# Win32tests.pl
use AsmUtil_IA32;

$a = "Just Another C&ASM Hacker\n";
$b = "Perl ";
# ----  CopyMemory - the 30 lb. sledge hammer version of  Perl's substr() or unpack("p??",...)
# ---- remember peek & poke ?, its back as CopyMemory:
$CopyMemory = DeclareXSub( "_CopyMemory" , "C:\\WINDOWS\\system32\\kernel32.dll!RtlMoveMemory", "i,i,i","","s");
$QPF = DeclareXSub( "_QPF" , "C:\\WINDOWS\\system32\\kernel32.dll!QueryPerformanceFrequency", "i","i","s");
$QPC = DeclareXSub( "_QPC" , "C:\\WINDOWS\\system32\\kernel32.dll!QueryPerformanceCounter", "i","i","s");
$qsort = DeclareXSub( "_qsort" , "C:\\WINDOWS\\system32\\msvcrt.dll!qsort", "i,i,i,i","","c");
$ClibAtan = DeclareXSub( "_atan" , "C:\\WINDOWS\\system32\\msvcrt.dll!atan", "d","d","c");
$atoi64 = DeclareXSub( "_atoi64" , "C:\\WINDOWS\\system32\\msvcrt.dll!_atoi64", "i","q","c");
$i64toa = DeclareXSub( "_i64toa" , "C:\\WINDOWS\\system32\\msvcrt.dll!_i64toa", "q,i,i","i","c");
print ">>> Win32 API __stdcall tests <<<\n";
print "Before CopyMemory: ",$a; 
$CopyMemory->{Call}(SVPtr($a)+13,SVPtr($b),5); 
print "After  CopyMemory: ",$a;

my $Quad = "\x00" x 8;
$qstr = "\x00" x 80;
$QPF->{Call}(SVPtr($Quad));
$QPFreturn = unpack("i",$QPF->{RetEAX});
if($QPFreturn){
$i64toa->{Call}($Quad,SVPtr($qstr),10);
print  "_i64toa tests:\nticks/second: ",$qstr  ,"\n";
for($i=0;$i<50000;++$i){ 
$QPC->{Call}(SVPtr($Quad));
$qstr = "\x00" x 80;
$i64toa->{Call}($Quad,SVPtr($qstr),10);
print  "ticks: ",$qstr  ,"\r";
}
print "\n";
}
print ">>> Microsoft Visual C Run Time msvcrt.dll(and msvcr??.dll) __cdecl 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")));
$ClibAtan->{Call}(1.00000);
printf("FPU doubles test: 4*atan(1) = Pi = %18.16f\n",4*unpack("d",$ClibAtan->{Ret64bit}));
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 
 $_[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]));
 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 API FUNCTIONS
                "\x68" . pack("I",$get_context_ref)    .# push [Perl_get_context()]
                "\x68" . pack("I",$Tstack_sp_ptr_ref)  .# push [Perl_Tstack_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}();
#cbtest();

sub asm2perl{
 my $lastcaller = (caller(1))[3];
 print "called from ",$lastcaller . "(\@_ = ",join(" ",@_),")\n";
}
print "Back to Perl\n";
__END__
my output:

>>> Win32 API __stdcall tests <<<
Before CopyMemory: Just Another C&ASM Hacker
After  CopyMemory: Just Another Perl  Hacker
_i64toa tests:
ticks/second: 3579545
ticks: 179650690908

>>> Microsoft Visual C Run Time msvcrt.dll(and msvcr??.dll) __cdecl tests <<<
_atoi64 call: Quad(longlong) return test (EDX:EAX)=> 0102030405060708
Perl emulated (un)pack(Q,...) test: 0x0102030405060708
FPU doubles test: 4*atan(1) = Pi = 3.1415926535897931
---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