#! /usr/bin/perl -w

use File::Path;

%non_basetype = ();
%non_basename = ();
%redeclare = ();
%strunames = ();
%functions = ();

%opt = ("save" => 1 );
%shortopt = ( "-v" => "verbose", "-q" => "quiet", "-m" => "methods", "-fk" => "functions");
for (values %shortopt) { $opt{$_} = 0; }
@argv_files = ();
%argv_outfiles = ();
$opt{"outsub"} = "cc";
$_ = $0; if (/\//) { s/\/[^\/]*//; $opt{"basepath"} = $_; } else { $opt{"basepath"} = "."; }

# scanning the arguments
for (@ARGV)
{
  if (exists $shortopt{$_}) { $opt{$shortopt{$_}} = 1; next; }
  if (/^--(\w.*)=(.*)$/) { $opt{$1} = $2; next; } # options with args are longoptions
  if (/^--not?-(\w.*)$/) { $opt{$1} = 0; next; } 
  if (/^--(\w.*)$/) { $opt{$1} = 1; next; } 
  # anything else is a filename of course
  if (! -f "$_") { print STDERR "$_: file does not exist (skipped)\n"; next; }
  else 
  { # a filename it should be
    my $v = outfile_name($_, $opt{"outsub"});
    print "[<$_>:<$v>]" if $opt{"outfiles"};
    if (exists $argv_outfiles{$v}) { print STDERR "$_: its output $v is also an input file (skipped)\n"; next; }
    push @argv_files, $_;     
    $argv_outfiles{$_} = $v;
  }
}

do $opt{"basepath"}."/"."tokenccode.pl";

$addB = "";
$addE = "";
$used_inherits = 0;

for $F (@argv_files)
{
    my $dir; my $i = 100; my $j;
    my %tokens = ();
  
    open F, "<$F" or print STDERR "$F: input skipped: $!" and next; 
    $T = join( "",<F>); close F;
  
    &token_c_simplify($T, \%tokens, $i);             debug_mksaveof("simps",$T,"$F.simplified");
    &token_c_special_clinkage($T, \%tokens, $i);     debug_mksaveof("simps",$T,"$F.clinkage");
    &token_c_special_flattens($T, \%tokens, $i);     debug_mksaveof("simps",$T,"$F.halfflat");
    &token_c_special_fullflattens($T, \%tokens, $i); debug_mksaveof("simps",$T,"$F.fullflat");

stage_debug_origs:
    if ($opt{"origs"}) 
    {   debug_mksaveof("origs",$T,"$F.orig-zz");
        debug_write_hash("origs",\%tokens,"$F.orig-tk");
        my $TT = $T; # check to see that it is reversible so far...
        &token_c_special_untokenizes($TT, \%tokens); 
        &token_c_unsimplify($TT, \%tokens);
        debug_mksaveof("origs",$TT,"$F.orig");
    }

stage_extras:  print $F,": " unless $opt{"quiet"};        
    my %extra = ( "before"=>"", "attach"=>"", "after"=>"", "addB"=>"", "addE"=>"", "use"=>"");
    set_extras_via($F, \%extra);
    $addB = $extra{"addB"};
    $addE = $extra{"addE"};

    %redeclare = ();  %non_basename = ();  %non_basetype = ();
    if (length $extra{"use"})
    {
        find_var_redeclare($extra{"use"}, \%redeclare);
        find_var_non_basename($extra{"use"}, \%non_basename);
        find_var_non_basetype($extra{"use"}, \%non_basetype);
    }

stage_changes:
    %s_structs = (); # structname -> bodytoken
    %strunames = (); # gname -> structname
    %functions = (); # functionname -> prototypestring
    %s_basetype = (); # structname -> basetype

    register_functions($T,\%tokens,\%functions);  
    register_structs($T,\%tokens,\%s_structs);
    buildof_g_name_of_structs(\%s_structs,\%tokens,\%strunames);
    buildto_basetype_of_structs(\%s_structs,\%tokens,\%s_basetype);
    
stage_add_basetypes:
    $used_inherits = 0;
    kill_non_basetypes(\%s_basetype, \%tokens, \%non_basetype);
    my $stru;
    for $stru (keys %s_structs)
    {   my $base = $s_basetype{$stru};
        if (defined $base)
        {	  			
            $used_inherits +=(
                $tokens{$s_structs{$stru}} =~
                    s/ (\{) (\s*(?:\@\wcomment\d+\@\s*)?) (\b\w+\b) ([\w\s]+) (\;) 
                     / "  __inherits1($base)\n$1 __inherits2($3,$4)$2"/gsex 
            )
        
        }
    }
    $inherits_def =
         "\n#[ifndef __inherits1]"
        ."\n#[ifndef __cplusplus]"
        ."\n#[define __inherits1(x)]"
        ."\n#[define __inherits2(x,y) x y ; ]"
        ."\n#[else]"
        ."\n#[define __inherits1(x) : x ]"
        ."\n#[define __inherits2(x,y)]"
        ."\n#[endif]"
        ."\n#[endif]";
    $inherits_def = "" if ! $used_inherits;

stage_combine_source:         
    my $R; 
    for $R (&find_start_include_files(
        $extra{"before"},$extra{"attach"},$extra{"after"},$addB,$addE))
    {
        open R,"<$R" or print "$R: combine skipped: $!" and next; 
        my $S = join("",<R>); close R;
            		print "[combine: $R]" if $opt{"debug-combines"};
        token_c_special_fullsimplify($S,\%tokens,$i);
        register_functions($S,\%tokens,\%functions);
    }
        		print join (" ", keys %strunames)."... " unless $opt{"quiet"};
                        print join (" ", keys %functions) if $opt{"verbose"};

stage_add_per_struct:  
    for $stru (keys %strunames)
    {
        $tokens{$s_structs{$strunames{$stru}}} =~
            s/ (\}) / &add_inlines($stru).$1 /gsex;
    }

stage_add_per_file:
  
    $addB = "\n\n\#\[ifdef __cplusplus\] \/*generated*\/\n"
             .$addB
             ."\n\#\[endif \/*__cplusplus generated *\/\]\n" if $addB !~ /^\s*$/s;
    $addE = "\n\n\#\[ifdef __cplusplus\] \/*generated*\/\n"
             .$addE
             ."\n\#\[endif \/*__cplusplus generated*\/\]\n" if $addE !~ /^\s*$/s;
  
    $T =~ s/ (\@Bclinkage\d+\@) / $extra{"before"}.$1.$addB.$inherits_def /sex;
    $T =~ s/ (\@Eclinkage\d+\@) / $extra{"attach"}.$1.$extra{"after"}.$addE /sex;

stage_include_cc_filnames:
    $T =~ s/ (\#\[\s*include\s) ([^]]*) (\])
           / $1.&replace_includearg($2,\%tokens).$3 /gmex;

stage_debug_tokens:         
    if ($opt{"tokens"}) 
    {   debug_mksaveof("tokens",$T,"$F.zz");
        debug_write_hash("tokens",\%tokens,"$F.tk");
    }

stage_spitout:  print "\n" unless $opt{"quiet"};

    &token_c_special_untokenizes($T, \%tokens); 
    &token_c_unsimplify($T, \%tokens);

    if ($opt{"save"})
    {   $E = $argv_outfiles{$F}; 
        mksaveof($T,$E) or print STDERR "$E: save failed: $!" and next; 
    }
}

sub outfile_name
{ # $filename, $outsub -> canonic outfilename
    my $v = $_[0];
    if ($v =~ /\//) { $v =~ s/ (\/) ([^\/]*) $/ $1.$_[1]."\/".$2 /sex; return $v; }
    else { return $_[1]."\/".$v; }
}

sub replace_includearg
{ # includearg, \%tokens
   my $v = token_untokenize($_[0], $_[1]); 

   $v =~   
       s/ ([\<\"]) ([^\"\>]+) ([\"\>]) 
        / $1.&replace_include($2).$3 /sex;
   
   print $1 if defined $opt{"debug-include-replace"};
   return $v;
}

sub replace_include
{ # filename -> tested outfilename
    my $file = $_[0];
    return $argv_outfiles{$file} if exists $argv_outfiles{$file};
    my $outfile = outfile_name($file, $opt{"outsub"});
    return $outfile if (-f $outfile);
    return $file;
}


# stores block-tokens with each struct-name in %structs
sub register_structs
{ # $text, \%token, \%structs
  $_[0] =~
       s/ (struct\s+)(\w+) (\s*(?:\@\wcomment\d+\@\s*)?) (\@Sblock\d+\@) 
         / &register_structs_1($_[2],$_[1],$1,$2,$3,$4) /gsex;
}

sub register_structs_1
{ # \%structs, \%tokens, $struP, $struD, $blockP, $blockD
    my ($struP,$struD,$blockP,$blockD) = @_[2..5];
    my $struname;
    
    ${$_[0]}{$struD} = $blockD  if exists ${$_[1]}{$blockD};
    return $struP.$struD.$blockP.$blockD;
}

sub g_name_of
{ # $name -> $g_name
    my $g = $_[0];
    $g =~ s/ ^_?([A-Z]) / lc($1) /ex;
    $g =~ s/ ([A-Z]+) / "_".lc($1) /gex;
    $g =~ s/^_+//;
    return $g;
}

# the values of %gnames are the keys of %structs
sub buildof_g_name_of_structs
{ # \%structs, \%dummy, \%strunames
    my ($i,$n);
    foreach $i (keys %{$_[0]})
    {
        $n = g_name_of($i);
        ${$_[2]}{$n} = $i  if $n ne $i and $i =~ /_/;
    }
}

# the keys of %basetypes are the keys of %structs
sub buildto_basetype_of_structs
{ # \%structs, \%tokens, \%basetypes
    my ($i,$block);
    foreach $i (keys %{$_[0]})
    {	  		
        $block = ${$_[1]}{ ${$_[0]}{$i} };
        if ( $block =~ 
            m/\{\s* (?:\@\wcomment\d+\@\s*)? 
               (\w+) \s*(?:\@\wcomment\d+\@\s*)? 
               (\w+) \s*(?:\@\wcomment\d+\@\s*)?
               \;/sx
           )
        {
            ${$_[2]}{$i} = $1;       
        }                            
    }
}

# undef all entries in basetypes matching the criteria...
sub kill_non_basetypes
{ # \%basetypes, \%dummy, \%non_basetype
    my ($i,$base);
    foreach $i (keys %{$_[0]})
    {
        $base = ${$_[0]}{$i};
        if (defined $_[2] and exists ${$_[2]}{$base} 
            or $base =~ m/^[a-z]+[1-9]*$/ 
            or $base =~ m/Type$/ or $base =~ m/_type$/
            or $base =~ m/Function$/ or $base =~ m/_function$/
           )
        {   ${$_[0]}{$i} = undef; 
        }
    }
}

sub register_functions
{ # $text, \%tokens, \%functions
    			    	print "[functions: " if $opt{"functions"};
    $_[0] =~
    s/([\w\s\*]+) (\b\w+) (\s*\(\s*) ([\s\w\[\]\*\,]+) (\s*\)\s*) (\;|\@Pblock\@)
     / &register_functions_1($_[2], $1,$2,$3,$4,$5,$6) /gsex;
         			print "]" if $opt{"functions"};
}

sub register_functions_1
{ # \%functions, $/m/...
    my ($rtype,$name,$lbrc,$args,$rbrc,$semi) = @_[1..6];
    my $line = join ("",@_[1..6]);
        			print " $name" if $opt{"functions"};
   
    ${$_[0]}{$name} = $rtype.$name.$lbrc.$args.$rbrc;

    return $line;
}


# here comes the real magic...
sub add_inlines
{ # struname
    my $stru = $_[0];
    my $add = "";
        		print "  [INLINES for $stru: " if $opt{"verbose"};
    for $f (sort keys %functions)
    {
        if ($f =~ m/^${stru}_(.*)/ 
        or defined $redeclare{$stru} and $f =~ m/^$redeclare{$stru}_(.*)/)
        {
            print $1," " if $opt{"verbose"};
            $shortname = $1;
            $longname = $f;
            $struct_name = "struct $strunames{$stru}";
            $funcdef  = $functions{$f};
            $rettype  = $funcdef;
            $rettype  =~ s/ ^ ([^\(]+) \(.* / $1 /sx;
            $rettype =~ s/\s+/ /gs;
            $rettype  =~ s/\s$//; $rettype =~ s/\w+$//;
            $rettype  =~ s/^\s//; $rettype =~ s/\s+$//;   
            $funcdecl = $funcdef;
            $funcdecl =~ s/ ^ [^\(]+ \( / \( /x;
            $funcargs = $funcdecl;
            $funcargs =~ s/ ([\w\[\]\*\s]+) (\s|\*)(\w+\s*) (?:\[\d*\]\s*)? ([\)\,]) / $3$4 /gsx;
            $funcargs =~ s/void//g;
            $funcdecl =~ s/\s+/ /g; $funcdecl =~ s/^\s//;  $funcdecl =~ s/\s$//;
            $funcargs =~ s/\s+/ /g; $funcargs  =~ s/^\s//; $funcargs  =~ s/\s$//;
           
            $firsttype = $funcdecl;
            $firsttype =~ s/\s*\(\s*(\w+)(\s|\*).*/$1/;
           
            # the GTK people are severely misguided on returning Widget from any new-function
            $retconv = "";
            if ($shortname =~ m/^new$/ or $shortname =~ m/^new_/) {
                $rettype = "$strunames{$stru}*";
                $retconv = "($rettype)";
            }


               $add .= "  inline static $rettype _${shortname} $funcdecl; \n";
            if ($rettype eq "void")
            {
               $addE .= "inline $rettype\n"
                       ."$strunames{$stru}::_${shortname} $funcdecl \n"
                       ."                { $longname$funcargs; } \n";
            }else{
               $addE .= "inline $rettype\n"
                       ."$strunames{$stru}::_${shortname} $funcdecl \n"
                       ."                { return $retconv$longname$funcargs; } \n";
            }
             
            if ($strunames{$stru} eq "_$firsttype" || $struct_name eq $firsttype)
            {
#                 note: the out-commented version is short in sourcecode but the
#                 c++ compiler will generate bigger codepieces. 
#                 (g++ -fenum-int-equiv -fno-rtti -fno-exceptions)
                $funcdecl =~ s/ (\() [^\,\)]+ ([\,\)]) /$1.($2 eq ")"?")":"")/sex;
                $funcargs =~ s/ (\() [^\,\)]+ ([\,\)]) /$1."this".$2/sex;

                $funcdecl = "(void)" if $funcdecl =~ m/\s*\(\s*\)\s*/;

                if ($rettype eq "void")
                {
                   # compute the type and name of the second(!) argument
                   if ( $funcargs =~ m/,/)
                   {
                      $funcdecl =~ m/ \s*\( ([^\,\)]+) [\,\)] /sx;
                      $arg2 = $1; $arg2 =~ m/^(.*[\s\*])(\w+)\s*$/s;
                      $rettype = $1; $retconv = "($2)"; $rettype =~ s/^\s+//;
#               $add .= "  inline        $rettype ${shortname}_ $funcdecl \n"
#                      ."                { _$shortname$funcargs; return $retconv; } \n";
                $addE  .= "inline        $rettype\n"
                         ."$strunames{$stru}::${shortname}_ $funcdecl \n"
                         ."              { $longname$funcargs; return $retconv; } \n";
                   }else{

#               $add .= "  inline        $rettype ${shortname}_ $funcdecl \n"
#                      ."                { _$shortname$funcargs; } \n";
                $addE  .= "inline        $rettype\n"
                         ."$strunames{$stru}::${shortname}_ $funcdecl \n"
                         ."              { $longname$funcargs; } \n";
                   }
                }else{
#               $add .= "  inline        $rettype ${shortname}_ $funcdecl \n"
#                      ."                { return $retconv _$shortname$funcargs; } \n";
                $addE  .= "inline        $rettype\n"
                         ."$strunames{$stru}::${shortname}_ $funcdecl \n"
                         ."              { return $retconv $longname$funcargs; } \n";
                }
                $add .= "  inline        $rettype ${shortname}_ $funcdecl; \n";
                print $shortname." " if $opt{"methods"};
            }
        } # if startsof like $stru
    } # for $f (%functions)
    print "]\n" if $opt{"verbose"};
   
    if (length $add > 1)
    { 
        return  "\n\#\[ifdef __cplusplus\]\n".$add."\n\#\[endif /*__cplusplus*/\]\n";
    }else{
        return "";
    }
}

sub mkpathof
{ # filename
    my $f = $_[0];
    return if not $f =~ /\//;
    $f =~ s/\/[^\/]*$//;
    mkpath $f if ! -d $f;
}

sub set_extras_via
{ # $file, \%extras
    my $F = $opt{"basepath"}."/extra/".$_[0];
    if (-f $F)
    {
        open F,"<$F" or print "$F: extra skipped: $!" and return;
        my $T = join("",<F>); close F;
        
        $T =~ s/ \/\*\{\s* (\w+) \s*\*\/ 
                 (.*)
                 \/\*\}\s* \1 \s*\*\/
               / ${$_[1]}{$1} = $2; "\/*$1*\/" /gsex;
    }
}

# will only find the first include file in the textpieces given,
# it won't even find an includefile being given after a comment.
sub find_start_include_files
{ # @textpieces
    my @files = ();
    my $ff;

    for $ff (@_)
    {
        if (defined $ff and $ff =~ m/\s*\#include\s* [\"\<] ([^\"\>]+) [\>\"] /sx)
        {
            push @files, $1;
        }
    }
    return @files;
}

sub find_var_redeclare
{ # $text, \%hash

  while ( $_[0] =~
      s/ (\/\* \s* REDECLARE \s* \*\/ \s+)
         \#define \s+ (\w+) \s+ (\w+) \b
      / ${$_[1]}{$2} = $3; $1 /gsex)
  {}
  
  $_[0] =~
      s/ \/\* \s* REDECLARE \s* \*\/ //gsx;
}

sub find_var_non_basename
{ # $text, \%hash

  while ( $_[0] =~
      s/ (\/\* \s* NON?\s*BASENAME \s* \*\/ \s+)
         \#define \s+ (\w+) \s+ (\w+) \b
      / ${$_[1]}{$2} = $3; $1 /gsex)
  {}
  
  $_[0] =~
      s/ \/\* \s* NON?\s*BASENAME \s* \*\/ //gsx;
}

sub find_var_non_basetype
{ # $text, \%hash

  while ( $_[0] =~
      s/ (\/\* \s* NON?\s*BASETYPE \s* \*\/ \s+)
         \#define \s+ (\w+) \s+ (\w+) \b
      / ${$_[1]}{$2} = $3; $1 /gsex)
  {}
  
  $_[0] =~
      s/ \/\* \s* NON?\s*BASETYPE \s* \*\/ //gsx;
}

sub mksaveof
{ # $test, $filename
    my $F = $_[1];
    mkpathof($F);
    open F,">$F" or print "<$F: $!>" and return 0;
    print F $_[0]; close F;
    return 1;
}

sub debugdirof
{ #  $optionname 
    my $dir = $_[0];
    $dir = "debug" if not defined $dir;
    $dir = $opt{$dir} if defined $opt{$dir};
    $dir = "debug" if not defined $dir or $dir == 1;
    $dir .= "/";
    return $dir
}

sub debug_mksaveof
{ # optionname, $text, $filename
    return if not $opt{$_[0]};
    
    $dir = debugdirof($_[0]);
    mksaveof($_[1],"$dir$_[2]") or print "$dir$_[2]: $_[0] : $!";
}

sub debug_write_hash
{ # optionname, \%tokens, $filename
    return if not $opt{$_[0]};
    
    $dir = debugdirof($_[0]);
    token_write_hash("$dir$_[2]",$_[1]) or print "$dir$_[2]: $_[0] : $!";
}