#!/usr/bin/perl
# -----------------------------------------------------------------------------
# Verificateur de syntaxe PHP, ecrit en perl.
#
# POURQUOI. Le poste de developpement n a ni `php` ni `python` en ligne de
# commande : il n y a donc pas de `php -l`. Une faute de syntaxe ne se voit
# qu apres envoi FTP sur OVH, en 500 sur toutes les pages du site. Ce fichier
# est le filet avant envoi. Perl est disponible, fourni par Git Bash.
#
# CE QU IL FAIT. Il parcourt chaque fichier CARACTERE PAR CARACTERE avec un
# etat (html / php / chaine simple / chaine double / commentaire / heredoc) :
# ce qui est dans une chaine ou un commentaire ne compte pas. Un verificateur
# naif en expressions regulieres ne suffit pas — chaque « l'extension » ecrit
# dans un message francais passerait pour une chaine non terminee, et les faux
# positifs font qu on cesse de le lire.
#
# Il couvre les trois fautes qui font tomber le site :
#   1. chaine non refermee ;
#   2. accolades ou parentheses desequilibrees, et bloc alternatif sans
#      terminateur (`if:` sans `endif`) ;
#   3. balise HTML de structure non fermee dans une vue.
#
# CE QU IL NE FAIT PAS. Ce n est pas un analyseur PHP : il ne verifie ni les
# noms de fonctions, ni les types, ni les appels. Il attrape la faute qui
# empeche le fichier d etre lu, pas celle qui le fait mal se comporter.
#
# ETALONNAGE. Le bon resultat sur l ensemble de app/ est ZERO erreur. Tant
# qu il en signale sur des fichiers en service depuis des mois, c est lui
# qu il faut corriger, pas eux.
#
# USAGE :
#   perl outils/verifier-php.pl app/services/classeur.php
#   perl outils/verifier-php.pl $(find app -name '*.php')
#   perl outils/verifier-php.pl --tout
# -----------------------------------------------------------------------------
use strict;
use warnings;
use utf8;
binmode(STDOUT, ':encoding(UTF-8)');

my @fichiers = @ARGV;
if (!@fichiers || (@fichiers == 1 && $fichiers[0] eq '--tout')) {
    @fichiers = ();
    my @pile = ('app', 'public');
    while (my $dir = shift @pile) {
        next unless -d $dir;
        opendir(my $dh, $dir) or next;
        for my $e (sort readdir $dh) {
            next if $e eq '.' || $e eq '..';
            my $p = "$dir/$e";
            if (-d $p) { push @pile, $p; }
            elsif ($p =~ /\.php$/) { push @fichiers, $p; }
        }
        closedir $dh;
    }
}

my $total_erreurs = 0;
my $total_fichiers = 0;

# Balises HTML qui ne se ferment pas.
my %vides = map { $_ => 1 } qw(br hr img input meta link source track wbr col area base embed param);
# Balises de structure suivies dans les vues.
my %suivies = map { $_ => 1 } qw(div section form table thead tbody tfoot tr td th ul ol li
                                 p span details summary label select textarea button
                                 h1 h2 h3 h4 article aside nav main header footer);

for my $fichier (@fichiers) {
    $total_fichiers++;
    my @erreurs = verifier($fichier);
    if (@erreurs) {
        $total_erreurs += scalar @erreurs;
        print "\n$fichier\n";
        print "  ligne $_->[0] : $_->[1]\n" for @erreurs;
    }
}

print "\n";
print "$total_fichiers fichier(s) verifie(s), $total_erreurs erreur(s).\n";
print $total_erreurs == 0 ? "OK.\n" : "A CORRIGER AVANT ENVOI.\n";
exit($total_erreurs == 0 ? 0 : 1);

# -----------------------------------------------------------------------------

