getfunclist.pl to HTML.

index -|- end

Generated: Sun Apr 15 11:46:19 2012 from getfunclist.pl 2011/09/24 18.1 KB.

#!/usr/bin/perl -w
# NAME: getfunclist.pl
# AIM: Given a perl script, scan, and output function list, and line number
# 24/09/2011 - Turn of $debug_on, and add '#' to start of list
# 22/07/2011 - If given TWO perl files, compare the function lists
# 28/08/2010 geoff mclane http://geoffair.net/mperl
use strict;
use warnings;
use File::Basename;  # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[^.]*/] )
use Cwd;
my $perl_dir = 'C:\GTools\perl';
unshift(@INC, $perl_dir);
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 $outfile = $perl_dir."\\temp.$pgmname.txt";
open_log($outfile);

# user variables
my $vers = "0.0.2 2011-07-23"; # add compare if 2 files given
#my $vers = "0.0.1 2010-09-28"; # intital version
my $load_log = 0;
my $in_file = '';
my $in_file2 = '';

my $max_lines = 40;
my $max_line = 75;

my $tmp_copy = $perl_dir."\\tempcopy.txt";

my $verbosity = 0;

sub VERB1() { return ($verbosity >= 1); }
sub VERB2() { return ($verbosity >= 1); }
sub VERB5() { return ($verbosity >= 1); }
sub VERB9() { return ($verbosity >= 1); }

### program variables
my @warnings = ();
my $cwd = cwd();
my $os = $^O;
my ($hash_ref1,$hash_ref2);

# DEBUG
my $debug_on = 0;
my $def_file1 = 'solve.pl';
my $def_file2 = 'fg_square.pl';

my $dbg_01; # show end of quotes
my $dbg_02; # show end of regex
my $dbg_03; # show end of function

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" );
   }
}

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 is_prototype($) {
    my $line = shift;
    return 1 if ($line =~ /^sub\s+\w+\s*\(*.*\)*\s*;/);
    return 0;
}

