chkperl.pl to HTML.

Generated: Tue Jun 8 17:26:33 2010 from chkperl.pl 2010/05/01 20.6 KB.
#!/perl -w
# NAME: chkperl.pl
# AIM: Rought attempt to find an error in perl syntax
# 04/11/2009 - more tries at being helpful
# 2009/10/29 - some updates, and changes
# 9/1/2009 - geoff mclane - http://geoffair.net/mperl/
use strict;
use warnings;
unshift(@INC, "C:\\GTools\\perl");
require 'logfile.pl' or die "Unable to load logfile.pl ...\n";
# log file stuff
my ($LF);
my $pgmname = $0;
if ($pgmname =~ /(\\|\/)/) {
    my @tmpsp = split(/[\\\/]/,$pgmname);
    $pgmname = $tmpsp[-1];
}
my $perl_base = "C:\\GTools\\perl"; # perl directory
my $outfile = $perl_base."\\temp.$pgmname.txt";
open_log($outfile);

my $in_file = 'stripcols.pl';
#my $in_file = 'scanvc.pl';
#my $in_file = 'fixcasts.pl';
#my $in_file = 'convstruct.pl';
#my $in_file = 'tempp.txt';

# features
my $add_lines_to_log = 0;
my $out_subs = 0;
my $write_trim = 0;
my $trim_file = 'tempchk.txt';
my $load_log = 0;

# debug
my $dbg01 = 0; # show skipped comments
my $dbg02 = 0; # show skipped double quotes
my $dbg03 = 0; # show skipped regex
my $dbg04 = 0; # show skipped single quotes
my $dbg05 = 0; # show brace level enter/exit
my $dbg06 = 0; #
my $dbg07 = 0;

# program variables
my @warnings = ();
my $ret_val = 0;

sub prtw($) {
   my ($txt) = shift;
   prt($txt);
   $txt =~ s/\n$//;
   push(@warnings,$txt);
}

sub show_warnings() {
    if (@warnings) {
        prt( "\nGot ".scalar @warnings." WARNINGS ...\n" );
        foreach my $line (@warnings) {
            prt("$line\n" );
        }
    } else {
        prt("No warnings issued.\n");
    }
   #my $s = get_dbg_str();
   #prt( "WARNING: DEBUG ON [$s]\n" ) if length($s);
   prt("\n");
}

sub pgm_exit($$) {
   my ($val,$msg) = @_;
   show_warnings();
   if (length($msg)) {
      $msg .= "\n" if ( !($msg =~ /\n$/) );
      prt($msg);
   }
   close_log($outfile,$load_log);
   exit($val);
}


sub get_space_indent($) {
    my ($ln) = shift;
    my $len = length($ln);
    my ($i,$cc);
    $i = 0;
    for ($i = 0; $i < $len; $i++) {
        $cc = substr($ln,$i,1);
        last if ($cc =~ /\S/);
    }
    return $i;
}

################################################
# My particular time 'translation'
sub YYYYMMDD2($$) {
   #  0    1    2     3     4    5     6     7     8
   my ($tm, $sep) = @_;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($tm);
   $year += 1900;
   $mon += 1;
   my $ymd = "$year";
   $ymd .= $sep;
   if ($mon < 10) {
      $ymd .= '0'.$mon;
   } else {
      $ymd .= "$mon";
   }
   $ymd .= $sep;
   if ($mday < 10) {
      $ymd .= '0'.$mday;
   } else {
      $ymd .= "$mday";
   }
   return $ymd;
}

