#!/usr/bin/perl
# linuxtests.pl
use AsmUtil_IA32;
use Config;
use sigtrap;
# --- get myperl shared objects and get C and math libs ----  
@perl_so = `ldd $^X`; 
@system_so = `/sbin/ldconfig -N -X -p`; # not used here, but interesting to hack at
$Clib = (grep {/^\// and /libc\.so/i} split(/ /,(grep( m/libc\.so/i, @perl_so))[0]))[0]; # usually links to $Config{libc}
$mathlib = (grep {/^\// and /libm\.so/i} split(/ /,(grep( m/libm\.so/i, @perl_so))[0]))[0];
$a = "Just Another C&ASM Hacker\n";
$b = "Perl ";
# ----  CopyMemory - the 30 lb. sledge hammer version to perl's substr() or unpack("p??",...)
# ---- remember peek & poke ? its back as CopyMemory:
$CopyMemory = DeclareXSub( "_CopyMemory" , "$Config{libc}!memcpy", "i,i,i","","c");
$qsort = DeclareXSub( "_qsort" , "$Config{libc}!qsort", "i,i,i,i","","c");
if(!defined($qsort)){$qsort = DeclareXSub( "_qsort" , "$mathlib" . "!qsort", "i,i,i,i","","c");}
$Gamma = DeclareXSub( "_gamma" , "$Config{libm}!tgamma", "d","d","c");
$ClibAtan = DeclareXSub( "_atan" , "$mathlib" . "!atan", "d","d","c");
$atoi64 = DeclareXSub( "_atoi64" , "$Config{libc}!atoll", "i","q","c"); # strtoll
$i64toa = DeclareXSub( "_i64toa" , "$Config{libc}!sprintf", "i,i,q","i","c");
print "Before CopyMemory: ",$a; 
$CopyMemory->{Call}(SVPtr($a)+13,SVPtr($b),5); 
print "After  CopyMemory: ",$a; # 0n18446744073709551615 = 0xffffffffffffffff , 0n4294967295 = 0xffffffff

my $Quad = "\x08\x07\x06\x05\x04\x03\x02\x01" ; # little endian for \x01\x02\x03\x04\x05\x06\x07\x08
$qstr = "\x00" x 80;
$i64toa->{Call}(SVPtr($qstr),SVPtr("%lld"),$Quad);
print  "i64toa decimal: 0n72623859790382856 == ",$qstr  ,"\n";
print ">>> $Config{archname} C Run Time $Clib  tests <<<\n";
$qstr = "72623859790382856"; # 0n72623859790382856 == 0x0102030405060708
$atoi64->{Call}(SVPtr($qstr));
printf "atoi64 call: Quad(longlong) return test (EDX:EAX)=> %08X%08X\n", unpack("L",$atoi64->{RetEDX}),unpack("L",$atoi64->{RetEAX}); 
printf("Perl emulated \(un\)pack\(Q,...\) test: %s\n",SVQuad(CQuad("72623859790382856")));
print ">>> $Config{archname} Math Run Time $mathlib  tests <<<\n";
$ClibAtan->{Call}(1.00000);
printf("FPU doubles test: 4*atan(1) = Pi = %18.16f\n",4*unpack("d",$ClibAtan->{Ret64bit}));
$Gamma->{Call}(0.5);
printf("Special functions test Gamma(0.5)**2 = Pi = %18.16f\n",unpack("d",$Gamma->{Ret64bit})**2);
print "---C library qsort calls back to Perl test:\n";
$qcompare = DeclareCallback(__PACKAGE__."::qcompare","p2,p2","","c"); #p2==(short *)
$iArray = pack("s13",399,99,3,1,234,546,789,34,124,894,521,67,754);
print "Before sort:" ,join(",",unpack("s13",$iArray)),"\n";
$qsort->{Call}(SVPtr($iArray),13, 2, $qcompare->{Ptr}); 
print "After  sort:" ,join(",",unpack("s13",$iArray)),"\n";
sub qcompare(){
# ----- reconstruct @_ without XS -----
 my $Cstack = substr(unpack("P16",$qcompare->{stackPtr}),8);  # copy stack in binary form 
 #@_ = getparameters($qcompare->{stackPtr},$qcompare->{args});
 $_[0] = substr($Cstack,0,4); # $_[0] == void*  
 $_[1] = substr($Cstack,4,4);
 $e1=unpack("s",unpack("P2",$_[0])); # $e1 = (Perl scalar) *(short *) $_[0]
 $e2=unpack("s",unpack("P2",$_[1]));
# $e1=unpack("s",$_[0]); 
# $e2=unpack("s",$_[1]); print $e1," ",$e2,"\n";
# substr($qcompare->{CallerRtn1},0,4,pack("i",$e1-$e2)); # return result back to C qsort routine
 cbreturn({cbref => $qcompare ,ret32 => $e1-$e2,}); # return result back to C qsort routine
}
$arg1="Assembly";
$arg2="Callback",
$arg3="To";
$arg4="Perl";
$ptrptrargs = pack("PPPPI",$arg1,$arg2,$arg3,$arg4,0);
$cbname = __PACKAGE__ . "::". "asm2perl";

$cb_asm2perl =  "\x90" .
                "\x68" . pack("I",$call_argv_ref)      .# push [Perl_call_argv()]  PUSH POINTERS TO PERL XS FUNCTIONS
                "\x68" . pack("I",$get_context_ref)    .# push [Perl_get_context()]
                "\x68" . pack("I",$Tstack_sp_ptr_ref)  .# push [Perl_(T|I)stack_sp_ptr()]
                "\x55"                                 .# push ebp
                "\x89\xE5"                             .# mov ebp,esp   use ebp to access XS
# ----------------- dSP; MACRO starts -------------------
                "\xff\x55\x08"                         .# call dword ptr [ebp+8] => call Perl_get_context()   
                "\x50"                                 .# push eax  
                "\xff\x55\x04"                         .# call dword ptr [ebp+4] => 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("callbackname",G_DISCARD,char **args) -----
                "\x68" . pack("P",$ptrptrargs)     .# push char **args
                "\x68\x02\x00\x00\x00"             .# push G_DISCARD
                "\x68" . pack("p",$cbname)         .# push ptr to name of perl subroutine
                "\xff\x55\x08"                     .# call Perl_get_context() 
                "\x50"                             .# push eax  
                "\xff\x55\x0c"                     .# call perl_call_argv:   call dword ptr [ebp+0x0c]
                "\x83\xc4\x10"                     .# add esp,10  CDECL call we maintain stack
                "\x89\xec"                         .# mov esp,ebp
                "\x5D"                             .# pop ebp
                "\x83\xc4\x0c"                     .# add esp,0c
                "\xc3";                             # ret
print ">>> internal XSUB\'s(ASM routine) call/callback test  <<<\n";
print "---Perl calls assembly calls back to Perl test:\n";
$cbtest = DeclareXSub( __PACKAGE__."::cbtest" , SVPtr($cb_asm2perl), "");
$cbtest->{Call}();

sub asm2perl{
 my $lastcaller = (caller(1))[3];
 print "called from ",$lastcaller . "(\@_ = ",join(" ",@_),")\n";
}
print "Back to Perl\n";
__END__
Before CopyMemory: Just Another C&ASM Hacker
After  CopyMemory: Just Another Perl  Hacker
i64toa decimal: 0n72623859790382856 == 72623859790382856
>>> i486-linux-gnu-thread-multi C Run Time /lib/i686/cmov/libc.so.6  tests <<<
atoi64 call: Quad(longlong) return test (EDX:EAX)=> 0102030405060708
Perl emulated (un)pack(Q,...) test: 0x0102030405060708
>>> i486-linux-gnu-thread-multi Math Run Time /lib/i686/cmov/libm.so.6  tests <<<
FPU doubles test: 4*atan(1) = Pi = 3.1415926535897931
Special functions test Gamma(0.5)**2 = Pi = 3.1415926535897936
---C library qsort calls back to Perl test:
Before sort:399,99,3,1,234,546,789,34,124,894,521,67,754
After  sort:1,3,34,67,99,124,234,399,521,546,754,789,894
>>> internal XSUB's(ASM routine) call/callback test  <<<
---Perl calls assembly calls back to Perl test:
called from AsmUtil_IA32::__ANON__(@_ = Assembly Callback To Perl)
Back to Perl