sub verifier {
    my ($fichier) = @_;
    my @erreurs;

    open(my $fh, '<:encoding(UTF-8)', $fichier) or return ([0, "illisible : $!"]);
    local $/;
    my $src = <$fh>;
    close $fh;
    return () unless defined $src;

    my $n = length $src;
    my $i = 0;
    my $ligne = 1;

    my $etat = 'html';        # html | php | chaine1 | chaine2 | com1 | com2 | heredoc
    my $heredoc_id = '';
    my $heredoc_nowdoc = 0;
    my $chaine_ligne = 0;

    my @accolades;            # [ligne] des { ouvertes
    my @parentheses;          # [ligne] des ( ouvertes
    my @crochets;             # [ligne] des [ ouverts
    my @alternatifs;          # [mot, ligne] des if:/foreach:/... ouverts
    my @balises;              # [nom, ligne] des balises HTML ouvertes

    while ($i < $n) {
        my $c = substr($src, $i, 1);
        my $c2 = substr($src, $i, 2);
        $ligne++ if $c eq "\n";

        # --- Hors PHP : on cherche l ouverture, et on suit le HTML -------------
        if ($etat eq 'html') {
            if ($c2 eq '<?') {
                $etat = 'php';
                $i += ($src =~ /\G<\?php/gc, substr($src, $i, 5) eq '<?php') ? 5 : 2;
                next;
            }
            if ($c eq '<') {
                my $reste = substr($src, $i, 200);

                # --- Le contenu de <script> et <style> n est pas du HTML -------
                #
                # Un commentaire JavaScript qui parle de « <button> » n ouvre
                # aucune balise, et un selecteur CSS non plus. Sans cette
                # exception, le gabarit — qui porte deux cents lignes de
                # JavaScript — se signalait a chaque commentaire citant une
                # balise. Un faux positif est pire qu une absence de controle :
                # il apprend a ne plus lire l outil.
                #
                # On saute donc d un bloc, du chevron ouvrant a la fermeture
                # correspondante, sans rien interpreter au passage.
                if ($reste =~ m{^<(script|style)\b}i) {
                    my $bloc = lc $1;
                    my $fin  = index(lc $src, "</$bloc", $i);
                    if ($fin > $i) {
                        # Les sauts de ligne du bloc comptent quand meme : les
                        # numeros de ligne des erreurs suivantes en dependent.
                        $ligne += (substr($src, $i, $fin - $i) =~ tr/\n//);
                        $i = $fin;
                        next;
                    }
                }

                if ($reste =~ m{^</\s*([a-zA-Z][a-zA-Z0-9]*)}) {
                    my $nom = lc $1;
                    if ($suivies{$nom}) {
                        my $trouve = -1;
                        for (my $k = $#balises; $k >= 0; $k--) {
                            if ($balises[$k][0] eq $nom) { $trouve = $k; last; }
                        }
                        if ($trouve >= 0) { splice(@balises, $trouve, 1); }
                    }
                } elsif ($reste =~ m{^<([a-zA-Z][a-zA-Z0-9]*)}) {
                    my $nom = lc $1;
                    # Auto-fermante : <img ... />
                    my $fin = index($src, '>', $i);
                    my $auto = ($fin > $i && substr($src, $fin - 1, 1) eq '/');
                    if ($suivies{$nom} && !$vides{$nom} && !$auto) {
                        push @balises, [$nom, $ligne];
                    }
                }
            }
            $i++;
            next;
        }

        # --- Chaines ---------------------------------------------------------
        if ($etat eq 'chaine1' || $etat eq 'chaine2') {
            my $quote = $etat eq 'chaine1' ? "'" : '"';
            if ($c eq '\\') { $i += 2; next; }
            if ($c eq $quote) { $etat = 'php'; $i++; next; }
            $i++;
            next;
        }

        # --- Commentaires ----------------------------------------------------
        if ($etat eq 'com1') {                       # // ou #
            if ($c eq "\n") { $etat = 'php'; }
            # Un ?> ferme aussi un commentaire de fin de ligne.
            if ($c2 eq '?>') { $etat = 'html'; $i += 2; next; }
            $i++;
            next;
        }
        if ($etat eq 'com2') {                       # /* ... */
            if ($c2 eq '*/') { $etat = 'php'; $i += 2; next; }
            $i++;
            next;
        }

        # --- Heredoc / nowdoc -------------------------------------------------
        if ($etat eq 'heredoc') {
            # Le terminateur doit etre en debut de ligne (eventuellement indente
            # depuis PHP 7.3), suivi de ; ou , ou fin de ligne.
            if ($c eq "\n") {
                my $reste = substr($src, $i + 1, length($heredoc_id) + 40);
                if ($reste =~ /^\s*\Q$heredoc_id\E\s*[;,)\r\n]/) {
                    $i += 1 + index($reste, $heredoc_id) + length($heredoc_id);
                    $etat = 'php';
                    next;
                }
            }
            $i++;
            next;
        }

        # --- Dans PHP ---------------------------------------------------------
        if ($c2 eq '?>') { $etat = 'html'; $i += 2; next; }
        if ($c2 eq '//') { $etat = 'com1'; $i += 2; next; }
        if ($c eq '#' && substr($src, $i, 2) ne '#[') { $etat = 'com1'; $i++; next; }
        if ($c2 eq '/*') { $etat = 'com2'; $i += 2; next; }

        if ($c eq "'") { $etat = 'chaine1'; $chaine_ligne = $ligne; $i++; next; }
        if ($c eq '"') { $etat = 'chaine2'; $chaine_ligne = $ligne; $i++; next; }

        if ($c2 eq '<<' && substr($src, $i, 3) eq '<<<') {
            my $reste = substr($src, $i + 3, 120);
            if ($reste =~ /^[ \t]*(['"]?)([A-Za-z_][A-Za-z0-9_]*)\1/) {
                $heredoc_id = $2;
                $heredoc_nowdoc = ($1 eq "'");
                $chaine_ligne = $ligne;
                $etat = 'heredoc';
                $i += 3 + index($reste, $heredoc_id) + length($heredoc_id);
                $i++ if $1 ne '';   # guillemet fermant
                next;
            }
        }

        if ($c eq '{') { push @accolades, $ligne; $i++; next; }
        if ($c eq '}') {
            push @erreurs, [$ligne, "« } » sans « { » correspondante"] unless @accolades;
            pop @accolades;
            $i++;
            next;
        }
        if ($c eq '(') { push @parentheses, $ligne; $i++; next; }
        if ($c eq ')') {
            push @erreurs, [$ligne, "« ) » sans « ( » correspondante"] unless @parentheses;
            pop @parentheses;
            $i++;
            next;
        }
        if ($c eq '[') { push @crochets, $ligne; $i++; next; }
        if ($c eq ']') {
            push @erreurs, [$ligne, "« ] » sans « [ » correspondant"] unless @crochets;
            pop @crochets;
            $i++;
            next;
        }

        # --- Syntaxe alternative : if: ... endif; ------------------------------
        # Reconnue seulement en debut de mot, pour ne pas confondre avec une
        # methode dont le nom finirait par « for ».
        if ($c =~ /[a-z]/i && ($i == 0 || substr($src, $i - 1, 1) !~ /[\w\$>]/)) {
            my $reste = substr($src, $i, 60);
            if ($reste =~ /^(if|elseif|else|foreach|for|while|switch)\b/) {
                my $mot = $1;
                # La syntaxe alternative met le « : » IMMEDIATEMENT apres la
                # parenthese fermante (ou apres le mot, pour « else »). Chercher
                # plus loin ferait entrer dans les chaines : un « : » ecrit dans
                # un message francais — « ATTENTION : compte inactif » — passait
                # alors pour l ouverture d un bloc.
                my $j = $i + length($mot);
                if ($mot ne 'else') {
                    # Aller a la parenthese ouvrante, puis a sa fermante.
                    $j++ while $j < $n && substr($src, $j, 1) =~ /[\s\r\n]/;
                    if ($j >= $n || substr($src, $j, 1) ne '(') {
                        $i += length($mot);
                        next;
                    }
                    my $prof = 0;
                    while ($j < $n) {
                        my $d = substr($src, $j, 1);
                        # Les chaines a l interieur de la condition sont sautees.
                        if ($d eq "'" || $d eq '"') {
                            my $q = $d;
                            $j++;
                            while ($j < $n) {
                                my $x = substr($src, $j, 1);
                                if ($x eq '\\') { $j += 2; next; }
                                last if $x eq $q;
                                $j++;
                            }
                        } elsif ($d eq '(') { $prof++; }
                        elsif ($d eq ')') { $prof--; last if $prof == 0; }
                        $j++;
                    }
                    $j++;   # apres la parenthese fermante
                }
                $j++ while $j < $n && substr($src, $j, 1) =~ /[\s\r\n]/;
                my $suite = substr($src, $j, 2);
                if ($suite =~ /^:[^:]/ && $mot !~ /^(elseif|else)$/) {
                    push @alternatifs, [$mot, $ligne];
                }
                $i += length($mot);
                next;
            }
            if ($reste =~ /^(endif|endforeach|endfor|endwhile|endswitch)\b/) {
                my $fin = $1;
                (my $ouvre = $fin) =~ s/^end//;
                if (!@alternatifs) {
                    push @erreurs, [$ligne, "« $fin » sans bloc alternatif ouvert"];
                } else {
                    pop @alternatifs;
                }
                $i += length($fin);
                next;
            }
        }

        $i++;
    }

    # --- Ce qui est reste ouvert a la fin du fichier --------------------------
    if ($etat eq 'chaine1' || $etat eq 'chaine2') {
        push @erreurs, [$chaine_ligne, "chaine non refermee (ouverte ici)"];
    }
    if ($etat eq 'heredoc') {
        push @erreurs, [$chaine_ligne, "heredoc « $heredoc_id » non referme"];
    }
    if ($etat eq 'com2') {
        push @erreurs, [$ligne, "commentaire /* non referme"];
    }
    push @erreurs, [$_, "« { » jamais refermee"] for @accolades;
    push @erreurs, [$_, "« ( » jamais refermee"] for @parentheses;
    push @erreurs, [$_, "« [ » jamais referme"] for @crochets;
    push @erreurs, [$_->[1], "« $_->[0]: » sans « end$_->[0] »"] for @alternatifs;
    push @erreurs, [$_->[1], "balise <$_->[0]> jamais fermee"] for @balises;

    return sort { $a->[0] <=> $b->[0] } @erreurs;
}