sub show_brace_stack($) {
   my ($rbcs) = @_;  # \@brcstk2
   my $cnt = scalar @{$rbcs};
   my ($min,$i,$brl,$last,$plast);
   my ($lnn,$lin,$len,$llmx,$llnn,$spi,$oc,$opn);
   my ($lnn2,$opn2,$brl2,$spi2);
   my ($msg);
   $min = 9999999;
   $last = 0;
   $plast = 0;
   $llmx = 0;
   for ($i = 0; $i < $cnt; $i++) {
      #                 0     1       2        3  4
      # push(@brcstk2, [$lnn, $oline, $brclvl, 1, $spindent]);
      if (${$rbcs}[$i][3]) {  # if this an OPEN
         $brl = ${$rbcs}[$i][2];
         if ($brl <= $min) {
            $min = $brl;
            $plast = $last;
            $last = $i;
         }
      }
   }
   for ($i = $plast; $i < $cnt; $i++) {
      $lnn = ${$rbcs}[$i][0];
      $lin = ${$rbcs}[$i][1];
      $brl = ${$rbcs}[$i][2];
      $len = length($lin);
      $llmx = $len if ($len > $llmx);
   }
   $llnn = $cnt;
   for ($i = $plast; $i < $cnt; $i++) {
      $lnn = ${$rbcs}[$i][0];
      $lin = ${$rbcs}[$i][1];
      $brl = ${$rbcs}[$i][2];
      $opn = ${$rbcs}[$i][3];
      $spi = ${$rbcs}[$i][4];
      $msg = '';
      if (($i + 1) < $cnt) {
         $lnn2 = ${$rbcs}[$i+1][0];
         $brl2 = ${$rbcs}[$i+1][2];
         $opn2 = ${$rbcs}[$i+1][3];
         $spi2 = ${$rbcs}[$i+1][4];
         if (($opn == $opn2) &&  # are both OPEN or CLOSE, and
             ($spi == $spi2)) {
            $msg .= '*W*';
         }
      } else {
         $lnn2 = -1;
      }
      $lnn2 = (($i + 1) < $cnt ? ${$rbcs}[$i+1][0] : -1);
      $oc  = ($opn ? 'O' : 'C');
      if (($oc eq 'O') && ($lnn == $lnn2) && ($opn2 == 0)) {
         $oc = 'B';
      }
      if ($lnn == $llnn) {
         prt("[".$brl."]");
      } else {
         $lin .= ' ' while (length($lin) < $llmx);
         prt("\n") if ($i);
         prt("$lin $msg$lnn-$oc($spi)[$brl]");
      }
      $llnn = $lnn;
   }
   prt("\n") if ($i);
   prt("Check the above for the ERROR, especially any '*W*' warning!\n");

}


