#!/usr/bin/perl -w
# NAME: perl-list.pl
# AIM: SPECIALISED - Just to make a perl-list.txt and perl-list.htm file
# 23/12/2011 geoff mclane http://geoffair.net/mperl
use strict;
use warnings;
use File::Basename;  # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[^.]*/] )
use File::stat;
use Cwd;
my $perl_dir = 'C:\GTools\perl';
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 = $perl_dir."\\temp.$pgmname.txt";
open_log($outfile);

# user variables
my $VERS = "0.0.1 2011-12-22";
my $load_log = 1;
my $in_file = '';
my $verbosity = 0;
my $debug_on = 0;
my $def_file = 'def_file';
my $out_file = 'perl-list.txt';
my $show_type_text = 0;
my $show_path = 0;
my $out_html = 'perl-list.htm';
my $tab_space = '   '; # note tabs to 3 spaces - change if desired
my $add_top_jump = 1;
my $add_alpha_list = 1;

### program variables
my @g_file_list = ();
my @warnings = ();
my $cwd = cwd();
my $os = $^O;
my $out_text = '';
my $html_text = '';
my %name_dupes = ();

my $date_key = '0001_date';
my $size_key = '0002_size';
my $aim_key  = '0003_AIM';
my $use_key  = '0004_use';
my $sub_key  = '0005_sub';

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

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

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


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

my %g_hash = ();

my $TYP_HASH = 1;
my $TYP_ARRAY = 2;
my $TYP_CODE = 3;
my $TYP_GLOB = 4;
my $TYP_OTHER = 5;
my $TYP_UNDEF = 6;

my %type_text = (
    $TYP_HASH => 'HASH',
    $TYP_ARRAY => 'ARRAY',
    $TYP_CODE => 'CODE',
    $TYP_GLOB => 'GLOB',
    $TYP_OTHER => 'OTHER',
    $TYP_UNDEF => 'TEXT'
    );

sub get_type_number($) {
	my ($k) = shift;
	my $type = ref($k);
	if ($type) {
		if ($type eq 'HASH' ) {
            return $TYP_HASH;
		} elsif ($type eq 'ARRAY') {
            return $TYP_ARRAY;
		} elsif ($type eq 'CODE') {
			return $TYP_CODE;
		} elsif ($type eq 'GLOB') {
            return $TYP_GLOB;
		} else {
            return $TYP_OTHER;
		}
	}
    return $TYP_UNDEF;
}
sub get_type_text($) {
    my $num = shift;
    if (defined $type_text{$num}) {
        return $type_text{$num};
    }
    return 'Undefined $num';
}

sub is_text_type($) {
    my ($k) = shift;
    my $n = get_type_number($k);
    return 1 if ($n == $TYP_UNDEF);
    return 0;
}

######################################################
# Converting SPACES to '&nbsp;'
# Of course this could be done just using perl's
# powerful search and replace, but this handles
# any number of spaces, only converting the number
# minus 1 to &nbsp; ... not sure how to have
# this level of control with regex replacement
######################################################
sub conv_spaces {
   my $t = shift;
   my ($c, $i, $nt, $ln, $sc, $sp);
   $nt = ''; # accumulate new line here
   $ln = length($t);
   for ($i = 0; $i < $ln; $i++) {
      $c = substr($t,$i,1);
      if ($c eq ' ') {
         $i++; # bump to next 
         $sc = 0;
         $sp = '';
         for ( ; $i < $ln; $i++) {
            $c = substr($t,$i,1);
            if ($c ne ' ') {
               last; # exit
            }
            $sc++;
            $sp .= $c;
         }
         if ($sc) {
            $sp =~ s/ /&nbsp;/g;
            $nt .= $sp;
         }
         $i--; # back up one
         $c = ' '; # add back the 1 space
      }
      $nt .= $c;
   }
   prt( "conv_space: from [$t] to [$nt] ...\n" ) if $debug_on;
   return $nt;
}

