Generated: Sun Aug 21 11:11:13 2011 from m4scan.pl 2010/10/08 23.2 KB.
#!/usr/bin/perl -w # NAME: m4scan.pl # AIM: Scan an M4 auto-tools MACRO file # 05/10/2010 geoff mclane http://geoffair.net/mperl use strict; use warnings; use File::Basename; # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[^.]*/] ) use File::Spec; # File::Spec->rel2abs($rel); # we are IN the SLN directory, get ABSOLUTE from RELATIVE 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 location and \@INC content.\n"; #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 $load_log = 0; my $in_file = ''; my $use_trim_all = 0; my $debug_on = 1; my $def_file = 'C:\Projects\Cairo\acinclude.m4'; ### program variables my @warnings = (); my $cwd = cwd(); my $os = $^O; my %ref_params = (); 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" ); } } 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); } # debug my $dbg_m401 = 0; my $dbg_m402 = 0; my $dbg_m403 = 0; my $dbg_m404 = 0; my $dbg_m405 = 0; my $dbg_m406 = 0; my $dbg_m407 = 0; # $cline = accumulate_with_back($cline,$lncnt,\$ln,\@lines); sub m4_accumulate_with_back($$$$) { my ($iline,$lncnt,$rln,$rlines) = @_; my ($nline,$oline); $oline = $iline; $oline =~ s/\\$//; $oline = substr($oline,0,length($oline) - 1) while ($oline =~ /\s$/); # remove all TRAILING space my $ln = ${$rln}; while ($iline =~ /\\$/) { $iline =~ s/\\$//; # remove '\' $iline = substr($iline,0,length($iline) - 1) while ($iline =~ /\s$/); # remove all TRAILING space $ln++; if ($ln < $lncnt) { $nline = trim_all(${$rlines}[$ln]); if (length($nline)) { $iline .= " "; $iline .= $nline; } } else { last; } } ${$rln} = $ln; # pass back potentially new line... if ($dbg_m401 && ($oline ne $iline)) { prt("Accumulated back from\n[$oline] to line $ln\n[$iline]\n"); } return $iline; } # ======================================================================= # based on ALL AC_MACROS are of the form # AC_MACRO([...],....,....), could also check [ ], but that's for later.. # $cline = accumulate_ac_macro($cline,$lncnt,\$ln,\@lines); # ======================================================================= sub m4_accumulate_ac_macro($$$$) { my ($iline,$lncnt,$ri,$rlines) = @_; my ($i,$ch,$brcnt,$k,$k2,$lcnt,$acmac,$oline,$sqcnt,$bgnln); # prt("Accumulate AC MACRO until end...\n"); $k = ${$ri}; # extract current line number, 0 based $bgnln = $k + 1; $oline = $iline; my $len = length($iline); prt("[02] $bgnln:accumulate: Doing line [$iline], len $len\n") if ($dbg_m402); # eat any initial space only for ($i = 0; $i < $len; $i++) { $ch = substr($iline,$i,1); last if ($ch =~ /\S/); # stop on first non-white space } $acmac = ''; # accumulate the name of the MACRO for (; $i < $len; $i++) { $ch = substr($iline,$i,1); last if ($ch =~ /\W/); # stop on non-alpha-numeric - should be '(' $acmac .= $ch; } # could allow 'space' BEFORE '(' # ONE DAY pgm_exit(1,"ERROR: mac=[$acmac] Fix m4_accumulate_ac_macro to accept [$ch] following 'name'!\n") if ($ch ne '('); # essentially get to END of MACRO - may be mutiple lines $i++; # note, BUMP past FIRST '(', and set $brcnt == 0 $brcnt = 0; $sqcnt = 0; $lcnt = 1; for (; $i < $len; $i++) { $ch = substr($iline,$i,1); if ($ch eq '(') { if (!$sqcnt) { $brcnt++; prt("[03]:1:$i:$len: br=$brcnt sq=$sqcnt bumped br count\n") if ($dbg_m403); } else { prt("[03]:1:$i:$len: br=$brcnt sq=$sqcnt skipped br count due sqcnt\n") if ($dbg_m403); } } elsif ($ch eq '[') { $sqcnt++; prt("[02]:1:$i:$len: br=$brcnt sq=$sqcnt bumped sq count\n") if ($dbg_m402); } elsif ($ch eq ']') { prt("[02]:1:$i:$len: br=$brcnt sq=$sqcnt will decrement sq count\n") if ($dbg_m402); $sqcnt-- if ($sqcnt); } elsif ($ch eq ')') { if ($sqcnt) { $ch = ''; prt("[02]:1:$i:$len: br=$brcnt sq=$sqcnt skipped br decement due sq count\n") if ($dbg_m402); } else { if ($brcnt) { $brcnt--; $ch = ''; prt("[02]:1:$i:$len: br=$brcnt sq=$sqcnt decrement br count\n") if ($dbg_m402); } else { prt("[02]:1:$i:$len: br=$brcnt sq=$sqcnt EXIT0\n") if ($dbg_m402); last; } } } } if ($ch ne ')') { # oops, need more lines $k++; $k2 = $k + 1; my $nline = ''; prt( "\n[04] br=$brcnt sq=$sqcnt no closed! Get next line $k, of $lncnt lines\n" ) if ($dbg_m404); while ($k < $lncnt) { #prt( "$k2:$.: need more lines...br=$brcnt, sq=$sqcnt...\n" ); # if ($dbg01); if ($use_trim_all) { $nline = trim_all(${$rlines}[$k]); } else { $nline = ${$rlines}[$k]; chomp $nline; } $lcnt++; $len = length($nline); prt( "[04] br=$brcnt sq=$sqcnt line=$lcnt, len=$len [$nline]\n" ) if ($dbg_m404); for ($i = 0; $i < $len; $i++) { $ch = substr($nline,$i,1); if ($ch eq '(') { if ($sqcnt) { $ch = ''; prt("[04] br=$brcnt sq=$sqcnt skipped br count due sqcnt\n") if ($dbg_m404); } else { $brcnt++; prt("[04] br=$brcnt sq=$sqcnt bumped br count\n") if ($dbg_m404); } } elsif ($ch eq '[') { $sqcnt++; prt("[04] br=$brcnt sq=$sqcnt bumped sq count\n") if ($dbg_m404); } elsif ($ch eq ']') { prt("[04] br=$brcnt sq=$sqcnt will decrement sq count\n") if ($dbg_m404); $sqcnt-- if ($sqcnt); } elsif ($ch eq ')') { if ($sqcnt) { $ch = ''; prt("[04] br=$brcnt sq=$sqcnt skipped br decement due sq count\n") if ($dbg_m404); } else { if ($brcnt) { $brcnt--; $ch = ''; # CLEAR this char - is NOT the end prt("[04] br=$brcnt sq=$sqcnt decrement sq count\n") if ($dbg_m404); } else { prt("[04] br=$brcnt sq=$sqcnt EXIT1\n") if ($dbg_m404); last; } } } } if ($ch eq ')') { prt("[04] br=$brcnt sq=$sqcnt EXIT2\n") if ($dbg_m404); if (length($nline)) { #$iline .= ' ' if ( !( ($iline =~ /\s$/) || ($nline =~ /^\s/) ) ); if ($use_trim_all) { $iline .= " "; # "\n"; } else { $iline .= "\n"; } $iline .= $nline; $nline = ''; } last; } $k++; # need MORE $k2 = $k + 1; if (length($nline)) { #$iline .= ' ' if ( !( ($iline =~ /\s$/) || ($nline =~ /^\s/) ) ); if ($use_trim_all) { $iline .= " "; # "\n"; } else { $iline .= "\n"; } $iline .= $nline; $nline = ''; } } if ($k >= $lncnt) { $ch = ${$ri}; # extract current line number prt("Started at line $ch, and now at line $k, of $lncnt, searching AC MACRO [$acmac] end...\n"); my $tmp = trim_all($iline); if (length($tmp) > 200) { $nline = substr($tmp,0,100)."...\n".substr($tmp,(length($tmp) - 100)); prt("Have accumulated [$nline]!\n"); } else { prt("Have accumulated [$tmp]!\n"); } pgm_exit(1,"ERROR: Ran out of line in an ac macro!\n"); } ${$ri} = $k; # pass back new line number } else { prt( "[04] Closed in current line\n" ) if ($dbg_m404); } if ($dbg_m405) { if ($oline ne $iline) { prt("Done: Accumulated from [$bgnln]\n[$oline] to line $k2\n[$iline]\n"); } else { prt("Done: Accumulated NO CHANGE\n"); } } return $iline; } sub get_ref_params() { my $rh = \%ref_params; return $rh; } sub remove_dnl($) { my ($txt) = shift; return '' if ($txt =~ /^dnl\s*$/); if ($txt =~ /dnl/m) { my $ntxt = ''; my $len = length($txt); my ($i,$ch,$pc,$rem); $ch = ' '; for ($i = 0; $i < $len; $i++) { $pc = $ch; $ch = substr($txt,$i,1); if (($ch eq 'd')&&($pc =~ /\W/)) { $rem = substr($txt,$i); if ($rem =~ /^dnl\W+/) { $i += 3; for (; $i < $len; $i++) { $ch = substr($txt,$i,1); next if ($ch eq "\n"); last if ($ch =~ /\S/); } } } $ntxt .= $ch; } $txt = $ntxt; } return $txt; } sub trim_head_tail($) { my $txt = shift; $txt = trim_ends($txt); return $txt; } sub m4_comma_split($) { my ($line) = @_; my $len = length($line); my ($i,$ch,$insq,$item,$inbr,$hadcom,$nosp,$dline); $insq = 0; $item = ''; $inbr = 0; $nosp = 0; my @arr = (); for ($i = 0; $i < $len; $i++) { $ch = substr($line,$i,1); if ($ch eq ']') { $insq-- if ($insq); $nosp = 1; # no space after this $item .= $ch; next; } elsif ($ch eq '(') { $inbr++; } elsif ($ch eq ')') { if (!$inbr) { push(@arr,$item) if (length($item)); $item = ''; $item = substr($line,($i+1)) if (($i + 1) < $len); $item =~ s/.*\#.*$//; $item = remove_dnl($item); $item = trim_ends($item); prt("[07] $i: Last bracket, rem [$item]\n") if ($dbg_m407); last; } $inbr-- if ($inbr); $nosp = 1; # no space after this $item .= $ch; next; } elsif ($ch eq ',') { $nosp = 1; # no space after this if ( !($inbr || $insq) ) { push(@arr,$item); $item = ''; next; } } elsif ($ch eq '[') { $insq++; } elsif ($ch =~ /\S/) { $nosp = 0; } if ($nosp) { if ($ch =~ /\S/) { $nosp = 0; $item .= $ch; } } else { $item .= $ch; } } push(@arr,$item) if (length($item)); return \@arr; } sub m4_comma_split_OK($) { my ($line) = @_; my $len = length($line); my ($i,$ch,$insq,$item,$inbr,$hadcom,$comcnt,$dline); $insq = 0; $item = ''; $inbr = 0; $comcnt = 0; my @arr = (); if ($dbg_m406) { for ($i = 0; $i < $len; $i++) { $ch = substr($line,$i,1); if ($insq || $inbr) { if ($ch eq '[') { $insq++; } elsif ($ch eq ']') { $insq-- if ($insq); } elsif ($ch eq '(') { $inbr++; } elsif ($ch eq ')') { $inbr-- if ($inbr); } } else { if ($ch eq ',') { $comcnt++; } elsif ($ch eq '[') { $insq++; } elsif ($ch eq '(') { $inbr++; } elsif ($ch eq ')') { $inbr-- if ($inbr); } } } $dline = $line; $dline =~ s/\n/\$\{m4_newline\}/gm; prt("[06] Comma split [$dline] len $len, commas $comcnt\n"); } $inbr = 0; $insq = 0; $hadcom = 0; for ($i = 0; $i < $len; $i++) { $ch = substr($line,$i,1); if ($insq) { if ($ch =~ /\S/) { $item .= $ch; $hadcom = 0; } elsif ($hadcom == 0) { $item .= $ch; #} elsif (length($item)) { # $item .= $ch; } if ($ch eq ']') { $insq--; prt(" [06] IS:$i: Close square [$item], to [$insq], inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } elsif ($ch eq '(') { $inbr++; prt(" [06] IS:$i: Open bracket [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } elsif ($ch eq ')') { $inbr-- if ($inbr); prt(" [06] IS:$i: Close bracket [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } elsif ($ch eq ',') { prt(" [06] IS:$i: Comma in square [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); $hadcom = 1; } elsif ($ch eq '[') { $insq++; prt(" [06] IS:$i: Bump square [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } elsif ($ch =~ /\S/) { $hadcom = 0; } } elsif ($ch eq '[') { $item .= $ch; $insq++; prt("[06] $i: Open square [$item], to [$insq], inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } elsif ($ch eq ',') { if ($inbr || $insq) { $item .= $ch; prt("[06] $i: Comma [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); } else { prt("[06] $i: Split on Comma [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); push(@arr,$item); $item = ''; } $hadcom = 1; } elsif ($ch eq ')') { if ($inbr) { $item .= $ch; prt("[06] $i: Close bracket [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); } else { push(@arr,$item) if (length($item)); $item = ''; $item = substr($line,($i+1)) if (($i + 1) < $len); $item =~ s/.*\#.*$//; $item = remove_dnl($item); $item = trim_ends($item); prt("[07] $i: Last bracket, rem [$item]\n") if ($dbg_m407); last; } $inbr-- if ($inbr); $hadcom = 0; } elsif ($ch eq '(') { $item .= $ch; $inbr++; prt("[06] $i: Open bracket [$item], in [$insq], or inbr $inbr\n") if ($dbg_m406); $hadcom = 0; } else { if ($ch =~ /\S/) { $item .= $ch; $hadcom = 0; } elsif ($hadcom == 0) { $item .= $ch; #} elsif (length($item)) { # $item .= $ch; } } } push(@arr,$item) if (length($item)); if ($dbg_m406) { $len = scalar @arr; $ch = ($len == ($comcnt+1)) ? "ok" : "CHECK THIS SPLIT!"; prt("[06] Done comma split to $len bits... comcnt $comcnt $ch\n"); } return \@arr; } sub m4_split_macro($$$); sub m4_split_macro($$$) { my ($rparams,$oline,$lev) = @_; my ($mac,$cont,$ra,$cnt1,$itm); my ($mac2,$cont2,$ra2,$itm2,$cnt2); my ($dcont,$ditm); my ($mkey); my $line = $oline; my $rm = ${$rparams}{'CURR_MAC_REF'}; my $mcnt = ${$rparams}{'CURR_MAC_CNT'}; $line = remove_dnl($line); my $ind = ' '; $ind .= ' ' x $lev; my @arr = (); #$line =~ s/\n/\$\{m4_newline\}/gm; $cnt1 = 0; if ($line =~ /^(\w+)\((.+)$/m) { $mac = $1; #$cont = $2; # this excludes after a CR??? $cont = substr($line,(length($mac)+1)); $dcont = $cont; $dcont =~ s/\n/ /gm; $mcnt++; ${$rparams}{'CURR_MAC_CNT'} = $mcnt; $mkey = sprintf("%04d",$mcnt); $mkey .= "_$mac"; prt("\n") if ($lev == 0); prt("${ind}GOOD MAC [$mac], with [$dcont]\n"); #$cont =~ s/\$\{m4_newline\}/\n/gm; $ra = m4_comma_split($cont); ${$rm}{$mkey} = [] if (!defined ${$rm}{$mkey}); my $rma = ${$rm}{$mkey}; $cnt1 = scalar @{$ra}; prt("${ind}MAC [$mac], with $cnt1 components...\n"); $cnt1 = 0; foreach $itm (@{$ra}) { $cnt1++; $ditm = $itm; $ditm =~ s/\n/ /gm; if ($ditm =~ /^\[(.*)\]$/) { $itm = substr($itm,1,(length($itm)-2)); $ditm = substr($ditm,1,(length($ditm)-2)); } if ($itm =~ /^(m4_\w+)\((.+)$/m) { $mac2 = $1; prt( "${ind}$cnt1: as MAC2 [$mac2] [".$ditm."]\n"); $ra2 = m4_split_macro($rparams,$itm,($lev+1)); } else { prt( "${ind}$cnt1: {".$ditm."}\n"); push(@{$rma},$itm); } } } else { $ra = \@arr; prt("\n${ind}NOT AN M4 MACRO [$line]\n"); if ($line =~ /^(\w+)\(/) { $mac = $1; $cont = substr($line,(length($mac)+1)); prt("${ind}Starts with [$mac] ok, but after [$cont]\n"); if ($cont =~ /\)$/m) { prt("${ind}And ends ok with ')' - WHAT IS WRONG?\n"); } else { prt("${ind}Does NOT END in ')'?\n"); } } else { prt("${ind}Does NOT start properly...\n"); } } return $ra; } sub invert_string { return 1 if ($a lt $b); return -1 if ($a gt $b); return 0; } sub m4_process_file($) { my ($rparams) = @_; my $inf = ${$rparams}{'CURR_M4_FILE'}; 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"); my ($cline,$inc,$lnn,$tline,$len,$i,$ln2,$ra,$cnt); my ($itm,$key,$rma,$mkey); for ($i = 0; $i < $lncnt; $i++) { $cline = $lines[$i]; chomp $cline; $lnn = $i + 1; $tline = trim_all($cline); $len = length($tline); next if ($len == 0); next if ($cline =~ /^\s*dnl\s*/); $cline = m4_accumulate_with_back($cline,$lncnt,\$i,\@lines) if ($cline =~ /\\$/); $cline = m4_accumulate_ac_macro($cline,$lncnt,\$i,\@lines) if ($cline =~ /^\s*\w+\(.*$/); $ln2 = $i + 1; prt("\n $lnn-$ln2: {".$cline."}\n"); my %mac = (); my $rm = \%mac; ${$rparams}{'CURR_MAC_REF'} = $rm; ${$rparams}{'CURR_MAC_CNT'} = 0; $ra = m4_split_macro($rparams,$cline,0); $cnt = scalar keys(%{$rm}); prt("MACRO: with $cnt components...\n"); foreach $mkey (sort keys %{$rm}) { # foreach $mkey (sort invert_string keys %{$rm}) { $rma = ${$rm}{$mkey}; $key = $mkey; $key =~ s/^\d+_{1}//; $cnt = scalar @{$rma}; prt("Macro [$key], with $cnt items... [$mkey]\n"); $cnt = 0; foreach $itm (@{$rma}) { $cnt++; prt(" $cnt: $itm\n"); } } } } sub setup_ref_params($) { my ($fil) = @_; my $rp = get_ref_params(); ${$rp}{'CURR_M4_FILE'} = $fil; my %m4_macros = (); ${$rp}{'REF_M4_MACROS'} = \%m4_macros; my %m4_defines = (); ${$rp}{'REF_M4_DEFINES'} = \%m4_defines; return $rp; } ######################################### ### MAIN ### parse_args(@ARGV); my $rh = setup_ref_params($in_file); m4_process_file($rh); pgm_exit(0,"Normal exit(0)"); ######################################## sub give_help { prt("$pgmname: version 0.0.1 2010-09-11\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) = @_; 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)"); } else { pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n"); } } else { $in_file = File::Spec->rel2abs($arg); prt("Set input to [$in_file]\n"); } shift @av; } if ((length($in_file) == 0) && $debug_on) { $in_file = File::Spec->rel2abs($def_file); } if (length($in_file) == 0) { pgm_exit(1,"ERROR: No input files found in command!\n"); } if (! -f $in_file) { pgm_exit(1,"ERROR: Unable to find in file [$in_file]! Check name, location...\n"); } } # SOME HELP # from : http://www.gnu.org/software/m4/manual/m4.html # Character translation is done with translit: — Builtin: translit (string, chars, [replacement]) # Expands to string, with each character that occurs in chars translated into the character # from replacement with the same index. # The builtin dnl stands for “Discard to Next Line”: — Builtin: dnl # All characters, up to and including the next newline, are discarded without # performing any macro expansion. A warning is issued if the end of the file is # encountered without a newline. The expansion of dnl is void. # eof - template.pl