sublist02.pl to HTML.

index -|- end

Generated: Mon Aug 16 14:14:40 2010 from sublist02.pl 2010/06/27 23 KB.

#!/perl -w
# NAME: sublist.pl
# AIM: Give a perl script name, list the 'sub' contained
# Took file decoder from chkperl.pl, but needed to 'fix' a few things
# regarding regex skipping, and adding heredoc handling
# 27/06/2010 geoff mclane http://geoffair.net/mperl
use strict;
use warnings;
use File::Basename;  # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[.]*/] )
use Cwd;
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 =~ /\w{1}:\\.*/) {
    my @tmpsp = split(/\\/,$pgmname);
    $pgmname = $tmpsp[-1];
}
my $perl_dir = 'C:\GTools\perl';
my $outfile = $perl_dir."\\temp.$pgmname.txt";
open_log($outfile);

# user variables
my $load_log = 1;
my $in_file = 'p2hall03.pl';
my $add_lines_to_log = 0;
my $out_subs = 0;
my $write_trim = 1;
my $trim_file = 'tempchk1.txt';

### program variables
my @warnings = ();
my $cwd = cwd();
my $os = $^O;
my $ret_val = 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;
my $dbg08 = 0; # debug output of REGEX skipping
my $dbg09 = 0; # debug output of line_is_heredoc
my $dbg10 = 0; # more HEREDOC debug

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


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

sub show_warnings() {
   if (@warnings) {
      prt( "\nGot ".scalar @warnings." WARNINGS...\n" );
      foreach my $itm (@warnings) {
         prt("$itm\n");
      }
      prt("\n");
   } else {
      prt( "\nNo warnings issued.\n\n" );
   }
}

################################################
# 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 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;
}

# add heredoc - like
# $text = [function] <<[<]["]END["]; .... END
sub line_is_heredoc($$) {
    my ($ln,$rhde) = @_;
    my $len = length($ln);
    my ($i,$ch,$cc,$ed);
    for ($i = 0; $i < $len; $i++) {
        $ch = substr($ln,$i,1);
        last if ($ch eq '=');   # end on EQUAL,
        last if ($ch eq '<');   # of '<' char
    }
    if ($ch eq '=') {
        $i++; # bump past EQUAL sign
        return 0 if ($i >= $len);
        prt("Got '=' at $i\n") if ($dbg09);
        for (; $i < $len; $i++) {
            $ch = substr($ln,$i,1);
            last if ($ch =~ /\S/);
        }
    }
    $i++;
    return 0 if ($i >= $len);
    if ($ch ne '<') {
        prt("Searching first '<'\n") if ($dbg09);
        for (; $i < $len; $i++) {
            $ch = substr($ln,$i,1);
            last if ($ch eq '<');
        }
        return 0 if ($i >= $len);
    }
    # got first '<' - go for second immediately
    prt("Got 1st '<' at $i\n") if ($dbg09);
    return 0 if ($i >= $len);
    $ch = substr($ln,$i,1);
    prt("Next char is '$ch' at $i\n") if ($dbg09);
    return 0 if ($ch ne '<');
    # got two '<' chars, go for END item
    $i++;
    return 0 if ($i >= $len);
    prt("Got 2nd '<' at $i\n") if ($dbg09);
    $ch = substr($ln,$i,1);
    if ($ch eq '<') {
        $i++;   # eat THIRD, if any
        return 0 if ($i >= $len);
        $ch = substr($ln,$i,1);
    }
    $cc = '';
    if (($ch eq '"')||($ch eq "'")) {
        $cc = $ch;
        $i++;
        return 0 if ($i >= $len);
        $ch = substr($ln,$i,1);
        prt("Got quotes '$cc', 1st char [$ch] at $i\n") if ($dbg09);
    }
    $ed = $ch;  # first char of END heredoc
    $i++;
    return 0 if ($i >= $len);
    for (; $i < $len; $i++) {
        $ch = substr($ln,$i,1);
        last if ($ch =~ /(\s|;)/);
        last if (length($cc) && ($ch eq $cc));
        $ed .= $ch;
    }
    prt("End HD on char '$ch', with [$ed] accumulated...\n") if ($dbg09);
    if ($ch eq $cc) {
        # still to end line
        $i++;
        return 0 if ($i >= $len);
        for (; $i < $len; $i++) {
            $ch = substr($ln,$i,1);
            last if ($ch eq ';');
            return 0 if ($ch =~ /\S/);
        }
        return 0 if ($i >= $len);
    }
    ${$rhde} = $ed;
    return 1;
}