###########################################################################
# VERY IMPORTANT SERVICE
# This converts the 'text' into HTML text, but only does a partial job!
# 1. Convert '&' to '&amp;' to avoid interpreting as replacement
# 2. Convert '<' to '&lt;' to avoid interpreting as HTML
# 3. Convert '>' to '&gt;' to avoid interpreting as HTML
# 4. Convert '"' to '&quot;'
# 5. Convert '\t' to SPACES
# 6. Finally, if there are double or more SPACES, convert to '&nbsp;'
###########################################################################
sub html_line {
   my $t = shift;
   my $ot = $t;
   $t =~ s/&/&amp;/g; # all '&' become '&amp;'
   $t =~ s/</&lt;/g; # make sure all '<' is/are swapped out
   $t =~ s/>/&gt;/g; # make sure all '>' is/are swapped out
   $t =~ s/\"/&quot;/g; # and all quotes become &quot;
   $t =~ s/\t/$tab_space/g; # tabs to spaces
   if ($t =~ /\s\s/) { # if any two consecutive white space
      return conv_spaces($t);
   }
   prt( "html_line: from [$ot] to [$t] ...\n" ) if $debug_on;
   return $t;
}

sub show_hash_type($$$$);
sub show_array_type($$$$);

sub show_hash_type($$$$) {
    my ($data,$dep,$path,$inkey) = @_;
    my $cnt = 0;
    my $indent = '  ' x $dep;
    my ($key,$val,$num,$text,$icnt,$npath,$ccnt,$hcnt);
    $num = get_type_number($data);
    $text = ($show_type_text ? get_type_text($num) : "");
    $hcnt = scalar keys %{$data};
    $npath = $show_path ? $path : "";
    prt($indent."Count $hcnt $text $npath\n" ) if (VERB1());
    foreach $key (sort keys %{$data}) {
        $val = ${$data}{$key};
        $num = get_type_number($val);
        $text = ($show_type_text ? get_type_text($num) : "");
        $cnt++;
        $ccnt = sprintf("%2d",$cnt);
        ###$npath = $path.'->'.'{"'.$key.'"}';
        $npath = $show_path ? $path.'{"'.$key.'"}' : "";
        $key =~ s/^\d+_//;
        if ($num == $TYP_UNDEF) {
            prt( $indent."$ccnt: $key = ".$val." $text $npath\n" );
            if ($key eq 'date') {
                $out_text .= " $val";
                $html_text .= " ".html_line(trim_all($val));
            } elsif ($key eq 'size') {
                $out_text .= " $val\n";
                $html_text .= " ".html_line(trim_all($val))."</td></tr>\n";
            }
        } elsif ($num == $TYP_HASH) {
            $icnt = scalar keys(%{$val});
            prt($indent."$ccnt: $key $text $icnt $npath\n"); # if (VERB2());
            show_hash_type($val,($dep+1),$npath,$key);
        } elsif ($num == $TYP_ARRAY) {
            $icnt = scalar @{$val};
            prt($indent."$ccnt: $key $text $icnt $npath\n"); # if (VERB2());
            if ($key eq 'use') {
                $out_text .= "use ";
                $html_text .= "\n<tr><td><b>use</b> ";
            } elsif ($key eq 'sub') {
                $out_text .= "sub ";
                $html_text .= "\n<tr><td><b>sub</b> ";
            }
            show_array_type($val,($dep+1),$npath,$key);
            if (($key eq 'use')||($key eq 'sub')) {
                $out_text .= "\n";
                $html_text .= "</td></tr>\n";
            }
        } else {
            prtw("WARNING:$ccnt: $key $text MISSED - CHECK ME!\n" );
        }
    }
}

sub show_array_type($$$$) {
    my ($data,$dep,$path,$inkey) = @_;
    my $cnt = 0;
    my $indent = '  ' x $dep;
    my ($key,$num,$text,$icnt,$npath,$ccnt,$acnt);
    $num = get_type_number($data);
    $text = ($show_type_text ? get_type_text($num) : "");
    $acnt = scalar @{$data};
    $npath = $show_path ? $path : "";
    prt($indent."Count $acnt $text $npath\n" ) if (VERB1());
    foreach $key (@{$data}) {
        $num = get_type_number($key);
        $text = ($show_type_text ? get_type_text($num) : "");
        $npath = $show_path ? $path.'['.$cnt.']' : "";
        $cnt++;
        $ccnt = sprintf("%2d",$cnt);
        if ($num == $TYP_UNDEF) {
            prt( $indent."$ccnt: $key $text $npath\n" );
            if (($inkey eq 'use')||($inkey eq 'sub')) {
                $out_text .= "$key ";
                $html_text .= html_line(trim_all($key))." ";
            } elsif ($inkey eq 'AIM') {
                $out_text .= "$key\n";
                if ($cnt == 1) {
                    $html_text .= "\n<tr><td>";
                }
                $html_text .= html_line(trim_all($key));
                if ($cnt == $acnt) {
                    $html_text .= "</td></tr>";
                } else {
                    $html_text .= "<br>";
                }
                $html_text .= "\n";
            }
        } elsif ($num == $TYP_HASH) {
            $icnt = scalar keys(%{$key});
            prt($indent."$ccnt: HASH, with $icnt keys $npath\n" ) if (VERB2());
            show_hash_type($key,($dep+1),$npath,$inkey);
        } elsif ($num == $TYP_ARRAY) {
            $icnt = scalar @{$key};
            prt($indent."$ccnt: ARRAY, with $icnt items $npath\n" ) if (VERB2());
            show_array_type($key,($dep+1),$npath,$inkey);
        } else {
            prtw("WARNING:$ccnt: $text MISSED - CHECK ME!\n" );
        }
    }
}

