package AsmUtil_IA32;

use DynaLoader;
use Exporter;
use File::Basename;
use Config;

use strict;

our @ISA = qw(Exporter);

our @EXPORT = qw(DeclareXSub DeclareCallback SVPtr CInt CQuad cbreturn
                 SVQuad getparameters  $call_argv_ref $get_context_ref $Tstack_sp_ptr_ref);
our @EXPORT_OK = qw(G_DISCARD G_SCALAR G_NOARGS);
our @EXPORT_NOT_OK = qw();
our $VERSION = "0.01";
my $perldll;
#-------- cop.h:
use constant G_SCALAR  =>  0;
use constant G_DISCARD  => 2;
use constant TRUE  =>  1;
use constant FALSE  =>  0;

#--------------- get perl shared object and some API routines---
push @DynaLoader::dl_library_path, dirname($^X) ;  # ActiveState's Win32 perl dll location
($perldll = $Config{libperl}) =~ s/\.lib/\.$Config{so}/i; 
$perldll = DynaLoader::dl_findfile($perldll); 
our $perlAPI =  DynaLoader::dl_load_file($perldll);
our $call_argv_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_call_argv");  # embed.h
our $get_context_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_get_context");
our $Tstack_sp_ptr_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_Istack_sp_ptr"); # perlapi.h
if (!$Tstack_sp_ptr_ref){$Tstack_sp_ptr_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_Tstack_sp_ptr");}
######################## Subs ############### 
sub DeclareXSub{
 my %FARPROC;
 $FARPROC{namespace} = $_[0];
 $FARPROC{lib} = DynaLoader::dl_load_file((split("!",$_[1]))[0]) if $_[1] =~ m/\!/; 
 $FARPROC{procptr} = defined($FARPROC{lib}) ? DynaLoader::dl_find_symbol($FARPROC{lib},(split("!",$_[1]))[1]) : $_[1];
 return  if !defined($FARPROC{procptr});
 $FARPROC{args} = $_[2];
 $FARPROC{rtn} = $_[3];
 if ($^O =~ /win32/i){
   $FARPROC{conv} = defined($_[4]) ? $_[4] : "s" ;  # default calling convention: Win32  __stdcall
 }else{
   $FARPROC{conv} = defined($_[4]) ? $_[4] : "c" ;  # default calling convention: UNIX   __cdecl
 }
 my $stackIN;
 my @stridx;
 my @bytype;
 my $bytspushed;
 my $asmcode = "\x90"; # machine code starts , this can also be \xcc -user breakpoint
 my @Args = split(",",$FARPROC{args});
 @Args = reverse @Args; # pushing order last args first
 foreach my $arg (@Args){
  $stackIN .= "\x68" . pack("I",0) ;    # 4 byte push
  $stackIN .= "\x68" . pack("I",0) if($arg =~ m/d|q/i) ;    # another 4 byte push for doubles,quads
  push(@stridx,length($stackIN)-4+1) if $arg !~ m/d|q/i;
  push(@stridx,length($stackIN)-9+1) if $arg =~ m/d|q/i;  
  push(@bytype,"byval") if $arg =~ m/v|l|i|c|d|q/i;
  push(@bytype,"byref") if $arg =~ m/p|r/i;  # 32 bit pointers
  $bytspushed += 4 ; # 4 byte aligned
  $bytspushed += 4 if($arg =~ m/d|q/i); # another 4 for doubles or quads 
 }
 $FARPROC{sindex} = \@stridx;
 $FARPROC{types} = \@bytype; 
 $FARPROC{stklen} = $bytspushed;
 $FARPROC{edi} = "null"; # 4 bytes long !!! ,how convenient
 $FARPROC{esi} = "null";
 $FARPROC{RetEAX} = "null";  # usual return register
 $FARPROC{RetEDX} = "null";
 $FARPROC{Ret64bit} = "nullnull"; # save double or quad returns
 $FARPROC{stackOUT} ="\x00" x $bytspushed;
 $asmcode .= "$stackIN";
 $asmcode .= "\xb8" . CInt($FARPROC{procptr});  # mov eax, $procptr
 $asmcode .= "\xFF\xd0" ; # call eax  => CALL THE PROCEDURE
# --- save return values info into Perl Strings, including the stack:
# - some calls return values back to the stack, overwriting the original args
 $asmcode .= "\xdd\x1d" . CPtr($FARPROC{Ret64bit})  if $FARPROC{rtn} =~ m/d/i;  # fstp qword [$FARPROC{Ret64bit}]
 $asmcode .= "\xa3" . CPtr($FARPROC{RetEAX});     # mov [$FARPROC{RetEAX}], eax
 $asmcode .= "\x89\x15" . CPtr($FARPROC{RetEDX}); # mov [$FARPROC{RetEDX}], edx
 $asmcode .= "\x89\x35" . CPtr($FARPROC{esi});    # mov [$FARPROC{esi}], esi
 $asmcode .= "\x89\x3d" . CPtr($FARPROC{edi});    # mov [$FARPROC{edi}], edi
 $asmcode .= "\x8d\xb4\x24" if $FARPROC{conv} =~ m/s/i; #
 $asmcode .=  CInt(-$bytspushed)  if $FARPROC{conv} =~ m/s/i;# lea   esi,[esp-$bytspushed]
 $asmcode .= "\x89\xe6" if $FARPROC{conv} =~ m/c/i; # mov   esi,esp
 $asmcode .= "\xbf" .CPtr($FARPROC{stackOUT});    # mov edi, [$FARPROC{stackOUT}]
 $asmcode .= "\xb9" . CInt($bytspushed);          # mov ecx,$bytspushed
 $asmcode .= "\xfc";                              # cld
 $asmcode .= "\xf3\xa4";                          # rep movsb [edi],[esi] => copy the stack
 $asmcode .= "\x8b\x3d" . CPtr($FARPROC{edi});    # mov edi,[$FARPROC{edi}]
 $asmcode .= "\x8b\x35" . CPtr($FARPROC{esi});    # mov esi,[$FARPROC{esi}]
 $asmcode .= "\x81\xc4" . CInt($bytspushed)  if $FARPROC{conv} =~ m/c/i;   # add esp,$bytspushed : __cdecl
 $asmcode .= "\xc3"  ;# ret  __stdcall or __cdecl
 $FARPROC{ASM} = $asmcode;
 $FARPROC{coderef} = DynaLoader::dl_install_xsub($FARPROC{namespace}, SVPtr($FARPROC{ASM}),__FILE__);  
 $FARPROC{Call} = sub{ 
            my @templates = reverse split(",",$FARPROC{args});
            my @args = reverse @_;   # parameters get pushed last first;
# --- edit the machine language pushes with @args ---
            for(my $index = 0; $index < scalar(@{$FARPROC{sindex}}) ; ++$index ) { 
             my @a=split(":",$args[$index]) if $args[$index] =~ m/\:/;
             if($templates[$index] eq "ss"){ $args[$index] = $a[0]<<16 + $a[1];}
             if($templates[$index] eq "cccc"){$args[$index] = $a[0]<<24 + $a[1]<<16 + $a[2]<<8 + $a[3]; }
             if($templates[$index] eq "ccc"){$args[$index] = $a[0]<<16 + $a[1]<<8 + $a[2]; }
             if($templates[$index] eq "cc"){$args[$index] = $a[0]<<8 + $a[1]; }
             if($templates[$index] eq "scc"){$args[$index] = $a[0]<<16 + $a[1]<<8 + $a[2] ; }
             if($templates[$index] eq "ccs"){$args[$index] = $a[0]<<24 + $a[1]<<16 + $a[2] ; }
             if($templates[$index] eq "sc"){$args[$index] = $a[0]<<16 + $a[1] ; }
             if($templates[$index] eq "cs"){$args[$index] = $a[0]<<16 + $a[1]; }
             if($templates[$index] =~ m/d|q/i){
              $args[$index] = pack("d",$args[$index]) if $templates[$index] =~ m/d/i;
              my $Quad = $args[$index] if $templates[$index] =~ m/q/i; 
              substr($FARPROC{ASM}, $FARPROC{sindex}->[$index]+5, 4 ,  substr($args[$index],0,4)) if $templates[$index] =~ m/d/i;
              substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 ,  substr($args[$index],4,4)) if $templates[$index] =~ m/d/i;
              substr($FARPROC{ASM}, $FARPROC{sindex}->[$index]+5, 4 ,  substr($Quad,0,4)) if $templates[$index] =~ m/q/i;
              substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 ,  substr($Quad,4,4)) if $templates[$index] =~ m/q/i;               
             }else{
              substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 ,  CInt($args[$index]))  if $FARPROC{types}->[$index] eq "byval";
             }
             substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 ,  CPtr($args[$index]))  if $FARPROC{types}->[$index] eq "byref"; 
            }
            my $ret = &{$FARPROC{coderef}};  # Invoke it
            return $ret;   # usually EAX==return value - not as reliabe as $FARPROC{RetEAX}
         };
 return \%FARPROC;  # make an object out of a hash( has 1 XSUB, 1 sub, 2 arrays, several scalars)
}

