sublist.pl to HTML.

index -|- end

Generated: Mon Aug 16 14:14:40 2010 from sublist.pl 2010/06/27 29.4 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 (which SHOULD be added to chkperl.pl!
# 27/06/2010 geoff mclane http://geoffair.net/mperl
# Subroutine name list - generated by sublist.pl, on 20100627
# set_debug($), pgm_exit($$), prtw($), show_warnings(), YYYYMMDD2($$), get_space_indent($), line_is_heredoc($$),
# process_file($), show_has_ref($), give_help, need_arg, parse_args
# === End sub name list ===
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 = 0;
#my $def_file = 'p2hall03.pl';
my $def_file = 'sublist.pl';
my $in_file = '';
my $add_lines_to_log = 0;
my $out_subs = 0;
my $write_trim = 0;
my $trim_file = 'tempchk1.txt';
my $max_out_len = 100;  # was 128

### program variables
my @warnings = ();
my $cwd = cwd();
my $os = $^O;
my $ret_val = 0;
my @input_list = ();

# debug
my $debug_on = 1;

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
my $dbg11 = 0;
my $dbg12 = 0;
my $dbg13 = 0;

my $max_dbg = $dbg13;
sub set_debug($) {
    my ($v) = @_;
    if ($v == 1) {
        $dbg01 = 1;
        return 0;
    } elsif ($v == 2) {
        $dbg02 = 1;
        return 0;
    } elsif ($v == 3) {
        $dbg03 = 1;
        return 0;
    } elsif ($v == 4) {
        $dbg04 = 1;
        return 0;
    } elsif ($v == 5) {
        $dbg05 = 1;
        return 0;
    } elsif ($v == 6) {
        $dbg06 = 1;
        return 0;
    } elsif ($v == 7) {
        $dbg07 = 1;
        return 0;
    } elsif ($v == 8) {
        $dbg08 = 1;
        return 0;
    } elsif ($v == 9) {
        $dbg09 = 1;
        return 0;
    } elsif ($v == 10) {
        $dbg10 = 1;
        return 0;
    } elsif ($v == 11) {
        $dbg11 = 1;
        return 0;
    } elsif ($v == 12) {
        $dbg12 = 1;
        return 0;
    } elsif ($v == 13) {
        $dbg13 = 1;
        return 0;
    }
    return 1;
}

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("[dbg13] brace level cleared\n") if ($dbg13);
    }
    if ($brklvl) {
        prtw("WARNING: still stacked brackets ($brklvl)\n");
        $ret_val++;
        foreach $line (@brkstk) {
            prt( "$line\n" );
        }
    } else {
        prt("[dbg13] bracket level cleared\n") if ($dbg13);
    }

    if ($sbrklvl) {
        prtw("WARNING: still stacked square brackets ($sbrklvl)\n");
        $ret_val++;
        foreach $line (@sbrkstk) {
            prt( "$line\n" );
        }
    } else {
        prt("[dbg13] square bracket level cleared\n") if ($dbg13);
    }

    $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 = $max_out_len;  # was 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");
            }
        }
    }
}

sub get_sub_hr($$) {
    my ($sra,$rc) = @_;
    my %h = ();
    my $cnt = 0;
    foreach my $s (@{$sra}) {
        $s =~ s/\(.*\)$//;
        if (!defined $h{$s}) {
            $h{$s} = 1;
            $cnt++;
        }
    }
    ${$rc} = $cnt;
    return \%h;
}

sub cmp_2_rh($$$$) {
    my ($f1, $f2, $rh1, $rh2) = @_;
    my @shared = ();
    my $cnt = 0;
    my %sh = ();
    my $s1 = '';
    foreach $s1 (keys %{$rh1}) {
        if (defined ${$rh2}{$s1}) {
            push(@shared,$s1);
        }
    }
    if (@shared) {
        $cnt = scalar @shared;
        @shared = sort @shared;
        if ($dbg12) {
            prt("[dbg12] Files $f1 and $f2 share $cnt subs...\n");
            prt(" - [".(join(" ",@shared))."]\n" );
        }
        foreach $s1 (@shared) {
            $sh{$s1} = 1;
        }
    } else {
        prt("[dbg12] Files $f1 and $f2 have NO shared subs...\n") if ($dbg12);
    }
    return \%sh;
}