sub process_in_file($) {
    my $inf = shift;
    if (! open INF, "<$inf") {
        pgm_exit(1,"ERROR: Unable to open file [$inf]!\n");
    }
    my @lines = <INF>;
    close INF;
    my ($line,$lnn,$i,$lncnt,$finds,$opt,$proto,$func,$fline);
    my ($len,$j,$ch,$pc,$nc,$j2,$inreg,$inquot,$qc,$reg,$quot);
    my ($isfun,$tmp,$brcnt);
    my ($reg1,$regt,$regc,$rbc,$currfun);
    $lnn = 0;
    $lncnt = scalar @lines;
    $finds = 0;
    $opt = 0;
    $proto = 0;
    my %hash = ();
    my %funcs = ();
    my %funclines = ();
    $hash{'file'} = $inf;
    $hash{'functions'} = \%funcs;
    $hash{'funlines'} = \%funclines;
    prt("\nProcessing $lncnt lines from file [$inf]...\n");
    $ch = '';
    $inreg = 0;
    $inquot = 0;
    $qc = '';
    my @brackets = ();
    my @braces = ();
    my @brreg = ();
    my @funlines = ();
    $isfun = 0;
    for ($i = 0; $i < $lncnt; $i++) {
        $lnn++;
        $fline = $lines[$i];
        chomp $fline;
        $line = trim_all($fline);
        $len = length($line);
        next if ($len == 0);
        next if ($line =~ /^#/);
        if ($line =~ /^sub\s+(\w+)\s*\(*.*\)*\s*\{/) {
            $func = $1;
            $currfun = $func;
            prt("$lnn: $line\n") if (VERB9());
            $finds++;
            $funcs{$func} = $lnn;
            if ($isfun) {
                prtw("WARNING: Function STARTED while still in function!\n");
            }
            $isfun = 1;
            if (@braces) {
                $tmp = scalar @braces;
                prtw("WARNING:$lnn: FUNCTION started with brace count $tmp [$line]\n");
            }
        } elsif ($line =~ /^sub\s+(\w+)\s*\(*.*\)*\s*/) {
            $func = $1;
            if (is_prototype($line)) {
                prt("$lnn: $line (PROTOTYPE)\n") if (VERB5());
                $proto++;
            } else {
                prtw("WARNING: $lnn: $line (MAYBE - CHECK ME!!!)\n");
                $opt++;
                if ($isfun) {
                    prtw("WARNING: Function STARTED while still in function!\n");
                }
                $isfun = 1;
                if (@braces) {
                    $tmp = scalar @braces;
                    prtw("WARNING:$lnn: Function started with brace count $tmp [$line]\n");
                }
                $funcs{$func} = $lnn;
                $finds++;
                $currfun = $func;
            }
        }
        for ($j = 0; $j < $len; $j++) {
            $j2 = $j + 1;
            $pc = $ch;
            $ch = substr($line,$j,1);
            $nc = ($j2 < $len) ? substr($line,$j2,1) : '';
            if ($inreg) {
                if (length($reg)) {
                    $rbc = scalar @brreg; # get count BEFORE!
                    $reg .= $ch;    # add to regexe
                    if ($regt eq 'm') {
                        if (($ch eq $reg1)&&($pc ne '\\')) {
                            $inreg = 0;
                            if (@brreg) {
                                $tmp = scalar @brreg;
                                prtw("WARNING: End REGEX, with $tmp brackets on stack!\n");
                            }
                            prt("$lnn: End REGEX: $regt $reg1 [$reg]\n") if ($dbg_02);
                            next;
                        }
                    } else {  # if ($regt eq 's')
                        if (($ch eq $reg1)&&($pc ne '\\')) {
                            if ($regc == 1) {
                                $inreg = 0;
                                if (@brreg) {
                                    $tmp = scalar @brreg;
                                    prtw("WARNING: End REGEX, with $tmp brackets on stack!\n");
                                }
                                prt("$lnn: End REGEX: $regt $reg1 [$reg]\n") if ($dbg_02);
                                next;
                            }
                            $regc++;
                        }
                    }
                    if ($pc ne '\\') {
                        if ($ch eq '(') {
                            push(@brreg,[$lnn,$line,$j]);
                        } elsif ($ch eq ')') {
                            if (@brreg) {
                                pop @brreg;
                            } else {
                                prt("WARNING: $lnn: [$line] Close regex bracket, but NONE on stack!\n");
                            }
                        }
                    }
                } else {
                    # no length yet - get the start of the regex expression
                    if ( !($ch =~ /\s/) ) {
                        $regt = 'm';
                        $regc = 0;
                        if ($ch eq 's') {
                            $regt = $ch;
                            $reg1 = $nc;
                        } elsif ($ch eq 'm') {
                            $regt = $ch;
                            $reg1 = $nc;
                        } else {
                            $reg1 = $ch;
                            $reg .= $ch;
                        }
                    }
                }
                if (($rbc == 0)&&($ch eq ')')&&($pc ne '\\')) {
                    $inreg = 0;
                    prtw("WARNING:$lnn:$j: End regex: t=$regt 1=$reg1 [$reg] [$line] CHECK ME\n"); # if ($dbg_02);
                    next;
                }
            } else {
                if (($pc eq '=')&&($ch eq '~')) {
                    $inreg = 1;
                    $reg = '';
                    next;
                }
                if ($inquot) {
                    if (($ch eq $qc)&&($pc ne '\\')) {
                        prt("$lnn: End quote $qc [$quot]\n") if ($dbg_01);
                        $inquot = 0;
                        next;
                    }
                    $quot .= $ch;
                } else {
                    if (($ch eq '"')||($ch eq "'")) {
                        $qc = $ch;
                        $quot = '';
                        $inquot = 1;
                        next;
                    }
                    # not in quote, or regex
                    if ($ch eq '#') {
                        # begin of a trailing comment
                        last; # end of line
                    }
                    if ($ch eq '(') {
                        push(@brackets,[$lnn,$line,$j]);
                    } elsif ($ch eq ')') {
                        if (@brackets) {
                            pop @brackets;
                        } else {
                            prtw("WARNING: $lnn: [$line] bracket closed with NONE open!\n");
                        }
                    } elsif ($ch eq '{') {
                        push(@braces,[$lnn,$line,$j]);
                        $brcnt = scalar @braces;
                    } elsif ($ch eq '}') {
                        if (@braces) {
                            pop @braces;
                        } else {
                            prtw("WARNING: $lnn: [$line] braces closed with NONE open!\n");
                        }
                        $brcnt = scalar @braces;
                    }
                }
            }
        }
        # end of line parsing
        if ($isfun) {
            push(@funlines,$fline);
            if ($brcnt == 0) {
                $tmp = scalar @funlines;
                $funclines{$currfun} = [@funlines];
                @funlines = ();
                $isfun = 0;
                prt("$lnn: End of function $tmp lines\n") if ($dbg_03);
            }
        }
        if ($inreg) {
            $line = trim_all($reg);
            if ($line =~ /;$/) {
                $inreg = 0; # close the regex
                prt("$lnn: End regex: [$reg]\n") if ($dbg_02);
            } elsif ($line =~ /\)$/) {
                $inreg = 0; # close the regex
                prt("$lnn: End regex: [$reg]\n") if ($dbg_02);
            }
        }
        prtw("WARNING: $lnn: End of line still in QUOTE ($qc) [$quot]!\n") if ($inquot);
        prtw("WARNING: $lnn: End of line still in REGEXE [$reg]!\n") if ($inreg);
    }
    # end of file
    if (@brackets) {
        $len = scalar @brackets;
        prtw("WARNING: End of file [$inf] with $len brackets open!\n");
        for ($i = 0; $i < $len; $i++) {
            $lnn = $brackets[$i][0];
            $line = $brackets[$i][1];
            $j = $brackets[$i][2];
            prt("$lnn:$j: [$line]\n");
        }
    }
    if (@braces) {
        $len = scalar @braces;
        prtw("WARNING: End of file [$inf] with $len braces open!\n");
    }
    prt("Done $lncnt lines for $finds, $proto prototypes, $opt optional...\n");
    my @arr = sort keys(%funcs);
    my $msg = '';
    my $ln_cnt = 0;
    $line = '';
    foreach $func (@arr) {
        $line .= ", " if (length($line));
        $line .= $func;
        if (length($line) > $max_line) {
            $msg .= "# $line\n";
            $line = '';
            $ln_cnt++;
        }
    }
    if (length($line)) {
        $msg .= "# $line";
        $ln_cnt++;
    }
    prt("# List: $msg\n");
    if ($ln_cnt > $max_lines) {
        $load_log = 1;
    }
    return \%hash;
}

sub compare_line_arrays($$) {
    my ($rla1,$rla2) = @_;
    my $cnt1 = scalar @{$rla1};
    my $cnt2 = scalar @{$rla2};
    if ($cnt1 ne $cnt2) {
        return ":diffc";
    }
    my ($i,$line1,$line2);
    for ($i = 0; $i < $cnt1; $i++) {
        $line1 = ${$rla1}[$i];
        $line2 = ${$rla2}[$i];
        if ($line1 ne $line2) {
            return ":diffl";
        }
    }
    return ":s";
}

sub compare_lists($$) {
    my ($mhr1,$mhr2) = @_;
    my ($hr1,$hr2,$rfl1,$rfl2,$rla1,$rla2);
    my ($lcnt1,$lcnt2,$tmp);
    $hr1 = ${$mhr1}{'functions'};
    $hr2 = ${$mhr2}{'functions'};
    $rfl1 = ${$mhr1}{'funlines'};
    $rfl2 = ${$mhr2}{'funlines'};
    my @k1 = keys %{$hr1};
    my @k2 = keys %{$hr2};
    my $cnt1 = scalar @k1;
    my $cnt2 = scalar @k2;
    my ($key1,$key2,$fnd);
    my %common = ();
    my %missed1 = ();
    my %missed2 = ();
    prt("\nComparing $cnt1 from $in_file, with $cnt2 from $in_file2...\n");
    my ($msg,$line);
    foreach $key1 (sort keys %{$hr1}) {
        $fnd = 0;
        foreach $key2 (sort keys %{$hr2}) {
            if ($key1 eq $key2) {
                $fnd = 1;
                last;
            }
        }
        if ($fnd) {
            $common{$key1} = 1;
        } else {
            $missed1{$key1} = 1;
        }
    }
    foreach $key2 (sort keys %{$hr2}) {
        $fnd = 0;
        foreach $key1 (sort keys %{$hr1}) {
            if ($key1 eq $key2) {
                $fnd = 1;
                last;
            }
        }
        if ($fnd) {
            $common{$key2} = 1;
        } else {
            $missed2{$key2} = 1;
        }
    }
    my $cntc = scalar keys(%common);
    my $cntm1 = scalar keys(%missed1);
    my $cntm2 = scalar keys(%missed2);
    prt("Found $cntc common, $cntm1 not in 2, $cntm2 not in 1\n");
    prt("\nFound $cntc common functions...\n");
    $msg = '';
    $line = '';
    my $smcnt = 0;
    my %same = ();
    my $copy = '';
    foreach $key1 (sort keys %common) {
        $rla1 = ${$rfl1}{$key1};
        $rla2 = ${$rfl2}{$key1};
        $tmp = compare_line_arrays($rla1,$rla2);
        if ($tmp eq ':s') {
            $smcnt++;
            $same{$key1} = $smcnt;
        }
    }
    if ($smcnt) {
        prt("Found $smcnt which appear identical...\n");
        foreach $key1 (sort keys %same) {
            $line .= ' ' if (length($line));
            $line .= "$key1";
            if (length($line) > $max_line) {
                $msg .= "$line\n";
                $line = '';
            }
        }
        $msg .= $line if (length($line));
        prt("$msg\n");
    }
    prt("And ".($cntc - $smcnt)." which appear DIFFERENT...\n");
    foreach $key1 (sort keys %common) {
        next if (defined $same{$key1});
        $rla1 = ${$rfl1}{$key1};
        $rla2 = ${$rfl2}{$key1};
        $lcnt1 = scalar @{$rla1};
        $lcnt2 = scalar @{$rla2};
        $tmp = "$lcnt1";
        if ($lcnt1 != $lcnt2) {
            $tmp = "$lcnt1:$lcnt2";
        }
        $tmp .= compare_line_arrays($rla1,$rla2);
        prt("[$key1]$tmp\n");
    }

    # These need to potentially be copied to file 2
    prt("\nMissed $cntm1 in [$in_file], but NOT in [$in_file2]...\n");
    $msg = '';
    $line = '';
    $copy = '';
    foreach $key1 (sort keys %missed1) {
        $rla1 = ${$rfl1}{$key1}; # get the line list
        $copy .= "\n".join("\n",@{$rla1})."\n";
        $line .= ' ' if (length($line));
        $line .= $key1;
        if (length($line) > $max_line) {
            $msg .= "$line\n";
            $line = '';
        }
    }
    $msg .= $line if (length($line));
    prt("$msg\n");
    if (length($copy)) {
        write2file($copy,$tmp_copy);
        prt("Written these 'missing' functions to [$tmp_copy].\n");
    }

    prt("\nMissed $cntm2 in [$in_file2], but NOT in [$in_file]...\n");
    $msg = '';
    $line = '';
    foreach $key1 (sort keys %missed2) {
        $line .= ' ' if (length($line));
        $line .= $key1;
        if (length($line) > $max_line) {
            $msg .= "$line\n";
            $line = '';
        }
    }
    $msg .= $line if (length($line));
    prt("$msg\n");
    prt("\n");

}

#########################################
### MAIN ###
parse_args(@ARGV);
$hash_ref1 = process_in_file($in_file);
if (length($in_file2)) {
    $hash_ref2 = process_in_file($in_file2);
    compare_lists($hash_ref1,$hash_ref2);
}
pgm_exit(0,"");
########################################
sub give_help {
    prt("$pgmname: version $vers\n");
    prt("Usage: $pgmname [options] in-file\n");
    prt("Options:\n");
    prt(" --help (-h or -?) = This help, and exit 0.\n");
    prt(" --load_log   (-l) = Load log file at end.\n");
    prt("Purpose:\n");
    prt(" Read the input file as a perl script, and show what appear to be\n");
    prt("  functions (subs), and its line number.\n");
    prt("Notes:\n");
    prt(" Load log is automatically set if more than $max_lines lines shown.\n");
}
sub need_arg {
    my ($arg,@av) = @_;
    pgm_exit(1,"ERROR: [$arg] must have following argument!\n") if (!@av);
}
sub parse_args {
    my (@av) = @_;
    my $cnt = 0;
    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;
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            if ($cnt == 0) {
                $in_file = $arg;
                if (-f $in_file) {
                    prt("Set input to [$in_file]\n");
                } else {
                    pgm_exit(1,"ERROR: Unable to locate [$in_file]!\n");
                }
            } elsif ($cnt == 1) {
                $in_file2 = $arg;
                if (-f $in_file2) {
                    prt("Set input 2 to [$in_file2]\n");
                } else {
                    pgm_exit(1,"ERROR: Unable to locate [$in_file2]!\n");
                }
            } else {
                pgm_exit(1,"ERROR: Only maximum of 2 bares files allowed!\n");
            }
            $cnt++;
        }
        shift @av;
    }
    if ($debug_on) {
        if ((length($in_file) ==  0)&&( -f $def_file1 )&&( -f $def_file2 )) {
            $in_file = $def_file1;
            $in_file2 = $def_file2;
        }
    }

    if (length($in_file) ==  0) {
        pgm_exit(1,"ERROR: No input files found in command!\n");
    }
}

# eof - getfunclist.pl

index -|- top