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