sub process_input_list($) {
    my ($ra) = @_;  # = \@input_list
    my %h = ();
    my %done = ();
    my @pair = ();
    my $cnt = 0;
    my ($f,$hr,$sra,$nrh,$pkey,$shr);
    foreach $f (@{$ra}) {
        $hr = process_file($f);
        show_has_ref($hr);
        $h{$f} = $hr;
        $cnt++;
    }
    if ($cnt > 1) {
        foreach $f (keys %h) {
            $hr = $h{$f};
            if (defined ${$hr}{'A_SUBS'}) {
                $sra = ${$hr}{'A_SUBS'};
                $nrh = get_sub_hr($sra,\$cnt);
                ${$hr}{'H_SUBS'} = $nrh;
                prt("[dbg11] File $f has $cnt subs...\n") if ($dbg11);
            }
        }
        foreach $f (keys %h) {
            $hr = $h{$f};
            if (defined ${$hr}{'H_SUBS'}) {
                $nrh = ${$hr}{'H_SUBS'};
                foreach my $f2 (keys %h) {
                    if ($f ne $f2) {
                        @pair = ();
                        push(@pair,$f);
                        push(@pair,$f2);
                        @pair = sort @pair;
                        $pkey = join(" & ",@pair);
                        my $hr2 = $h{$f2};
                        if (defined ${$hr2}{'H_SUBS'}) {
                            my $nrh2 = ${$hr2}{'H_SUBS'};
                            if (!defined $done{$pkey}) {
                                $done{$pkey} = cmp_2_rh($f, $f2, $nrh, $nrh2);
                            }
                        }
                    }
                }
            }
        }
    }
    return \%done;
}

sub show_ref_h($) {
    my ($rh) = @_;
    my $min = 0;
    my ($len);
    foreach my $key (keys %{$rh}) {
        my $sh = ${$rh}{$key};
        my @arr = sort keys(%{$sh});
        if (@arr) {
            $len = length($key);
            $min = $len if ($len > $min);
        }
    }
    foreach my $key (keys %{$rh}) {
        my $sh = ${$rh}{$key};
        my @arr = sort keys(%{$sh});
        if (@arr) {
            $key .= ' ' while (length($key) < $min);
            prt("$key: ".join(", ", @arr)."\n");
        }
    }

}

#########################################
### MAIN ###
parse_args(@ARGV);
my $ref_h = process_input_list(\@input_list);
my $cnt_f = scalar @input_list;
show_ref_h($ref_h) if ($cnt_f > 1);
pgm_exit(0,"Normal exit(0)");
########################################
sub give_help {
    prt("$pgmname: version 0.0.1 2010-05-05\n");
    prt("Usage: $pgmname [options] in_file_name\n");
    prt("Options:\n");
    prt(" -h or -?   = This help, and exit.\n");
    prt(" -ll        = Load log at end.\n");
    prt(" -s         = SUb list to log file.\n");
    prt(" -w         = Write trimmed text to $trim_file\n");
    prt(" -d1-$max_dbg     = Set degbu 1 to 10 on\n");
    prt("Read the in_file_name, and process as a perl script,\n");
    prt("extract and list the 'sub' names within.\n");
    prt("It also does a brace({}), bracket{()}, and square bracket {[]} check,\n");
    prt("like chkperl.pl...\n");
}

sub need_arg {
    my ($arg,@av) = @_;
    pgm_exit(1,"ERROR: [$arg] must have follwoing argument!\n")
        if (!@av);
}
sub parse_args {
    my (@av) = @_;
    my ($num);
    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)");
            } elsif ($sarg =~ /^l/i) {
                $load_log = 1;
                prt("Set to load log at end.\n");
            } elsif ($sarg =~ /^s/i) {
                $out_subs = 1;
                prt("Set to output subs to log file.\n");
            } elsif ($sarg =~ /^w/i) {
                $write_trim = 1;
                prt("Set to write trim text to $trim_file file.\n");
            } elsif ($sarg =~ /^d(\d+)$/i) {
                $num = $1;
                if (set_debug($num)) {
                    pgm_exit(1,"ERROR: Invalid argument [$arg]! Only -d1-$max_dbg allowed!\n");
                }
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            if (@input_list) {
                # started LIST - add to list
                push(@input_list,$arg);
            } elsif (length($in_file) > 0) {
                # start list
                push(@input_list,$in_file);
                push(@input_list,$arg);
            }
            $in_file = $arg;
            prt("Set input to [$in_file]\n");
        }
        shift @av;
    }
    if ($debug_on && (length($in_file) == 0)) {
        $in_file = $def_file;
        prt("Set input to DEFAULT [$in_file] for DEBUG ON\n");
        $load_log = 1;
        $out_subs = 1;
        $write_trim = 1;
    }
    if (length($in_file) == 0) {
        pgm_exit(1,"ERROR: No input file found!\n");
    }
    if ( ! @input_list) {
        push(@input_list,$in_file);
    }
}

# eof - sublist.pl

index -|- top