#!/usr/bin/perl

# GPL(C) Mohsin Ahmed, http://www.cs.albany.edu/~mosh

$verbose++;
$noname = 'NONAME000';
$Print  = 'printf';
$Post   = '';                    # Needed for closing paren in macros.

if( $ENV{ 'windir' } || $ENV{'WINDIR'} ){
    $windows++;
    $Print = 'DbgPrint';
}

$USAGE = "
   SYNOPSIS: Generate Functions to dump/$Print structs in header files.
   Notes: o  Input file can be full path, but
             Output files must not exist, and are created pwd.
          o  Current version has more features than the sample shown below.
          o  typedef/struct must begin and end in column 1 for the parser.
" . '
   Options: -h -?         Help
            -v            Verbose, -v2 saves details in file-x.c
            -n            ntsd extension.
            -f            force, dont warn about over writing files.
            -pSTR         Use STR instead of print.
            -m            macro style: print((..))

   Example Usage:
   > pdbg test.h          You get test-x.h and test-x.c

   > cat test.h
     struct xyz {
       int    widd;
       float  flop;
       char*  name;
       PDWORD sum;
       PZVAR  pzv;
     }

   > cat test-x.h
     void print_xyz( char* message, struct xyz * s );

   > cat test-x.c
     void print_xyz( char* message, struct xyz * s )
     {
       print( "struct xyz { \n" );
       print( "  widd  = %d\n",    s->bigwig );
       print( "  flop  = %g\n",    s->flop   );
       print( "  name  = %s\n",    s->name? s->name, "NONE" );
       print( "  sum   = %d\n",    s->sum?  s->sum, 0 );
       print( "  pzv   = x%08x\n", s->pzv?  s->pzv, 0 );
       print( "} // of struct xyz. \n" );
     }
  Author: GPL(C) Mohsin Ahmed, http://www.cs.albany.edu/~mosh
';

# Use this macro to print ip addresses with
# #define ST(ADDR)
#   strncpy( ARIAS, inet_ntoa(*(struct in_addr*)(&(ADDR))), sizeof(ARIAS)-1 )
# char ARIAS[32];
#   printf("%s", ST(s->ipaddr));

while( $_ = $ARGV[0], /^-/ ){
    shift; m/^--$/     && last;
    if( m/^-v(\d*)/ ){
        $verbose = ($1 || 1);
    }elsif( m/^-n/      ){
        ++$ntsdext;
        $Print = "dprintf";
    }elsif( m/^-f/      ){
        ++$force;
    }elsif( m/^-[?h]/i ){
        print $USAGE;
        exit;
    }elsif( m/^-p(.+)/ ){
        $Print = $1 . $Pret;
    }elsif( m/^-m/     ){
        # Options come in any order ie. -pSTR -m
        $Pret     = "(";
        $Post     = ")";
        $Print .= $Pret;
    }else{
        die "Invalid option '$_', try -? for help\n";
    }
}

# =========================================================================
$filename = shift
    || die "Need file, see -? for help\n";
open( INFILE, "<$filename")
    || die "Cannot read $filename\n";
$filename =~ m/([\w\d_]+)\.h$/;
$basename = $1;

print STDERR "// reading $filename ($basename).\n";
print STDERR "Print=$Print(..)$Post\n";

$protofile = $basename . '-x.h';
die "Cannot overwrite $protofile\n"
    if( -e $protofile && ! $force);
open( PROTOFILE, ">$protofile" )
    || die "Cannot write $protofile\n";
print STDERR "// writing protofile $protofile\n";

$extfile = $basename . '-x.c';
die "Cannot overwrite $extfile\n"
    if( -e $extfile && ! $force);
open( EXTFILE, ">$extfile" )
    || die "Cannot write $extfile\n";
print STDERR "// writing extfile $extfile\n";