sub process_file($) {
    my ($fil) = shift;
    my %hash = ();
    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 ($regs,$hdend);
    my %hreg = ();
    my %open_brace = ();
    $last_zero = 0;
    my $add_chk_above = 0;
    my $space = ' ';
    $hash{'S_FILE'} = $fil;
    if (!open INF, "<$fil") {
      prtw( "ERROR: Can NOT open $fil!\n" );
      return \%hash;
    }
    @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 "<")&&(line_is_heredoc($line,\$hdend))) {
                # stay to clear HEREDOC (possibly)
                prt("$clnn: Got HEREDOC start [$line], end with [$hdend]\n") if ($dbg10);
                $j++;
                $subtxt .= substr($line,$j) if ($insub);
                $i++;
                for (; $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);
                    $subtxt .= $line if ($insub);
                    last if ($oline =~ /^$hdend/);
                }
                prt("$clnn: Got HEREDOC end [$line]\n") if ($dbg10);
                $j = $len;
                next;
            }
            if (($cc eq '=')&&($nc eq '~')) {
               # clear regex
               $j++;
               $j++;
               if ($dbg08) {
                   $space = " " x $j;
                   prt("$clnn:  ".$space."[ = Begin regex\n");
                   prt("$clnn: [$line], at $j, entered regex!\n");
               }
               $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 '/');
                  last if ($cc =~ /\S/);    # non-white-space char
               }
               #$regt = $pc; # assumed START OF regex, just before first '/'
               $regs = $cc; # assumed START OF regex, either just before first '/' or some char
               $regt = 'm'; # assume MATCH
               if (($cc eq 'm')||($cc eq 's')) {
                    $regt = $cc;    # set reg TYPE (SUB or MATCH)
                    $regs = $nc;
                    $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);
               } elsif (($cc eq 't')&&($nc eq 'r')) {
                    $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);
                    $regt = 'tr';
                    $regs = $nc;
                    $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);
               }
               $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 $regs) {
                      if ($pc ne "\\") {
                           if ($dbg08) {
                               $space = " " x $j;
                               prt("$clnn:  ".$space." ] = End first regex [$regt] [$regs]\n");
                           }
                          last;
                      #} elsif ($ppc eq "\\") {
                      #    last;
                      }
                  }
               }
               if (($regt eq 's')||($regt eq 'tr')) {
                  $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 "\\") {
                               if ($dbg08) {
                                   $space = " " x $j;
                                   prt("$clnn:  ".$space." ] = End second regex [$regt] [$regs]\n");
                               }
                              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 line=[$line]\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 line [$line]\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" );
    }
    $hash{'A_SUBS'} = [ @subnames ];
    return \%hash;
}

sub show_has_ref($) {
    my ($hr) = @_;
    my ($key,$ra,$sub,$cnt,$file,$ccnt);
    $file = 'Unknown';
    foreach $key (keys %{$hr}) {
        if ($key eq 'S_FILE') {
            $file = ${$hr}{$key};
            last;
        }
    }
    foreach $key (keys %{$hr}) {
        if ($key eq 'A_SUBS') {
            $ra = ${$hr}{$key};
            $cnt = scalar @{$ra};
            prt("List of $cnt sub in file [$file]\n");
            $cnt = 0;
            foreach $sub (@{$ra}) {
                $cnt++;
                $ccnt = sprintf("%3d:",$cnt);
                prt("$ccnt [$sub]\n");
            }
        }
    }
}

#########################################
### MAIN ###
parse_args(@ARGV);

my $has_ref = process_file($in_file);
show_has_ref($has_ref);

pgm_exit(0,"Normal exit(0)");
########################################
sub give_help {
    prt("$pgmname: version 0.0.1 2010-05-05\n");
}
sub need_arg {
    my ($arg,@av) = @_;
    pgm_exit(1,"ERROR: [$arg] must have follwoing argument!\n")
        if (!@av);
}
sub parse_args {
    my (@av) = @_;
    while (@av) {
        my $arg = $av[0];
        if ($arg =~ /-/) {
            my $sarg = substr($arg,1);
            $sarg = substr($sarg,1) while ($sarg =~ /-/);
            if (($sarg =~ /h/i)||($sarg eq '?')) {
                give_help();
                pgm_exit(0,"Help exit(0)");
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            $in_file = $arg;
            prt("Set input to [$in_file]\n");
        }
        shift @av;
    }
}

# eof - template.pl

index -|- top