sub cmpNoCase {
    my $lc1 = lc($a);
    my $lc2 = lc($b);
    return -1 if ($lc1 lt $lc2);
    return  1 if ($lc1 gt $lc2);
    return 0;
}

sub get_meta_style() {
    my $txt = <<EOF;
  <meta http-equiv="Content-Type"
       content="text/html; charset=ISO-8859-1">
  <meta name="Author"
       content="Geoff Mclane">
  <link href="perl.css"
        rel="stylesheet"
        rev="stylesheet"
        type="text/css"
        media="screen">
  <base target="_self">
EOF
    return $txt;
}

sub get_doctype() {
    my $txt = <<EOF;
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" 
 "http://www.w3.org/TR/html4/loose.dtd">
EOF
    return $txt;
}

sub get_unique_link($) {
    my $fkey = shift;
    my $key = lc($fkey);
    $key =~ s/\./_/g;
    $key =~ s/-/_/g;
    $key =~ s/\@/_/g;
    if ( !($key =~ /^\w+$/) ) {
        prtw("WARNING: Note key [$key] contains NOT-alpha-numeric chars!\n");
    }
    my $ch = substr($key,0,1);
    if (($ch eq '_')||($ch =~ /\W/)) {
        $key = 'a'.$key; # ensure alpha start
    }
    my $cnt = 0;
    my $tkey = $key;
    while (defined $name_dupes{$tkey}) {
        $cnt++;
        $tkey = "$key$cnt";
    }
    $name_dupes{$tkey} = $fkey; # set jump key for this file
    return $tkey;
}

sub gen_alpha_list($) {
    my ($rh) = @_;
    my @list = sort cmpNoCase keys %{$rh};
    my $txt = "\n<a name=\"alpha_jump_list\"></a>\n<p>Alpha-List: ";
    my ($file,$jump,$key,$val,$fnd);
    foreach $file (@list) {
        foreach $key (keys %name_dupes) {
            $val = $name_dupes{$key};
            if ($val eq $file) {
                $jump = $key;
                $fnd = 1;
                last;
            }
        }
        if ($fnd) {
            $txt .= "\n<a href=\"#$jump\">$file</a>";
        } else {
            prtw("WARNING: Failed to find file [$file] in name_dupes hash!\n");
        }
    }
    $txt .= "</p>\n";
    return $txt;
}