sub DeclareCallback{
 my %CALLBACK;
 $CALLBACK{cbname} = $_[0];
 $CALLBACK{args} = $_[1];
 $CALLBACK{cbrtn} = defined($_[2]) ? $_[2] : "I";
 $CALLBACK{conv} = defined($_[3]) ? $_[3] : "c" ;
 $CALLBACK{ptrptrargs} = "\x00" x 4 ;  # char **args, NULL FOR NOW
 $CALLBACK{stackPtr} = "\x00" x 4;  # ebp
 $CALLBACK{CallerRtn1} = "\x00" x 8;  # eax register usually, possibly for a double
 $CALLBACK{CallerRtn2} = "\x00" x 4;  # edx register usually , for returning 8 byte values edx:eax - doubles
 $CALLBACK{ASM} = 
           "\x90"                                 .# nop or debug break
           "\x55"                                 .# push ebp
           "\x89\xE5"                             .# mov ebp,esp
# -------- local variables - Perl function pointers, stack info  
           "\x68" . CInt($call_argv_ref)          .# push *Perl_call_argv()  
           "\x68" . CInt($get_context_ref)        .# push *Perl_get_context()
           "\x68" . CInt($Tstack_sp_ptr_ref)      .# push *Perl_(I|T)stack_sp_ptr()
           "\x68\x00\x00\x00\x00"                 .# empty local variable
           "\x68\x00\x00\x00\x00"                 .# empty local variable
# -------  get ebp to access C stack on the Perl side and save return registers----------------
           "\x89\x2d" . CPtr($CALLBACK{stackPtr})   .# mov ds:[$CALLBACK{stackPtr}],ebp - stack access
           "\xA3" . CPtr($CALLBACK{CallerRtn1})     .# mov ds:[$CALLBACK{CallerRtn1}],eax - save eax primary return register
           "\x89\x15" . CPtr($CALLBACK{CallerRtn2}) .# mov ds:[$CALLBACK{CallerRtn2}],edx - save edx secondary return register
# ----------------- dSP; MACRO starts -------------------
           "\xff\x55\xf8"                         .# call dword ptr [ebp-0x08] => call Perl_get_context()   
           "\x50"                                 .# push eax  
           "\xff\x55\xf4"                         .# call dword ptr [ebp-0x0c] => call Perl_Tstack_sp_ptr() 
           "\x59"                                 .# pop  ecx 
           "\x8B\x00"                             .# mov  eax,dword ptr [eax] 
           "\x89\x45\xec"                         .# mov  dword ptr [sp],eax  => local copy of SP 
# -------------- perl_call_argv(char *callbackname,G_DISCARD,char **args) -----
           "\x68" . CPtr($CALLBACK{ptrptrargs})   .# push char **args
           "\x68\x02\x00\x00\x00"             .# push G_DISCARD
           "\x68" . CPtr($CALLBACK{cbname})   .# push ptr to name of perl subroutine
           "\xff\x55\xf8"                     .# call Perl_get_context() 
           "\x50"                             .# push eax  
           "\xff\x55\xfc"                     .# call perl_call_argv => call dword ptr [ebp-0x04]     
           "\x83\xc4\x10"                     .# add esp,0x10  CDECL call we maintain stack
           "\x83\xc4\x0c"                     .# add esp,14 # deallocate local variables
           "\x89\xec"                         .# mov esp,ebp
           "\x5D"                             .# pop ebp
           "\xA1" . CPtr($CALLBACK{CallerRtn1})     .# mov eax,[$CALLBACK{CallerRtn1}] - return eax to caller
           "\x8b\x15" . CPtr($CALLBACK{CallerRtn2}) .# mov edx,[$CALLBACK{CallerRtn2}] - return edx to caller
           "\xc3";                             # ret
   $CALLBACK{Ptr} =  SVPtr($CALLBACK{ASM});
 return \%CALLBACK;
}
sub getparameters{
  my $argtmpl;
  if(!defined($_[1])) {return [];};
  my @args = split(",",$_[1]);
  foreach my $arg (@args){ $argtmpl .= $arg;}
  my $template = "P" . (4*scalar(@args)+8); 
  my $Cstack = substr(unpack($template,$_[0]),8);  # copy stack in binary form
  return unpack($argtmpl,$Cstack);
} 
sub cbreturn{
  my %rets = %{$_[0]};
  substr($rets{cbref}->{CallerRtn1},0,4,pack("i",$rets{ret32})) if defined($rets{ret32});
  substr($rets{cbref}->{CallerRtn1},0,4,pack("x4i",$rets{ret32})) if defined($rets{ret64}); # little endian
  substr($rets{cbref}->{CallerRtn2},0,4,pack("ix4",$rets{ret32})) if defined($rets{ret64});
} 
sub SVPtr{
 return unpack("I",pack("p",$_[0]));
} 
sub CPtr{
 return pack("p",$_[0]);
} 
sub CInt{
 return pack("i",$_[0]);
}
sub CShort{
 return pack("s",$_[0]);
}
sub CByte{
 return pack("c",$_[0]);
}
sub CDbl{
 return pack("d",$_[0]);
}
sub CQuad{  # emulates pack("Q",...) - assumes decimal string input
# --- convert an arbitrary length decimal string to a hex string ---
 my @digits = split(//, $_[0]);
 my $lohexstr = substr(sprintf("%08X",substr($_[0],-8)),-2);  # gets the first 8 bits 
 my $totquotient = ""; 
# bit shift to the right 8 bits by dividing by 256,
# using arbitrary precision grade school long division
for (my $j = 0;$j <4 ; ++$j){  # shift 8 bits, 4 times for lower long
 my $remainder = "";
 $totquotient = "";
 my $quotient = "";
 my $dividend = "";
 my $remainder = "";
 for(my $i=0;$i<=$#digits;++$i){  
  $dividend = $remainder . $digits[$i];
  $quotient = int($dividend/256);
  $remainder = $dividend % 256; 
  $totquotient .= sprintf("%01d",$quotient);
 }
 $totquotient =~ s/^0*//;
 last if $j==3;
 $lohexstr = substr(sprintf("%08X",substr($totquotient,-8)),6,2) . $lohexstr; # unshift 8 more bits
 @digits = split(//,$totquotient); 
} 
 my $hihexstr = sprintf("%08X",$totquotient);
 my $lo = pack("H*",  $lohexstr);
 my $hi = pack("H*",  $hihexstr); 
 ( $hi, $lo ) = ( $lo, $hi ) ; # little endian
 return $hi . $lo;  
}
sub SVQuad{  # emulates unpack("Q",...) - assumes binary input 
 my ($hi, $lo) = unpack("NN",$_[0]) ;
 ( $hi, $lo ) = ( $lo, $hi )   ; # little endian
 return sprintf("0x%08X%08X",$hi,$lo); # - Are 64 bit decimal expressions meaningful ?
}

1;