Generated: Sun Aug 21 11:11:31 2011 from test2.pl 2010/09/20 10 KB.
#!/usr/bin/perl -w # NAME: test2.pl # AIM: Just a test scripts 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 'fgutils02.pl' or die "Unable to load 'fgutils02.pl'\n"; require 'lib_acscan.pl' or die "Unable to load 'lib_acscan.pl'!\n"; #require 'lib_acscan-ok.pl' or die "Unable to load 'lib_acscan.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 $load_log = 0; my $in_file = 'C:\FG\19\FlightGear\configure.ac'; #my $in_file = 'C:\Projects\boost\tools\jam\src\boehm_gc\configure.ac'; ### program variables my @warnings = (); my $cwd = cwd(); my $os = $^O; # debug ############################################################### our $dbg_lac01 = 0; # prt( "[01] scan_one_configure_file: Reading $filename\n" ) if $dbg_lac01; and more our $dbg_lac02 = 0; # show EACH line prt( "[02] $lnn: $cline... for each read line. our $dbg_lac03 = 0; # prt( "[03] Variable [$key] = [$nval]\n" ) our $dbg_lac04 = 0; # prt( "[04] Split to $vlen components ...\n" ) our $dbg_lac05 = 0; # prt( "[05] Substitute [$key] = [$nval]\n" ) if ((($orgkey ne $key)||($orgnval ne $nval)) our $dbg_lac06 = 0; # prt( "[06] $.: Should JOIN lines? - [$cline]\n" ) and more... our $dbg_lac07 = 0; # prt( "[07] $.: Got AC_INIT = [$1]\n" ) and AC_DEFIN... etc our $dbg_lac08 = 0; # prt( "[08] Got ac_output_line = $. [$rawline]\n" ) plus accumulation our $dbg_lac09 = 0; # prt( "[01|09] Adding $input [$ff] to mk_inp_list ...\n" ) our $dbg_lac10 = 0; # prt( "[01|10] Adding $input [$ff] to other_input_files ...\n" ) our $dbg_lac11 = 0; # prt( "[11] Storing configure_cond key $1 ... value=2\n" ) our $dbg_lac12 = 0; # prt( "[12] $.: 1=[$1] = 2=[$2] NOT USED [$cline]\n" ) our $dbg_lac13 = 0; # prt("[13] $lnn: Failed on MACRO [$blk], in file [$file]\n") our $dbg_lac14 = 0; # show each MACRO split in FULL our $dbg_lac15 = 0; # Show each AC MACRO accumulation... our $dbg_lac16 = 0; # Show back slash accumulation... our $dbg_lac17 = 0; # show all substitutions our $dbg_lac18 = 0; # show setting or replacing each macro with value our $dbg_lac19 = 0; # unused at present our $dbg_last = 0; sub pgm_exit($$) { my ($val,$msg) = @_; my $stg = ac_get_dbg_stg(); prt("Debug ON: $stg\n") if (length($stg)); 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" ); } } sub dispSymbols { my ($hashRef) = shift; my (%symbols); my (@symbols); %symbols = %{$hashRef}; @symbols = sort(keys(%symbols)); my $msg = ''; my $cnt = 0; foreach (@symbols) { $msg .= sprintf("%-10.10s| %s\n", $_, $symbols{$_}); $cnt++; } prt($msg); return $cnt; } sub displaylibSymbols() { my $pack = __PACKAGE__; prt("Show defined symbols in package [$pack]\n"); my $sym = '\%'.$pack.'::'; my $cnt = dispSymbols(eval $sym); prt("Done show of $cnt symbols in package [$pack]\n"); } sub show_ac_hash($) { my ($rparams) = @_; my ($key,$val,$cnt,$ky2,$val2,$len,$min,$ff,$ok); my $inf = ${$rparams}{'CURR_FILE'}; my $rh = ${$rparams}{'CURR_HASH'}; my ($in_name, $in_dir) = fileparse($inf); prt("\nGot keys: "); foreach $key (keys %{$rh}) { prt("$key "); } prt("\n"); foreach $key (keys %{$rh}) { $val = ${$rh}{$key}; if ($key eq '-NEW_PROJECT_NAME-') { prt("\nKEY: $key = [$val]\n"); } elsif ($key eq 'H_CONF_AC_MACS') { $cnt = scalar keys(%{$val}); prt("\nKEY: $key with $cnt macros in hash...\n"); $min = 0; foreach $ky2 (keys %{$val}) { $val2 = ${$val}{$ky2}; $len = length($ky2); $min = $len if ($len > $min); } $min = 40 if ($min > 40); foreach $ky2 (keys %{$val}) { $val2 = ${$val}{$ky2}; $ky2 .= ' ' while (length($ky2) < $min); prt(" $ky2 = [$val2]\n"); } } elsif ($key eq 'R_SUBS_NOT_FOUND') { $cnt = scalar keys(%{$val}); prt("\nKEY: $key with $cnt macros in hash...\n"); $min = 0; foreach $ky2 (keys %{$val}) { $val2 = ${$val}{$ky2}; $len = length($ky2); $min = $len if ($len > $min); } $min = 40 if ($min > 40); foreach $ky2 (keys %{$val}) { $val2 = ${$val}{$ky2}; $ky2 .= ' ' while (length($ky2) < $min); prt(" $ky2 = [$val2]\n"); } } elsif ($key eq 'A_MAKE_INPUT_LIST') { $cnt = scalar @{$val}; prt("\nKEY: $key with $cnt in array...\n"); foreach $ky2 (@{$val}) { $ff = $in_dir.$ky2.".am"; $ok = (-f $ff) ? ".am ok" : "NOT FOUND [$ff]"; prt( " $ky2 $ok\n"); } } elsif ($key =~ /^CURR_/) { # ignore current items } else { prtw("WARNING: Unhandled key [$key]!\n"); } } prt("\n"); } my $dbg_base = 'dbg_lac'; sub get_dbg_var($) { my $val = shift; my $var = $dbg_base; my $res = -1; if ($val < 10) { $var .= "0$val"; } else { $var .= "$val"; } # from : http://perldoc.perl.org/functions/eval.html if (eval "defined \$$var") { $res = eval "\$$var"; } return $res; } sub set_dbg_var($) { my $val = shift; my $var = $dbg_base; if ($val < 10) { $var .= "0$val"; } else { $var .= "$val"; } # from : http://perldoc.perl.org/functions/eval.html # NOT $$var++; # does not work! if (eval "defined \$$var") { eval "\$$var++"; } else { #print "ERROR: \$$var does NOT exist\n"; return 0; } return 1; } sub get_dbg_range() { my ($i,$res); for ($i = 1; ;$i++) { $res = get_dbg_var($i); last if ($res == -1); } return $i - 1; } sub test1() { displaylibSymbols(); $load_log = 1; my $rng = get_dbg_range(); my $rng2 = ac_get_dbg_range(); prt("Debug range 1 to $rng ($rng2)\n"); pgm_exit(1,"TEMP"); } sub process_ac_file($) { my ($inf) = @_; my %common_subs = (); my $rcs = \%common_subs; return if (! -f $inf); my ($in_name, $in_dir) = fileparse($inf); prt("Scanning [$inf] file...\n"); #set_all_lib_debug(); #set_dbg_lib_13(); #my $rh = scan_one_configure_file($inf,$rcs); my $debug_flag = -1; # this will set them _ALL_ on #my $debug_flag = 1 << (13 - 1); # this will set #13 ON my $rng2 = ac_get_dbg_range(); pgm_exit(1,"ERROR: Problem with ac_get_dbg_range()! is ZERO!\n") if ($rng2 == 0); # ====================================================== # SETUP for a call using a 'paramaters' HASH my %params = (); my $rparams = \%params; my %hash = (); my $rh = \%hash; my %conf_ac_mac = (); my $racmacs = \%conf_ac_mac; my %subs_not_found = (); my $rsnf = \%subs_not_found; my @mk_inp_list = (); my $ramil = \@mk_inp_list; ${$rparams}{'CURR_FILE'} = $inf; ${$rparams}{'CURR_COMMON_SUBS'} = $rcs; ${$rparams}{'CURR_HASH'} = $rh; ${$rparams}{'CURR_AC_MAC'} = $racmacs; ${$rparams}{'CURR_SUBS_NOT_FOUND'} = $rsnf; ${$rparams}{'CURR_MAKE_INP_LIST'} = $ramil; # array reference ${$rparams}{'CURR_DEBUG_FLAG'} = $debug_flag; # ====================================================== scan_configure_ac_file($rparams); # ====================================================== show_ac_hash($rparams); } sub test2() { my $stg = 'abc|def ghi|jkl | pqr stu'; my @arr = split(/[\s\|]+/,$stg); foreach (@arr) { prt("$_\n"); } my $inc = '<file.name>'; prt("1: [$inc] "); $inc =~ s/^<(.+)>$/$1/; $inc =~ s/^"(.+)"$/$1/; prt(" [$inc]\n"); $inc = '"file.name"'; prt("2 [$inc] "); $inc =~ s/^<(.+)>$/$1/; $inc =~ s/^"(.+)"$/$1/; prt(" [$inc]\n"); } ######################################### ### MAIN ### parse_args(@ARGV); ###test1(); test2(); ###process_ac_file($in_file); pgm_exit(0,"Normal exit(0)"); ######################################## sub give_help { prt("$pgmname: version 0.0.1 2010-08-14\n"); prt("Usage: $pgmname [options] in-file\n"); prt("Options:\n"); prt(" --help (-h or -?) = This help, and exit 0.\n"); } sub need_arg { my ($arg,@av) = @_; pgm_exit(1,"ERROR: [$arg] must have following argument!\n") if (!@av); } sub parse_args { my (@av) = @_; 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)"); } else { pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n"); } } else { $in_file = $arg; prt("Set input to [$in_file]\n"); } shift @av; } if (length($in_file) == 0) { pgm_exit(1,"ERROR: No input files found in command!\n"); } } # eof - template.pl