sub process_file($) {
    my ($fil) = shift;
    my (@lines, $line, $max, $i, $j, $pc, $cc, $nc, $len);
    my ($inreg, $incomm, $bgnln, $lnn, $oline);
    my ($regt, $regx, $comm, $quot);
    my ($ppc, $stmnt, @nlns, $tmp, $t, $clnn);
    my ($spindent,$last_zero,$key,$bropenned,$brlv);
    my ($insub,$sublevel,$subtxt,@subarr,@subnames);
    my %hreg = ();
    my %open_brace = ();
    $last_zero = 0;
    my $add_chk_above = 1;
    if (open INF, "<$fil") {
        @lines = <INF>;
        close INF;
        $max = scalar @lines;
        prt( "Processing $max lines, from $fil...\n" );
        $cc = '';
        $pc = '';
        $inreg = 0;
        $incomm = 0;
        $bgnln = '';
        my @brcstk = ();
        my @brkstk = ();
        my @sbrkstk = ();
        my @brcstk2 = ();
        my @brkstk2 = ();
        my @sbrkstk2 = ();
        my $brclvl = 0;
        my $brklvl = 0;
        my $sbrklvl = 0;
        $stmnt = '';
        @nlns = ();
        $insub = 0;
        $sublevel = 0;
        $subtxt = '';
        @subarr = ();
        @subnames = ();
        for ($i = 0; $i < $max; $i++) {
            $lnn++;
            $clnn = sprintf("%05d",$lnn);
            $oline = $lines[$i];
            chomp $oline;
            $oline =~ s/\t/    /g;
            $spindent = get_space_indent($oline);
            $line = trim_all($oline);
            $len = length($line);
            next if ($len == 0);
            $bgnln = '';    # restart BEGINNING of LINE
            $bropenned = 0; # braces, openned and closed in THIS line
            for ($j = 0; $j < $len; $j++) {
                $ppc = $pc;
                $pc = $cc;
                $cc = substr($line,$j,1);
                $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                $subtxt .= $cc if ($insub);
                if (($cc eq '=')&&($nc eq '~')) {
                   # clear regex
                   $j++;
                   $j++;
                   $regx = '=~';
                   for (; $j < $len; $j++) {
                      $ppc = $pc;
                      $pc = $cc;
                      $cc = substr($line,$j,1);
                      $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                      $regx .= $cc;
                      $subtxt .= $cc if ($insub);
                      last if ($cc eq '/');
                   }
                   $regt = $pc; # assumed START OF regex, just before first '/'
                   $j++;
                   for (; $j < $len; $j++) {
                      $ppc = $pc;
                      $pc = $cc;
                      $cc = substr($line,$j,1);
                      $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                      $regx .= $cc;
                      $subtxt .= $cc if ($insub);
                      if ($cc eq '/') {
                          if ($pc ne "\\") {
                              last;
                          } elsif ($ppc eq "\\") {
                              last;
                          }
                      }
                   }
                   if ($regt eq 's') {
                      $j++;
                      for (; $j < $len; $j++) {
                         $ppc = $pc;
                         $pc = $cc;
                         $cc = substr($line,$j,1);
                         $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                         $subtxt .= $cc if ($insub);
                         $regx .= $cc;
                          if ($cc eq '/') {
                              if ($pc ne "\\") {
                                  last;
                              } elsif ($ppc eq "\\") {
                                  last;
                              }
                          }
                      }
                   }
                   if (defined $hreg{$regx}) {
                      $hreg{$regx}++;
                   } else {
                      $hreg{$regx} = 1;
                      prt("$lnn: skipped regx [$regx]\n") if ($dbg03);
                   }
                   next;    # back to NEXT character
                }

                if ($cc eq '#') { # skip balance of this line
                   $comm = substr($line,$j);
                   $subtxt .= $comm if ($insub);
                   $line = substr($line,0,$len - ($len - $j));
                   prt("$lnn: skipped comment [$comm]\n") if ($dbg01);
                   last;
                }

                if ($cc eq '"') {
                   # got to end of quotes
                   $quot = $cc;
                   $j++;
                   for (; $j < $len; $j++) {
                      $ppc = $pc;
                      $pc = $cc;
                      $cc = substr($line,$j,1);
                      $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                      $quot .= $cc;
                      $subtxt .= $cc if ($insub);
                      if ($cc eq '"') { # 2009/10/28 
                          # potential END of double quotes
                          if ($pc ne "\\") {
                              last; # no escape before it, so IT IS END
                          } else {
                              # there is an ESCAPE before the double quotes,
                              # but has that back slash been escaped
                              if ($ppc eq "\\") {
                                  last; # yes, so we have '\\"' ...
                              }
                          }
                      }
                   }
                   if ($j == $len) {
                      prt("Error: Line $lnn: Line EXPIRED in double QUOTES line=[$line] dq=[$quot]\n");
                      exit(1);
                   }
                   prt("$lnn: skipped quotes [$quot]\n") if ($dbg02);
                }
                if ($cc eq "'") {
                   # got to end of quotes
                   $quot = $cc;
                   $j++;
                   for (; $j < $len; $j++) {
                      $ppc = $pc;
                      $pc = $cc;
                      $cc = substr($line,$j,1);
                      $nc = (($j + 1) < $len) ? substr($line,$j+1,1) : '';
                      $quot .= $cc;
                      $subtxt .= $cc if ($insub);
                      if ($cc eq "'") { # 2009/10/28 
                          # potential END of single quotes
                          if ($pc ne "\\") {
                              last; # no escape before it, so IT IS END
                          } else {
                              # there is an ESCAPE before the double quotes,
                              # but has that back slash been escaped
                              if ($ppc eq "\\") {
                                  last; # yes, so we have '\\"' ...
                              }
                          }
                      }
                   }
                   if ($j == $len) {
                      prt("Error: Line $lnn: Line EXPIRED in single QUOTES\n");
                      exit(1);
                   }
                   prt("$lnn: skipped single [$quot]\n") if ($dbg04);
                }

                if ($cc eq '{') {
                    if ($insub && length($subtxt) && ($brclvl == $sublevel)) {
                        $tmp = $subtxt;
                        $tmp =~ s/\{$//;
                        $tmp =~ s/^sub\s+//;
                        $tmp = trim_all($tmp);
                        push(@subnames,$tmp);
                    }
                   push(@brcstk, [$lnn, $oline]);
                   $bropenned++;
                   $brclvl = scalar @brcstk;
                   push(@brcstk2, [$lnn, $oline, $brclvl, 1, $spindent]);
                   prt( "$lnn: Stacking: [$oline]$brclvl\n") if ($dbg05);
                } elsif ($cc eq '}') {
                   prt( "$lnn: Unstacking: [$oline]$brclvl:".($brclvl-1)."\n") if ($dbg05);
                   push(@brcstk2, [$lnn, $oline, $brclvl, 0, $spindent]);
                   if (@brcstk) {
                      pop @brcstk;
                   } else {
                      prtw( "WARNING: $lnn: Found '}' with NO brace stack!\n" );
                      show_brace_stack( \@brcstk2 );
                      $ret_val++;
                   }
                   $brclvl = scalar @brcstk;
                   if ($brclvl == 0) {
                       %open_brace = ();
                       $last_zero = $lnn;   # if a brace is left open, the last 'open' is AFTER here
                   }
                   $bropenned-- if ($bropenned);
                   if ($insub) {
                       if ($sublevel == $brclvl) {
                           prt( "[dbg07] $lnn: Exit subroutine. ($sublevel)\n" ) if ($dbg07);
                           $insub = 0;
                           push(@subarr,$subtxt) if (length($subtxt));
                           $subtxt = '';
                       }
                   }
                } elsif ($cc eq '[') {
                    push(@sbrkstk, "$lnn: $oline");
                    $sbrklvl = scalar @sbrkstk;
                } elsif ($cc eq ']') {
                    if (@sbrkstk) {
                        pop @sbrkstk;
                   } else {
                      prtw( "WARNING: $lnn: Found $cc with NO square bracket stack!\n" );
                      $ret_val++
                    }
                    $sbrklvl = scalar @sbrkstk;
                } elsif ($cc eq '(') {
                    push(@brkstk, "$lnn: $oline");
                    $brklvl = scalar @brkstk;
                } elsif ($cc eq ')') {
                    if (@brkstk) {
                        pop @brkstk;
                   } else {
                      prtw( "WARNING: $lnn: Found $cc with NO bracket stack!\n" );
                      $ret_val++;
                    }
                    $brklvl = scalar @brkstk;
                }
                if ($cc =~ /\s/) {
                    if ($bgnln eq 'sub') {
                        $insub = 1; # start a SUBROUTINE
                        $sublevel = $brclvl;    # and keep the level
                        prt( "[dbg07] $lnn: Entering a subroutine. ($sublevel)\n" ) if ($dbg07);
                        $subtxt = "sub$cc";
                    }
                }
                $bgnln .= $cc;
            } # FOR length of line

            $open_brace{$clnn} = [ $lnn, $oline, $spindent, $brclvl ] if ($bropenned);

            $line = trim_all($line);
            if (length($line)) {
                $t = $brclvl;
                $tmp = '';
                while ($t--) {
                    $tmp .= '    ';
                }
                $tmp .= $line;
                push(@nlns,$tmp);
                if ($line =~ /\{$/) {
                    # ok
                } elsif ($line =~ /^\}/) {
                    # ok
                } elsif ($line =~ /;$/) {
                    # ok
                } else {
                    prt( "$lnn: [$line] CHECKME\n" ) if ($dbg06);
                }
            }
            $subtxt .= "\n" if ($insub);
      } # FOR each line
      if ($brclvl) {
         prtw("WARNING: still stacked braces ($brclvl) - Error should be AFTER here...\n");
         $ret_val++;
         $max = scalar @brcstk;
         for ($i = 0; $i < $max; $i++) {
             $lnn  = $brcstk[$i][0];
             $line = $brcstk[$i][1];
            prt( "$lnn: $line\n" );
         }
         prt( "Brace openned at -\n" );
         foreach $key (sort keys %open_brace) {
             $tmp = $open_brace{$key};
             $lnn  = ${$tmp}[0];
             $line = ${$tmp}[1];
             $brlv = ${$tmp}[3];
             $brlv-- if ($brlv);
             if ($brlv && ($line =~ /\s*sub\s+(.+)/)) {
                prt("CHECK ABOVE HERE: sub starting, and brace level NOT ZERO!\n\n") if ($add_chk_above);
                $add_chk_above = 0;
             }
             prt( "$lnn:$brlv: $line\n" );
         }
         prt( "Note where the brace level stays above zero...\n" );
         prt( "The error should be BEFORE this point...\n" );
      } else {
         prt("brace level cleared\n");
      }
      if ($brklvl) {
         prtw("WARNING: still stacked brackets ($brklvl)\n");
         $ret_val++;
         foreach $line (@brkstk) {
            prt( "$line\n" );
         }
      } else {
         prt("bracket level cleared\n");
      }
      if ($sbrklvl) {
         prtw("WARNING: still stacked square brackets ($sbrklvl)\n");
         $ret_val++;
         foreach $line (@sbrkstk) {
            prt( "$line\n" );
         }
      } else {
         prt("square bracket level cleared\n");
      }

      $line = '';
      if ($out_subs && @subnames) {
          # $tmp = "Subroutine name list\n";
          # $tmp .= join("\n",@subnames);
          # $tmp .= "\n=== End sub name list ===\n";
          my $ymd = YYYYMMDD2( time(), '' );
          $len = 128;
          $pc = '';
          $ppc = "# Subroutine name list - generated by $pgmname, on $ymd\n";
          foreach $cc (@subnames) {
              if (length($cc) > $len) {
                  $ppc .= "# ".$pc.",\n" if (length($pc));
                  $ppc .= "# ".$cc.",\n";
                  $pc = '';
                  next;
              } elsif ((length($cc) + length($pc)) > $len ) {
                  $ppc .= "# ".$pc.",\n";
                  $pc = '';
              }
              $pc .= ', ' if (length($pc));
              $pc .= $cc;
          }
          $ppc .= "# ".$pc if (length($pc));
          $ppc .= "\n# === End sub name list ===\n";
          $line .= $ppc;
          prt($ppc);
      }
      $tmp = "List of LINES processed....\n";
      $tmp .= join("\n",@nlns);
      $tmp .= "\n";
      if ($add_lines_to_log) {
          prt( "============================================================\n" );
          prt( "$tmp" );
          prt( "============================================================\n" );
      }
      $line .= $tmp;

      if (@subarr) {
          $line .= "Subroutine text\n";
          $line .= join("\n",@subarr);
          $line .= "\n";
      }
      if ($write_trim) {
         write2file($line,$trim_file);
         prt( "Trimmed lines written to '$trim_file'\n" );
      }
   } else {
      prtw( "ERROR: Can NOT open $fil!\n" );
   }
}

#####################################
### MAIN ###

parse_args(@ARGV);
prt( "$pgmname ... Checking $in_file...\n" );
process_file($in_file);
pgm_exit($ret_val,"Normal exit");

######################################


sub give_help {
   prt("$pgmname - Version 0.0.2\n");
   prt("Usage: $pgmname input_file_name [Options]\n");
   prt("Check a perl script for obvious errors.\n");
   prt("Options:\n");
   prt(" -? (-h) = Give this help.\n");
   prt(" -a      = Add trimmed lines to log.\n");
   prt(" -l      = Load log file at exit.\n");
   prt(" -s      = Show 'sub' list at end.\n");
   prt(" -w      = Write trimmed lines to '$trim_file'.\n");
}

sub parse_args {
   my (@av) = @_;
   while (@av) {
      my $arg = $av[0];
      if ($arg =~ /^-/) {
         if (($arg eq '-?') || ($arg eq '-h') || ($arg eq '--help') ||
             ($arg eq '/?') || ($arg eq '/h') || ($arg eq '/help')) {
            give_help();
            pgm_exit(0,'Help exit');
         } elsif ($arg eq '-a') {
            $add_lines_to_log = 1;
            prt(" -a      = Add trimmed lines to log.\n");
         } elsif ($arg eq '-l') {
            $load_log = 1;
            prt(" -l      = Load log file at exit.\n");
         } elsif ($arg eq '-s') {
            $out_subs = 1;
            prt(" -s      = Show 'sub' list at end.\n");
         } elsif ($arg eq '-w') {
            $write_trim = 1;
            prt(" -w      = Write trimmed lines to '$trim_file'.\n");
         } else {
            prt("ERROR: Unknown argument [$arg]! Try -?...\n");
            pgm_exit(1,"aborting...\n");
         }
      } else {
         $in_file = $arg;
         prt( "Set input file to [$in_file]...\n" );
      }
      shift @av;
   }
}

# eof - chkperl.pl
index -|- top