getfunclist.pl to HTML.

index -|- end

Generated: Sat Oct 24 16:35:20 2020 from getfunclist.pl 2019/11/14 40.8 KB. text copy

#!/usr/bin/perl -w
# NAME: getfunclist.pl
# AIM: Given a perl script, scan, and output function list, and line number
# 2019-11-13 - review, and a fix for closing quotes...
# 10/06/2012 - Add -c to scan C/C++ and list prototypes, out to a DEF file
# 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 $os = $^O;
my $perl_dir = '/home/geoff/bin';
my $PATH_SEP = '/';
my $temp_dir = '/tmp';
if ($os =~ /win/i) {
    $perl_dir = 'C:\GTools\perl';
    $temp_dir = $perl_dir;
    $PATH_SEP = "\\";
}
unshift(@INC, $perl_dir);
require 'lib_utils.pl' or die "Unable to load 'lib_utils.pl' Check paths in \@INC...\n";
# log file stuff
our ($LF);
my $pgmname = $0;
if ($pgmname =~ /(\\|\/)/) {
    my @tmpsp = split(/(\\|\/)/,$pgmname);
    $pgmname = $tmpsp[-1];
}
my $outfile = $temp_dir.$PATH_SEP."temp.$pgmname.txt";
open_log($outfile);

# user variables
my $vers = "0.0.4 2019-11-13"; # review only
#my $vers = "0.0.3 2012-06-10"; # add -c to parse as C/C++
#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 $treat_as_c = 0; # default to perl, but -c switch to C/C++ parsing
my $out_file = '';
my $max_lines = 40;
my $max_line = 75;

my @in_files = ();

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

my $verbosity = 0;

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

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

my %export_hash = ();
my %files_done = ();

# DEBUG
my $debug_on = 0;
my $def_file1 = 'C:\FG\16\subversion\subversion\libsvn_diff\diff.h';
##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

my @cpp_res_types = qw(__int64 char bool const double int long short signed unsigned
void wchar_t );

my @cpp_res_words = qw( auto break case catch cerr cin class continue cout default delete
do else enum explicit extern false float for friend goto if inline mutable namespace new
operator private protected public register return sizeof static struct switch template
this throw true try typedef union using virtual volatile while
__asm __fastcall __based __cdecl __pascal __inline __multiple_inheritance __single_inheritance __virtual_inheritance);

#DELIMITER=,(){}[]-+*%/="'~!&|<>?:;.#
my $cpp_delimiters = ",(){}[]-+*%/=\"'~!&|<>?:;.#";

sub is_cpp_delimiter($) {
    my $ch = shift;
    return 1 if (index($cpp_delimiters,$ch) >= 0);
    return 0;
}

sub is_cpp_res_type($) {
    my $wd = shift;
    my ($tst);
    foreach $tst (@cpp_res_types) {
        return 1 if ($tst eq $wd);
    }
    return 0;
}

sub is_cpp_res_word($) {
    my $wd = shift;
    my ($tst);
    foreach $tst (@cpp_res_words) {
        return 1 if ($tst eq $wd);
    }
    return 0;
}

sub cpp_space_split {
   my ($txt) = shift;
   my $len = length($txt);
   my ($k, $ch, $tag, $incomm, $k2, $pc);
   my @arr = ();
   $tag = '';
   $incomm = 0;
    $ch = '';
   for ($k = 0; $k < $len; $k++) {
        $pc = $ch;
      $ch = substr($txt,$k,1);
        $k2 = $k + 1;
      if ($incomm) {
         $incomm = 0 if (($ch eq '"') && ($pc ne '\\'));
         $tag .= $ch;
            if (!$incomm) {
                push(@arr,$tag);
                $tag = '';
            }
      } elsif ($ch =~ /\s/) { # any spacey char
            push(@arr, $tag) if (length($tag));
         $tag = '';
      } elsif (is_cpp_delimiter($ch)) { 
         push(@arr, $tag) if (length($tag));
            push(@arr,$ch);
            $tag = '';
      } else {
         $tag .= $ch;
         $incomm = 1 if ($ch eq '"');
      }
   }
   push(@arr, $tag) if (length($tag));
   return @arr;
}

