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