gendef.pl to HTML.

index -|- end

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

index -|- top

checked by tidy  Valid HTML 4.01 Transitional