test2.pl to HTML.

index -|- end

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

index -|- top

checked by tidy  Valid HTML 4.01 Transitional