sub remove_comments($) {
    my $txt = shift;
    my $ntxt = '';
    my $len = length($txt);
    my ($i,$ch,$pc,$incom,$inquot);
    $ch = '';
    $incom = 0;
    $inquot = 0;
    for ($i = 0; $i < $len; $i++) {
        $pc = $ch;      # keep previous
        $ch = substr($txt,$i,1);    # get current char
        if ($inquot) {  # wait for unescaped end quote
            $inquot = 0 if (($ch eq '"') && ($pc ne '\\'));
        } else {
            if ($incom) {
                $incom = 0 if (($ch eq '/')&&($pc eq '*'));
                next if ($incom);
            } elsif ($ch eq '"') {
                $inquot = 1;
            } else {
                if (($ch eq '*') && ($pc eq '/')) {
                    $ntxt =~ s/\/$//;
                    $incom = 1;
                } elsif (($ch eq '/')&&($pc eq '//')) {
                    $ntxt =~ s/\/$//;
                    last;   # enf of line is comment
                }
            }
        }
        $ntxt .= $ch;   # add char to return text
    }
    $ntxt = trim_all($ntxt);
    return $ntxt;
}

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

sub show_warnings() {
    my $cnt = scalar @warnings;
   if ($cnt) {
      prt( "\nGot $cnt WARNINGS...\n" );
      $cnt = 0;
      foreach my $itm (@warnings) {
          $cnt++;
          prt("$cnt: $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;
}


my %rpts_shown = ();

sub add_proto($$$$) {
    my ($rh,$tag,$lnn,$fil) = @_;
    my $ind = index($tag,'(');
    my $nf = 1;
    my ($lead,$tail,@arr,$max,$i,$i2,$head,$func,$itm,$off);
    my ($ra,$head2,$tail2);
    if ($ind > 0) {
        $lead = substr($tag,0,$ind);
        $lead = trim_tailing($lead);
        $tail = substr($tag,$ind);
        $tail = trim_all($tail);
        $tail =~ s/;$//;
        $tail = trim_all($tail);
        ###@arr = split(/\s+/,$lead);
        @arr = cpp_space_split($lead);
        $max = scalar @arr;
        if ($max > 1) {
            $off = $max - 1; # not always best choice
            $func = $arr[-1];
            if ($max > 2) {
                $head = $arr[-2];
                if (($func =~ /^[_A-Z]+$/) && ($tail =~ /^\(\(.+\)\)$/) &&
                    !is_cpp_res_type($head) ) {
                    $off--;
                }
            }

            $head = '';
            for ($i = 0; $i < $max; $i++) {
                $itm = $arr[$i];
                $head .= ' ' if (length($head));
                if ($i == $off) {
                    $func = $itm;
                    $head .= "[$func]";
                } else {
                    $head .= $itm;
                }
            }
            if (defined ${$rh}{$func}) {
                $ra = ${$rh}{$func};    # extract ref arrar
                $tail2 = ${$ra}[0];     # get tail 2
                $head2 = ${$ra}[1];     # get head 2
                if (($tail ne $tail2) || ($head ne $head2)) {
                    if (! defined $rpts_shown{$func}) {
                        $rpts_shown{$func} = 1;
                        prtw("WARNING:$lnn: Function [$func]\n [$head2] [$tail2] over written by\n [$head] [$tail]! [$fil]\n");
                    } else {
                        $rpts_shown{$func}++;
                        my $cnt = $rpts_shown{$func};
                        ###prt("WARNING: Function [$func] over written by [$tail] $cnt times!\n");
                    }
                }
            }
            if (VERB2()) {
                prt("[v2]:$lnn: Function $head [$tail]\n");
            } elsif (VERB1()) {
                prt("[v]:$lnn: Function [$func]\n");
            }

            ${$rh}{$func} = [$tail,$head];
            $nf = 0;
        }
    }
    if ($nf) {
        prtw("WARNING:$lnn: No function found in [$tag]! [$fil]\n");
    }
}

sub add_func($$$$) {
    my ($rh,$tag,$lnn,$fil) = @_;
    my $ind = index($tag,'(');
    my $nf = 1;
    my ($lead,$tail,@arr,$max,$i,$i2,$head,$func,$itm,$off);
    my ($ra,$head2,$tail2);
    if ($ind > 0) {
        $lead = substr($tag,0,$ind);
        $lead = trim_tailing($lead);
        $tail = substr($tag,$ind);
        $tail = trim_all($tail);
        $tail =~ s/;$//;
        $tail = trim_all($tail);
        ###@arr = split(/\s+/,$lead);
        @arr = cpp_space_split($lead);
        $max = scalar @arr;
        if ($max > 1) {
            $off = $max - 1; # not always best choice
            $func = $arr[-1];
            if ($max > 2) {
                $head = $arr[-2];
                if (($func =~ /^[_A-Z]+$/) && ($tail =~ /^\(\(.+\)\)$/) &&
                    !is_cpp_res_type($head) ) {
                    $off--;
                }
            }

            $head = '';
            for ($i = 0; $i < $max; $i++) {
                $itm = $arr[$i];
                $head .= ' ' if (length($head));
                if ($i == $off) {
                    $func = $itm;
                    $head .= "[$func]";
                } else {
                    $head .= $itm;
                }
            }
            if (defined ${$rh}{$func}) {
                $ra = ${$rh}{$func};    # extract ref arrar
                $tail2 = ${$ra}[0];     # get tail 2
                $head2 = ${$ra}[1];     # get head 2
                if (($tail ne $tail2) || ($head ne $head2)) {
                    if (! defined $rpts_shown{$func}) {
                        $rpts_shown{$func} = 1;
                        prtw("WARNING:$lnn: Function [$func]\n [$head2] [$tail2] over written by\n [$head] [$tail]! [$fil]\n");
                    } else {
                        $rpts_shown{$func}++;
                        my $cnt = $rpts_shown{$func};
                        ###prt("WARNING: Function [$func] over written by [$tail] $cnt times!\n");
                    }
                }
            }
            if (VERB2()) {
                prt("[v2]:$lnn: Function $head [$tail]\n");
            } elsif (VERB1()) {
                prt("[v]:$lnn: Function [$func]\n");
            }

            ##${$rh}{$func} = [$tail,$head];
            $nf = 0;
        }
    }
    if ($nf) {
        prtw("WARNING:$lnn: No function found in [$tag]! [$fil]\n");
    }
}


sub add_functions($$$$) {
    my ($rh,$rap,$raf,$fil) = @_;
    my $pcnt = scalar @{$rap};
    my $fcnt = scalar @{$raf};
    prt("Got $pcnt potential prototypes, and $fcnt functions.\n");
    my ($tag,$i,$lnn);
    for ($i = 0; $i < $pcnt; $i++) {
        $lnn = ${$rap}[$i][0];
        $tag = ${$rap}[$i][1];
        add_proto($rh,$tag,$lnn,$fil);
    }
    for ($i = 0; $i < $fcnt; $i++) {
        $lnn = ${$raf}[$i][0];
        $tag = ${$raf}[$i][1];
        add_func($rh,$tag,$lnn,$fil);
    }

}


sub process_as_c($$$) {
    my ($fil,$rla,$rmh) = @_;
    my $max = scalar @{$rla};
    my ($j,$ln,$mx,$pc,$ch,@br,$ii,$cbr,$cbk,$qc,@bk,$lnn,$lbgn,$tmp);
    my $tag = '';
    my ($ms,$incpp,$hadbr,$hadbk,$i2);
    my $incomm = 0;
    my $inquot = 0;
    my $comm = '';
    $ch = '';
    @br = ();
    @bk = ();
    my @funcs = ();
    my @protos = ();
    $cbr = 0;
    $cbk = 0;
    $incpp = 0;
    $hadbr = 0;
    $hadbk = 0;
    my %hash = ();
    for ($j = 0; $j < $max; $j++) {
        $ln = ${$rla}[$j];
        $lnn = $j + 1;
        chomp $ln;
        $ln = trim_all($ln);
        while (($ln =~ /\\$/) && ($lnn < $max)) {
            prt("$lnn: Get NEXT [$ln]\n") if (VERB9());
            $ln =~ s/\\$//; # remove trailing slash
            $ln = trim_all($ln);    # trim the line
            $j++;                   # bump to NEXT line
            $lnn = $j + 1;          # set plus 1
            $tmp = ${$rla}[$j];     # extract NEXT line
            chomp $tmp;
            $tmp = trim_all($tmp);  # trim it
            $ln .= ' ' if ($ln =~ /\S$/);
            $ln .= $tmp;            # add it
        }
        $mx = length($ln);
        $cbr = scalar @br;
        $cbk = scalar @bk;
        prt("[v9] LN:$lnn: $ln\n") if (VERB9());
        $ms = "$lnn:1:$cbr:$cbk:";
        for ($ii = 0; $ii < $mx; $ii++) {
            $pc = $ch;
            $ch = substr($ln,$ii,1);
            $tag .= $ch;
            $i2 = $ii + 1;
            $ms = "$lnn:$i2:$cbr:$cbk:";
            if ($inquot) {
                $inquot = 0 if ($ch eq $qc);
            } else {
                if ($ch eq '"') {
                    $inquot = 1;
                    $qc = $ch;
                    $ms .= " inquot";
                } elsif ($ch eq '(') {
                    $ms .= " Open (";
                    push(@bk, $ms);
                    $cbk = scalar @bk;
                    $hadbk++;
                } elsif ($ch eq ')') {
                    if (@bk) {
                        pop @bk;
                        $ms .= " ) Close";
                    } else {
                        prtw("WARNING:$ms: got Close without open! [$fil]\n");
                    }
                    $cbk = scalar @bk;
                } elsif ($ch eq '{') {
                    $ms .= " open {";
                    push(@br, $ms);
                    $cbr = scalar @br;
                    $hadbr++;
                } elsif ($ch eq '}') {
                    if (@br) {
                        pop @br;
                        $cbr = scalar @br;
                        $ms = "$lnn:$i2:$cbr:$cbk:";
                    } else {
                        if ($incpp) {
                            # ignore this
                        } else {
                            prtw("WARNING:$ms: got close without open! [$fil]\n");
                        }
                    }
                    $ms .= " } close";
                    $cbr = scalar @br;
                } else {
                    if (($ch eq '/') && ($pc eq '/')) {
                        $comm = substr($ln,$ii-1);
                        ###prt("$ms Skipped inline comment\n[$comm]\n") if (VERB9());
                        $ms = "$ms Skipped inline comment\n[$comm]";
                        $tag =~ s/\/\///;
                        $comm = '';
                        last;   # skip rest of line
                    } elsif (($ch eq '*')&&($pc eq '/')) {
                        $tag =~ s/\/\*$//;    # remove trailing '/*' chars
                        # and stay here until comment ENDS
                        $lbgn = $j + 1;
                        $ii++;
                        $incomm = 1;
                        $comm = $pc.$ch;
                        while ($incomm && ($j < $max)) {
                            $lnn = $j + 1;
                            for (; $ii < $mx; $ii++) {
                                $pc = $ch;
                                $ch = substr($ln,$ii,1);
                                $i2 = $ii + 1;
                                $ms = "$lnn:$i2:$cbr:$cbk:";
                                $comm .= $ch;
                                if (($ch eq '/')&&($pc eq '*')) {
                                    $incomm = 0;
                                    ###prt("$lbgn-$ms Skipped comment\n[$comm]\n") if (VERB9());
                                    $ms = "$lbgn-$ms Skipped comment\n[$comm]";
                                    $comm = '';
                                    if ($i2 < $mx) {
                                        $ln = substr($ln,$i2);
                                    } else {
                                        $ln = '';
                                    }
                                    $mx = length($ln);
                                    $ii = 0;
                                    last;
                                }
                            }
                            if ($incomm) {
                                $j++;
                                $comm .= "\n";
                                if ($j < $max) {
                                    $ln = ${$rla}[$j];
                                    chomp $ln;
                                    $mx = length($ln);
                                    $ii = 0;
                                }
                            }
                        }
                    }
                }
            }
        }
        # end of line
        if ($ln =~ /^\s*\#/) {
            $tmp = remove_comments($ln);
            if ($tmp =~ /^\s*\#\s*include\s+(\"|<)(.+)(\"|>)/) {
                $ms .= " include [$1$2$3]";
            } elsif ($tmp =~ /^\s*\#\s*ifdef\s+(\w+)\b/) {
                $ms .= " ifdef [$1]";
            } elsif ($tmp =~ /^\s*\#\s*ifndef\s+(\w+)\b/) {
                $ms .= " ifndef [$1]";
            } elsif ($tmp =~ /^\s*\#\s*else\b/) {
                $ms .= " else";
            } elsif ($tmp =~ /^\s*\#\s*elif\s+(.+)$/) {
                $ms .= " elif [$1]";
            } elsif ($tmp =~ /^\s*\#\s*endif\b/) {
                $ms .= " endif";
            } elsif ($tmp =~ /^\s*\#\s*if\b/) {
                $ms .= " if";
            } elsif ($tmp =~ /^\s*\#\s*define\s+(.*)$/) {
                $ms .= " define $1";
            } elsif ($tmp =~ /^\s*\#\s*undef\s+(.*)$/) {
                $ms .= " undef $1";
            } elsif ($tmp =~ /^\s*\#\s*pragma\s+(.*)$/) {
                $ms .= " pragma $1";
            } elsif ($tmp =~ /^\s*\#\s*error\s+(.*)$/) {
                $ms .= " error $1";
            } else {
                $ms .= " ??? [$ln] CHECK ME";
            }
        }
        prt("$ms\n") if (VERB9());
        $ms = '';
        $ch = '';
        $tag = trim_all($tag);
        if (length($tag)) {
            if ($tag =~ /^\s*\#/) {
                if ($tag =~ /\s*\#\s*ifdef\s+__cplusplus/) {
                    $incpp++;
                    prt("[v5] $lnn:HASH:CPP: $tag\n") if (VERB5());
                } elsif ($tag =~ /\s*\#\s*endif/) {
                    prt("[v5] $lnn:HASH:CPP:$incpp: $tag\n") if (VERB5());
                    $incpp-- if ($incpp);
                } else {
                    prt("[v5] $lnn:HASH: $tag\n") if (VERB5());
                }
                $tag = ''# clear the tag
                $hadbr = 0;
                $hadbk = 0;
            } elsif (($tag =~ /;$/) && ($cbr == 0) && ($cbk == 0)) {
                if ($tag =~ /^typedef\s+/) {
                    prt("[v5] $lnn:TYPEDEF: $tag\n") if (VERB5());
                } elsif ($tag =~ /^struct\s+/ ) {
                    prt("[v5] $lnn:STRUCT: $tag\n") if (VERB5());
                } elsif ($hadbk) {
                    if ($tag =~ /^\s*static\s+/) {
                        prt("[v2] $lnn:PROTO:static: $tag\n") if (VERB2());
                    } else {
                        prt("[v2] $lnn:PROTO: $tag\n") if (VERB2());
                        push(@protos,[$lnn,$tag]); # keep potential function proto
                    }
                } else {
                    prt("[v2] $lnn:NEED CLASS! $tag FIX ME\n") if (VERB2());

                }
                $tag = ''# clear the tag
                $hadbr = 0;
                $hadbk = 0;
            } elsif ($tag =~ /^\s*extern\s+\"{1}C\"{1}\s+{/) {
                if (@br) {
                    pop @br;    # special clear
                }
                $cbr = scalar @br;
                prt("[v5] $lnn:EXTERN:$cbr:$cbk: $tag\n") if (VERB5());
                $tag = '';   # clear the tag
                $hadbr = 0;
                $hadbk = 0;
            } elsif (($cbr == 0) && ($cbk == 0) && $hadbr && $hadbk) {
                 prt("[v5] $lnn:FUNCS: $tag\n") if (VERB5());
                 push(@funcs,[$lnn,$tag]); # keep potential function proto
                $tag = '';   # clear the tag
                $hadbr = 0;
                $hadbk = 0;
            } else {
                $tag .= " ";
                prt("[v9] $lnn:$cbr:$cbk: EOL - accum [$tag]\n") if (VERB9());
            }
        } else {
            prt("[v9] $lnn: EOL - no tag cbr=$cbr cbk=$cbk\n") if (VERB9());
        }
    }

    add_functions(\%hash,\@protos,\@funcs,$fil);

    if ($cbr) {
        prtw("WARNING: File [$fil] ended with $cbr braces on stack!\n");
    }
    if ($cbk) {
        prtw("WARNING: File [$fil] ended with $cbk brackets on stack!\n");
    }
    ${$rmh}{$fil} = \%hash;
}

sub process_as_perl($$$) {
    my ($inf,$rlines,$rh) = @_;
    my ($line,$lnn,$i,$lncnt,$finds,$opt,$proto,$func,$fline);
    my ($len,$j,$ch,$pc,$pc2,$nc,$j2,$inreg,$inquot,$qc,$reg,$quot);
    my ($isfun,$tmp,$brcnt);
    my ($reg1,$regt,$regc,$rbc,$currfun);
    $lnn = 0;
    $lncnt = scalar @{$rlines};
    $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;
    $rbc = 0;
    $pc2 = '';
    for ($i = 0; $i < $lncnt; $i++) {
        $lnn++;
        $fline = ${$rlines}[$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;
            $pc2 = $pc; # keep 2 back chars
            $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 '~')) {
                    prt("$lnn:$j: Possible entering a 'regex' block... $line\n") if ($dbg_02);
                    $inreg = 1;
                    $reg = '';
                    next;
                }
                if ($inquot) {
                    #if (($ch eq $qc)&&($pc ne '\\')&&($pc2 ne '\\')) {
                    if (($ch eq $qc) && (($pc ne '\\')||(($pc eq '\\')&&($pc2 eq '\\') ))) {
                        prt("$lnn:$j: End quote $qc [$quot] - '$pc2$pc$ch'\n") if ($dbg_01);
                        $inquot = 0;
                        next;
                    }
                    $quot .= $ch;
                } else {
                    if (($ch eq '"')||($ch eq "'")) {
                        $qc = $ch;
                        $quot = '';
                        $inquot = 1;
                        prt("$lnn:$j: Begin quote $qc\n") if ($dbg_01);
                        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]! '$pc2$pc$ch'\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");
    }
    my @arr = sort keys(%funcs);
    my $fcnt = scalar @arr;
    prt("Done $lncnt lines, for $finds ($fcnt) functions, $proto prototypes, $opt optional...\n");
    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++;
    }
    if ($fcnt) {
        prt("# List: $fcnt perl functions...\n$msg\n");
    } else {
        prt("# No functions found.\n");
    }
    if ($ln_cnt > $max_lines) {
        $load_log = 1;
    }
    ${$rh}{$inf} = \%hash;
}

sub show_ref_hash($$) {
    my ($fil,$rh) = @_;
    my @arr = sort keys(%{$rh});
    my $cbr = scalar @arr;
    my ($tag);
    if ($cbr) {
        prt("Found $cbr function prototype\n");
        my $msg = '';
        my $head = "VERSION 3.0\n";
        $head .= "EXPORTS\n";
        foreach $tag (@arr) {
            $msg .= "    $tag\n";
        }
        $msg .= "\n";
        my $comm = "; DEF from $fil, generated by $pgmname, on ".lu_get_YYYYMMDD_hhmmss(time())."\n";
        if (length($out_file)) {
            if (-f $out_file) {
                append2file($comm.$msg,$out_file);
                prt("List appended to [$out_file]\n");
            } else {
                write2file($head.$comm.$msg,$out_file);
                prt("List written to [$out_file]\n");
            }
        } else {
            prt("No -o out-file given...\n");
            prt($head.$comm.$msg);
        }
    } else {
        prt("[v9] Found NO function prototypes in scan of $fil\n") if (VERB9());
    }
}

sub process_in_file($$) {
    my ($inf,$rmh) = @_;
    return if (defined $files_done{$inf});
    $files_done{$inf} = 1;
    if (! open INF, "<$inf") {
        pgm_exit(1,"ERROR: Unable to open file [$inf]!\n");
    }
    my @lines = <INF>;
    close INF;
    my $lncnt = scalar @lines;
    prt("Processing $lncnt lines, from $inf, ".($treat_as_c ? "as C/C++" : "as perl")."\n");
    if ($treat_as_c) {
        process_as_c($inf,\@lines,$rmh);
    } else {
        process_as_perl($inf,\@lines,$rmh);
    }
}


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

}

sub show_export_hash($) {
    my $rmh = shift;
    my ($fil,$rh);
    foreach $fil (keys %{$rmh}) {
        $rh = ${$rmh}{$fil};
        show_ref_hash($fil,$rh);
    }
}

sub process_in_files($$) {
    my ($ra,$rmh) = @_;
    my ($fil);
    foreach $fil (@{$ra}) {
        process_in_file($fil,$rmh);
    }
}

#########################################
### MAIN ###
parse_args(@ARGV);
process_in_files(\@in_files,\%export_hash);
if ($treat_as_c) {
    show_export_hash(\%export_hash);
}
#$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 got_wild($) {
    my $fil = shift;
    return 1 if ($fil =~ /\*/);
    return 1 if ($fil =~ /\?/);
    return 0;
}
sub glob_wild($) {
    my $fil = shift;
    my @files = glob($fil);
    my $cnt = scalar @files;
    if ($cnt) {
        prt("Adding $cnt files, from [$fil] input.\n");
        push(@in_files,@files);
        $in_file = $files[0];
    } else {
        pgm_exit(1,"ERROR: Got no files, from [$fil] input.\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 =~ /^c/i) {
                $treat_as_c = 1;
                close_log($outfile,0);
                $outfile = $temp_dir.$PATH_SEP."temp.$pgmname.c";
                open_log($outfile);
            } elsif ($sarg =~ /^l/i) {
                if ($sarg =~ /^ll/i) {
                    $load_log = 2;
                } else {
                    $load_log = 1;
                }
            } elsif ($sarg =~ /^o/) {
                need_arg(@av);
                shift @av;
                $sarg = $av[0];
                $out_file = $sarg;
                prt("Set out file to [$out_file].\n") if (VERB1());
            } elsif ($sarg =~ /^v/) {
                if ($sarg =~ /^v.*(\d+)$/) {
                    $verbosity = $1;
                } else {
                    while ($sarg =~ /^v/) {
                        $verbosity++;
                        $sarg = substr($sarg,1);
                    }
                }
                prt("Verbosity = $verbosity\n") if (VERB1());
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            #if ($cnt == 0) {
            if (got_wild($arg)) {
                glob_wild($arg);
            } else {
                $in_file = $arg;
                if (-f $in_file) {
                    prt("Added input of [$in_file]\n");
                    push(@in_files,$in_file);
                } 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;
            $treat_as_c = 1;
            #$verbosity = 9;
            $load_log = 2;
            #$load_log = 1;
        }
    }

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

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(" --c           (-c) = Treat as C/C++ code. Default is 'perl'\n");
    prt(" --load_log    (-l) = Load log file at end.\n");
    prt(" --out <file>  (-o) = Write output to this file.\n");
    prt(" --verb[N]     (-v) = Bump [or set] verbosity 0-9\n");
    prt("Purpose:\n");
    prt(" Read the input file as a perl script by default, or as C/C++ if -c, 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");
}

# eof - getfunclist.pl

index -|- top

checked by tidy  Valid HTML 4.01 Transitional