sub process_rh($) {
    my ($rh) = @_;
    my ($key,$val,$num,$txt,$cnt,$npath,$icnt,$ccnt,$htm_key);
    $cnt = 0;
    my $path = '${$rh}';
    $num = get_type_number($rh);
    $txt = get_type_text($num);
    $icnt = scalar keys(%{$rh});
    prt("Count $icnt keys in $txt $path\n" ); # if (VERB1());
    foreach $key (sort cmpNoCase keys %{$rh}) {
        $val = ${$rh}{$key};
        $cnt++;
        $ccnt = sprintf("%3d",$cnt);
        $num = get_type_number($val);
        $txt = get_type_text($num);
        $npath = $show_path ? $path.'{"'.$key.'"}' : "";
        $txt = $show_type_text ? $txt : '';
        $out_text .= $key;
        if ($cnt > 1) {
            if ($add_top_jump) {
                $html_text .= "\n  <tr><td align=\"center\"><a target=\"_self\" href=\"#top\">top</a>\n";
                if ($add_alpha_list) {
                    $html_text .= "\n<a href=\"#alpha_jump_list\">Alphabetic List</a> ";
                }
                $html_text .= "</td></tr>\n";
            } else {
                $html_text .= "\n  <tr><td>&nbsp;</td></tr>\n";
            }
        }
        $html_text .= "\n  <tr><td>";
        $htm_key = get_unique_link($key);
        $html_text .= "<a name=\"$htm_key\"></a>\n";
        $html_text .= "<b>";
        $html_text .= html_line(trim_all($key));
        $html_text .= "</b> ";
        if ($num == $TYP_UNDEF) {
            $icnt = '';
            prt("$ccnt: $key $val $txt $icnt $npath\n" );
        } elsif ($num == $TYP_HASH) {
            $icnt = scalar keys(%{$val});
            prt("$ccnt: $key $txt $icnt $npath\n"); # if (VERB1());
            show_hash_type($val,1,$npath,$key);
        } elsif ($num == $TYP_ARRAY) {
            $icnt = scalar @{$val};
            prt("$ccnt: $key $txt $icnt $npath\n"); # if (VERB1());
            show_array_type($val,1,$npath,$key);
        } else {
            prtw("WARNING:$ccnt: $key CHECK ME!\n");
        }
        $out_text .= "\n";
    }
    $icnt = scalar keys(%{$rh});
    if (length($out_file)) {
        $key = "List of $icnt perl files as at ";
        $key .= get_YYYYMMDD(time());
        $key .= ", generated by $pgmname";
        $key .= "\n";
        $txt = $key;
        $key .= "\n";
        write2file($key.$out_text.$txt,$out_file);
        prt("Summary written to $out_file\n");
    }
    if (length($out_html)) {
        $key = get_doctype();
        $key .= "\n<html>\n <head>\n <title>\n  Perl List\n </title>\n";
        $key .= get_meta_style();
        $key .= " </head>\n <body>\n";
        $key .= "\n  <a name=\"top\"></a>";
        $key .= "\n  <h1 align=\"center\">Perl List</h1>\n";
        $key .= "\n  <p class=\"ctr\"><a href=\"index.htm\">index</a>";
        if ($add_alpha_list) {
            $key .= "\n<a href=\"#alpha_jump_list\">Alphabetic List</a> ";
        }
        $key .= "\n<a href=\"#end\">end</a>";
        $key .= "</p>\n";
        $key .= "\n  <p>List of $icnt perl files as at ";
        $key .= get_YYYYMMDD(time());
        $key .= ", generated by $pgmname";
        $key .= "</p>\n";
        $key .= "\n  <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" summary=\"Perl List\">\n";
        # ================================
        # $htm_text will be inserted here
        # ================================
        $txt = "\n  <tr><td align=\"center\"><a target=\"_self\" href=\"#top\">top</a>\n";
        if ($add_alpha_list) {
            $txt .= "\n<a href=\"#alpha_jump_list\">Alphabetic List</a> ";
        }
        $txt .= "   </td></tr>\n";
        $txt .= "  </table>\n";
        if ($add_alpha_list) {
            $txt .= gen_alpha_list($rh);
            $txt .= "\n  <p align=\"center\"><a target=\"_self\" href=\"#top\">top</a>\n";
            if ($add_alpha_list) {
                $txt .= "\n<a href=\"#alpha_jump_list\">Alphabetic List</a> ";
            }
            $txt .= "</p>\n";
        }
        $txt .= "\n  <p>List of $icnt perl files as at ";
        $txt .= get_YYYYMMDD(time());
        $txt .= ", generated by $pgmname";
        $txt .= "  </p>\n";
        $txt .= "  <a name=\"end\"></a>\n";
        $txt .= " </body>\n";
        $txt .= "</html>\n";
        write2file($key.$html_text.$txt,$out_html);
        prt("Summary written to $out_html\n");
    }
}