while( <INFILE> ){

    # if( m/^\#/ && !m/\#define/ ){
    #     print ;
    #     next;
    # }

    # ooooo Start of a typedef/struct?

    if( m/^(typedef\s+)?struct\s*(\w*)\s*\{?\s*$/ ){

        if( m/struct\s+(\w+)/ ){
            $struct_name = $1;
        }else{
            # Name will appear at the end of struct.
            $struct_name = ++$noname;
        }

        # ooooooo First time?

        if( !$print_header++ ){
            $slm_info = slm_info( $filename );
            $today    = localtime;

            print  EXTFILE "// Dump structs of $filename \n";
            print  EXTFILE "// Slm: $slm_info            \n" if $slm_info;
            print  EXTFILE "// Generated by Mohsin Ahmed on $today \n\n";
            print  EXTFILE "#include \"$filename\"       \n";
            print  EXTFILE "#include \"$protofile\"       \n\n";
        }
        &process_struct();
    }
}

print STDERR "// $filename => $protofile and $extfile\n";

close INFILE   ;
close PROTOFILE;
close EXTFILE  ;

sub process_struct {
    my( $var, $ptr, $type, $realname, $line, $varpad, $numfields );

    # ooooooooo Start of struct. ooooooooooooo

    print STDERR "// $filename:$. struct $struct_name\n";

    $line =    "// " . ("=" x 50 ) . "\n"
           .   "// $filename:$. $struct_name\n\n" ;

    if( $ntsdext ){
        $line .= "DECLARE_API( print_$struct_name )\n"
              .  "{\n"
              .  "    struct $struct_name * p = NULL;\n"
              .  "    struct $struct_name   Q;\n"
              .  "    ULONG  result;\n"
              .  "    INIT_API();\n"
              .  '    if( *args )' ."\n"
              .  '        sscanf( args, "%lx", &p );' . "\n"
              .  '    if( !p || !ReadMemory( p, &Q, sizeof(Q), &result )){'
              .                                                           "\n"
              .  '       dprintf("Could not read address 0x%08x\n", p );'."\n"
              .  '       return 0;' . "\n"
              .  '    }' . "\n"
              .  "    print_$struct_name( \"none\", &Q );\n"
              .  "    return;\n"
              .  "}\n";
    }

    $line  .=
              "void\n"
          .   "print_$struct_name( const char* message, const struct $struct_name * s )";

    print PROTOFILE $line, ";\n";

    $line  .=   "\n"
           .    "{\n"
           .    "    if\(  message   \)\{\n"
           .    "       $Print\( \"%s\\n\", message )$Post;\n"
           .    "    \}\n"
           .    "    if\(  s == NULL \)\{\n"
           .    "       $Print\( \"struct $struct_name is NULL.\\n\"\)$Post;\n"
           .    "       return;\n"
           .    "    \}\n"
           .   "    $Print\(\"struct $struct_name \@ 0x\%08x = \{\\n\",s \)$Post;\n";


    # oooooo Parse the fields of the struct.

    while( <INFILE> ){
        $var = $ptr = '';
        $type = '0x%08x';

        if( m/^\}\s*(\w*)/ ){        #  oooooo End of struct?

            $realname = $1;
            $line .= "    $Print\( \"}; // struct $struct_name.\\n\"\)$Post;\n"
                  .  "    return;\n"
                  .  "} /* print_$struct_name */\n\n";

            if( $realname && ($struct_name =~ m/NONAME/ )){
                $struct_name = $realname;
                $line =~ s/NONAME\d+\b/$realname/g;
            }
            print EXTFILE $line;
            return;
        }

        next if m/^\s*$/;               # Blank lines ok anywhere.

        if( $verbose == 2 ){
            $line .= "// $.:$_";        # for debugging.
        }

        if( m/^\s*\#/ && ! m/^\s*\#define/){
                                        # some structs have ifdef fields.
            $line .= $_;                # preserve those for compilation.
            next;
        }

        s/;.*/;/;              # Comment usually follow ';' remove them.

        if( ! s/\s*(\w+)\s*;// ){    # not a usual field?

            # first open brace before any fields is to be ignored.
            if( $numfields++ && !m/^\s*\{/ ){
                $line .= "    // ? $_";  # let the user decide.
            }
            next;
        }

        $var = $1;
        s/^\s*//;                 # Remove leading spaces.
        $ptr = s/^p\B//i;         # Is this a pointer?
        s/\bunsigned\b//i;        # word unsigned is discarded.

        s/\b(short|int|uint|ushort|long|word|dword)\b/INTEGER/i
            && ($type = '%d');
        s/\b(float|double)\b/REAL/i && ($type = '%g');

        s/\bchar\s*\*/STRING/i && ($type = '%s') && $ptr++;
        s/\bchar\s*.*\[.*\]/STRING/i && ($type = '%s');
        if( $ptr ){
            s/\bchar\b/STRING/i && ($type = '%s');
        }else{
            s/\bchar\b/CHAR/i  && ($type = '%c');
        }

        if( $ptr ){

            if( $ntsdext ){
                if( $type eq '%s'){
                    $rvar = "ReadStr( s->$var, 20 )";
                }else{
                    $rvar = "ReadDword( s->$var )";
                }
            }else{
                if( $type =~ m/[dgx]/ ){
                    # PTR to int.
                    $rvar  = "(s->$var? (s->$var):0)";
                }else{
                    # PTR to string.
                    $rvar =  "(s->$var)? (s->$var):\"NONE\"";
                }
            }

            # Use sprintf to align all variable names in final output
            $varpad = sprintf( "%-18s", $var );

            $line .= "    $Print(\"  $varpad = $type \\n\", $rvar )$Post;\n";

        }else{
            # SCALAR.
            $rvar = $var;

            $varpad   = sprintf( "%-18s", $var );
            $line .= "    $Print(\"  $varpad = $type \\n\", s->$rvar )$Post;\n";
        }

    }
}

# from penlist.
# Return the acutal slm filename or nil.

sub slm_info {
    my( $fullfilename ) = (@_);
    my( $info, $dir, $slmdir );
    my( $project, $slmroot, $userroot, $subdir );

    $dir = $fullfilename;
    $dir =~ s,[^/\\].*$,,;
    $dir || ($dir = '.');

    if( ! open( SLMFILE, "<$dir/slm.ini" ) ){
        warn "Cannot read $dir/slm.ini\n";
        return '';
    }
    while( <SLMFILE> ){
        m/^project\s+=\s+(\S+)/     && ( $project=$1  );
        m/^slm\s+root\s+=\s+(\S+)/  && ( $slmroot=$1  );
        m/^user\s+root\s+=\s+(\S+)/ && ( $userroot=$1 );
        m/^sub\s+dir\s+=\s+(\S+)/   && ( $subdir=$1   );
    }
    $info = "$slmroot/src/$project$subdir/$fullfilename";
    $info =~ s,/,\\,g if( $windows );
    $info;
}

#  EOF