Generated: Sun Aug 21 11:11:02 2011 from gendef.pl 2010/10/23 15.9 KB.
#!/usr/bin/perl -w # NAME: gendef.pl # AIM: Generate a DLL DEF file from a simple list of functions # 23/10/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 $perl_dir = 'C:\GTools\perl'; unshift(@INC, $perl_dir); 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 $out_file = $perl_dir."\\temp.atk.def"; my $proj_name = ''; # DEBUG ONLY my $dbg_01 = 0; my $debug_on = 0; my $def_file = 'C:\Projects\atk-1.32.0\atk\atk.symbols'; my $def_name = 'libatk_1_0'; #my $def_cond = 'ATK_DISABLE_DEPRECATED'; my $def_cond = ''; my %user_conditions = (); my %missed_conditions = (); ### program variables my @warnings = (); my $cwd = cwd(); my $os = $^O; my $in_input_file = 0; 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 show_missed_conditions() { my ($cond); my $cnt = scalar keys(%missed_conditions); prt("Found $cnt conditional compile item(s)...\n") if ($cnt); $cnt = 0; foreach $cond (keys %missed_conditions) { $cnt++; prt(" $cnt: [$cond]\n"); } } sub pgm_exit($$) { my ($val,$msg) = @_; if (length($msg)) { $msg .= "\n" if (!($msg =~ /\n$/)); prt($msg); } show_missed_conditions(); show_warnings($val); close_log($outfile,$load_log); exit($val); } sub prtw($) { my ($tx) = shift; $tx =~ s/\n$//; prt("$tx\n"); push(@warnings,$tx); } sub process_in_file($) { my ($inf) = @_; if (! open INF, "<$inf") { pgm_exit(1,"ERROR: Unable to open file [$inf]\n"); } my @lines = <INF>; close INF; my $lncnt = scalar @lines; my $proj = $proj_name; prt("Processing $lncnt lines, from [$inf]...\n"); my ($line,$inc,$lnn,$i,$incomm,$j2,$len,$j,$pc,$ch,$nc,$ok,$def,$nline); my ($cond,$msg,$condval,$data); $lnn = 0; $incomm = 0; $ch = ''; my @funcs = (); my @cstack = (); my @cvals = (); $condval = 1; for ($i = 0; $i < $lncnt; $i++) { $line = $lines[$i]; chomp $line; $line = trim_all($line); $lnn++; $len = length($line); next if ($len == 0); $ok = 0; $nline = ''; for ($j = 0; $j < $len; $j++) { $j2 = $j + 1; $pc = $ch; $ch = substr($line,$j,1); $nc = ($j2 < $len) ? substr($line,$j2,1) : ''; if ($incomm) { if (($ch eq '/') && ($pc eq '*')) { $incomm = 0; } } else { if ($ch eq '/') { if ($nc eq '*') { $incomm = 1; next; } elsif ($nc eq '/') { last; } } else { if ($line =~ /^\s*\#/) { # conditional # my %user_conditions = (); # my %missed_conditions = (); if ($line =~ /^\s*\#\s*if\s+(.+)$/) { $cond = $1; $condval = 1; $msg = ''; if (defined $user_conditions{$cond}) { $condval = $user_conditions{$cond}; $msg = "User $condval"; } else { $msg = "Not user defined"; $condval = 0; $missed_conditions{$cond} = 1; } push(@cstack,"${cond}_\@_TRUE_\@_"); push(@cvals,$condval); prt("[01] Stored condition [".$cstack[-1]."] $msg\n") if ($dbg_01); } elsif ($line =~ /^\s*\#\s*ifdef\s+(.+)$/) { $cond = $1; $condval = 1; $msg = ''; if (defined $user_conditions{$cond}) { $condval = $user_conditions{$cond}; $msg = "User defined"; $condval = 1; } else { $msg = "Not user defined"; $condval = 0; $missed_conditions{$cond} = 1; } push(@cstack,"${cond}_\@_TRUE_\@"); push(@cvals,$condval); prt("[01] Stored condition [".$cstack[-1]."] $msg\n") if ($dbg_01); } elsif ($line =~ /^\s*\#\s*ifndef\s+(.+)$/) { $cond = $1; $condval = 0; $msg = ''; if (defined $user_conditions{$cond}) { $condval = $user_conditions{$cond}; $msg = "User defined"; $condval = 0; } else { $msg = "Not user defined"; $condval = 1; $missed_conditions{$cond} = 1; } push(@cstack,"${cond}_\@_FALSE_\@"); push(@cvals,$condval); prt("[01] Stored condition [".$cstack[-1]."] $msg\n") if ($dbg_01); } elsif ($line =~ /^\s*\#\s*else/) { if (@cstack) { # switch to opposite if ($cstack[-1] =~ /\@_TRUE_\@/) { $cstack[-1] =~ s/\@_TRUE_\@/\@_FALSE_\@/; prt("[01] Switched condition [".$cstack[-1]."]\n") if ($dbg_01); } elsif ($cstack[-1] =~ /\@_FALSE_\@/) { $cstack[-1] =~ s/\@_FALSE_\@/\@_TRUE_\@/; prt("[01] Switched condition [".$cstack[-1]."]\n") if ($dbg_01); } else { prtw("WARNING: else condition stack does not confirm TRUE or FALSE! = ". $cstack[-1]."\n"); } } else { prtw("WARNING: else encountered without condition stack!\n"); } if (@cvals) { if ($cvals[-1] == 1) { $cvals[-1] = 0; } else { $cvals[-1] = 1; } } $condval = $condval ? 0 : 1; } elsif ($line =~ /^\s*\#\s*endif/) { # end conditional if (@cstack) { $cond = pop @cstack; prt("[01] popped [$cond]\n") if ($dbg_01); } if (@cvals) { pop @cvals; } if (@cvals) { $condval = $cvals[-1]; } else { $condval = 1; } } else { prtw("WARNING: Precompile directive NOT HANDLED [$line]\n"); } last; # end of this line } else { if ($ch =~ /\w/) { $nline .= $ch; $ok++; } else { # only thing found is 'DATA', so $j++; # eat the space for (; $j < $len; $j++) { $ch = substr($line,$j,1); last if ($ch =~ /w/); } for (; $j < $len; $j++) { $ch = substr($line,$j,1); last if ($ch =~ /W/); $data .= $ch; } last; # done this line } } } } } if ($ok) { if ($condval) { push(@funcs,[$nline,$data]); } else { prt("Skipped [$nline], due to condition value!\n"); } } $data = ''; } $lncnt = scalar @funcs; if ($lncnt) { prt("Got list of $lncnt functions to export... from [$inf]\n"); if (length($proj) == 0) { $proj = 'FIX_ME_WITH_CORRECT_LIBRARY_NAME'; prtw("WARNING: Setting project name to [$proj]\n"); } my $max = 0; for ($i = 0; $i < $lncnt; $i++) { $line = $funcs[$i][0]; $data = $funcs[$i][1]; $len = length($line); $max = $len if ($len > $max); } # LIBRARY libatk_1_0 # EXPORTS # Insert @1 # Delete @2 # Member @3 # Min @4 $def = "LIBRARY $proj\n"; $def .= "EXPORTS\n"; $lnn = 0; for ($i = 0; $i < $lncnt; $i++) { $line = $funcs[$i][0]; $data = $funcs[$i][1]; $lnn++; $line .= ' ' while (length($line) < $max); $def .= " $line \@".$lnn; $def .= " $data" if (length($data)); $def .= "\n"; } $def .= "\n"; $def .= "; comment: generated by $pgmname, on ".localtime(time())."\n"; $def .= "\n"; write2file($def,$out_file); prt("Written $lnn functions to [$out_file]\n"); } else { prt("Oops, got NO functions from [$inf]...\n"); } } ######################################### ### MAIN ### parse_args(@ARGV); ###prt( "$pgmname: in [$cwd]: Hello, World...\n" ); process_in_file($in_file); 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"); prt(" --cond <VAL:(0|1)> (-c) = Set a CONDITION FALSE(0), or TRUE(1)\n"); prt(" --in (-i) = Alternate way to give input file.\n"); prt(" --name <proj> (-n) = Set library name, in DEF file.\n"); prt(" --out <file> (-o) = Set the output DEF file name. (Def=$out_file)\n"); prt(" --resp <file> (-r) = Load commands from a response file.\n"); prt(" --dbg (-d) = SHow conditional stack changes.\n"); } sub need_arg { my ($arg,@av) = @_; pgm_exit(1,"ERROR: [$arg] must have following argument!\n") if (!@av); } sub load_input_file($$) { my ($arg,$file) = @_; if (open INF, "<$file") { my @lines = <INF>; close INF; my @carr = (); my ($line,@arr,$tmp); foreach $line (@lines) { $line = trim_all($line); next if (length($line) == 0); next if ($line =~ /^#/); @arr = split(/\s/,$line); foreach $tmp (@arr) { $tmp = local_strip_both_quotes($tmp); push(@carr,$tmp); } } $in_input_file++; parse_args(@carr); $in_input_file--; } else { pgm_exit(1,"ERROR: Unable to 'open' file [$file]!\n") } } sub set_user_cond($$) { my ($arg,$sarg) = @_; my @arr = split(/:/,$sarg); my $cnt = scalar @arr; my $bad = 0; my $msg = ''; my ($cond,$val); if ($cnt == 2) { my $cond = $arr[0]; my $val = $arr[1]; if (($val == 0) || ($val == 1)) { $user_conditions{$cond} = $val; } else { $msg = "Must be of form 'COND:0' or 'COND:1' only."; } } else { $bad = 1; $msg = "Must be of form 'COND:0' or 'COND:1' only."; } if ($bad) { pgm_exit(1,"ERROR: Command [$arg $sarg] INVALID! $msg\n"); } prt("Set condition [$cond], to calue [$val]\n"); } 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 =~ /^c/i) { need_arg(@av); shift @av; $sarg = $av[0]; set_user_cond($arg,$sarg); } elsif ($sarg =~ /^d/i) { $dbg_01 = 1; } elsif ($sarg =~ /^i/i) { need_arg(@av); shift @av; $sarg = $av[0]; $in_file = $sarg; prt("Set input to [$in_file]\n"); } elsif ($sarg =~ /^n/i) { need_arg(@av); shift @av; $sarg = $av[0]; $proj_name = $sarg; prt("Set project NAME to [$proj_name]\n"); } elsif ($sarg =~ /^o/i) { need_arg(@av); shift @av; $sarg = $av[0]; $out_file = $sarg; prt("Set output file to [$out_file]\n"); } elsif ($sarg =~ /^r/i) { need_arg(@av); shift @av; $sarg = $av[0]; prt("Loading from response file [$sarg]\n"); load_input_file($arg,$sarg); } else { pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n"); } } else { $in_file = $arg; prt("Set input to [$in_file]\n"); } shift @av; } if ($in_input_file == 0) { if ($debug_on) { # just some DEBUG values if (length($in_file) == 0) { $in_file = $def_file; prt("[debug] Set input to DEFAULT [$in_file]\n"); } if (length($proj_name) == 0) { $proj_name = $def_name; prt("[debug] Set project NAME to DEFAULT [$proj_name]\n"); } if (length($def_cond)) { $user_conditions{$def_cond} = 1; prt("[debug] Added DEFAULT condition [$def_cond]\n"); } } 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"); } if (length($proj_name) == 0) { prtw("WARNING: NO project NAME found in command!\n"); } } } # eof - template.pl