sub process_file($$$) {
    my ($inf,$tm,$sz) = @_;
    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]...\n") if (VERB9());
    my ($line,$inc,$lnn,$use,$ra,$sub,$ctm,$csz,$i);
    $lnn = 0;
    #my @farr = ();
    my %hfile = ();
    my %use_dupes = ();
    my %sub_dupes = ();
    my %line_dupes = ();
    $ctm = lu_get_YYYYMMDD_hhmmss($tm);
    $csz = get_nn($sz);
    $hfile{$date_key} = $ctm;
    $hfile{$size_key} = $csz;
    #push(@farr,[$ctm,$csz]);
    for ($i = 0; $i < $lncnt; $i++) {
        $line = $lines[$i];
        chomp $line;
        $line = trim_all($line);
        $lnn++;
        if ($line =~ /^\s*\#\s*AIM/) {
            $hfile{$aim_key} = [ ] if (!defined $hfile{$aim_key});
            $ra = $hfile{$aim_key};
            push(@{$ra},$line);
            $line_dupes{$line} = 1;
            $i++;
            for (; $i < $lncnt; $i++) {
                $line = $lines[$i];
                chomp $line;
                $line = trim_all($line);
                $lnn++;
                if ($line =~ /^\s*\#/) {
                    if ($line =~ /^\s*\#(\#|\s|\.|\*|=)*$/) {
                        # do not add this type of line
                    } elsif (!defined $line_dupes{$line}) {
                        $line_dupes{$line} = 1;
                        push(@{$ra},$line);
                    }
                } else {
                    $i--;
                    last;
                }
            }
        } elsif ($line =~ /^\s*use\s+(.+)$/) {
            $use = $1;
            $use =~ s/\#.*$//;
            $use = trim_tailing($use);
            if (!defined $use_dupes{$use}) {
                $use_dupes{$use} = 1;
                prt("$lnn: use $use\n") if (VERB5());
                $hfile{$use_key} = [ ] if (!defined $hfile{$use_key});
                $ra = $hfile{$use_key};
                push(@{$ra},$use);
            }
        } elsif ($line =~ /^\s*sub\s+(\w+)\s*(\s|\()/) {
            $sub = $1;
            if (!defined $sub_dupes{$sub}) {
                $sub_dupes{$sub} = 1;
                prt("$lnn: sub $sub\n") if (VERB5());
                $hfile{$sub_key} = [ ] if (!defined $hfile{$sub_key});
                $ra = $hfile{$sub_key};
                push(@{$ra},$sub);
            }
        }
    }
    #$g_hash{$inf} = [];
    #$ra = $g_hash{$inf};
    #push(@farr,\%hfile);
    #push(@{$ra},\@farr);
    #push(@{$ra},\%hfile);
    $g_hash{$inf} = \%hfile;    # just store a ref to the file hash
}

sub process_files() {
    my ($file,$tm,$sz,$max,$i);
    my $ra = \@g_file_list;
    $max = scalar @{$ra};
    prt("Processing $max perl files...\n");
    for ($i = 0; $i < $max; $i++) {
        $file = ${$ra}[$i][0];
        $tm   = ${$ra}[$i][1];
        $sz   = ${$ra}[$i][2];
        process_file($file,$tm,$sz);
    }
}

sub process_directory() {
    my $dir = '.';
    my (@files,$file,$sb);
    if (opendir(DIR, $dir)) {
        @files = readdir(DIR);
        closedir(DIR);
    } else {
        pgm_exit(1,"ERROR: Open of directory $dir FAILED!\n");
    }
    foreach $file (@files) {
        if ($file =~ /\.pl$/) {
            if ($sb = stat($file)) {
                push(@g_file_list,[$file,$sb->mtime,$sb->size]);
            } else {
                prtw("WARNING: FAILED to stat file $file!\n");
            }
        }
    }
}

#########################################
### MAIN ###
parse_args(@ARGV);
process_directory();
process_files();
process_rh(\%g_hash);
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(" --verb[n]     (-v) = Bump [or set] verbosity. def=$verbosity\n");
    prt(" --load        (-l) = Load LOG at end. ($outfile)\n");
    prt(" --out <file>  (-o) = Write output to this file.\n");
    prt(" --path        (-p) = Show 'path' into hash.\n");
}

sub need_arg {
    my ($arg,@av) = @_;
    pgm_exit(1,"ERROR: [$arg] must have a following argument!\n") if (!@av);
}

sub parse_args {
    my (@av) = @_;
    my ($arg,$sarg);
    while (@av) {
        $arg = $av[0];
        if ($arg =~ /^-/) {
            $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 =~ /^v/) {
                if ($sarg =~ /^v.*(\d+)$/) {
                    $verbosity = $1;
                } else {
                    while ($sarg =~ /^v/) {
                        $verbosity++;
                        $sarg = substr($sarg,1);
                    }
                }
                prt("Verbosity = $verbosity\n") if (VERB1());
            } elsif ($sarg =~ /^l/) {
                $load_log = 1;
                prt("Set to load log at end.\n") if (VERB1());
            } 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 =~ /^p/) {
                $show_path = 1;
                prt("Set to show hash path.\n") if (VERB1());
            } elsif ($sarg =~ /^t/) {
                $show_type_text = 1;
                prt("Set to show type text.\n") if (VERB1());
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            $in_file = $arg;
            pgm_exit(1,"ERROR: Unknown option [$arg]! Try -? for help\n");
        }
        shift @av;
    }
}

# eof - perl-list.pl
