# calltests.pl
use AsmUtil_IA32;

use strict;

{
    $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:

    my $CopyMemory =
      DeclareXSub( "_CopyMemory",
        "C:\\WINDOWS\\system32\\kernel32.dll!RtlMoveMemory",
        "i,i,i", "", "s" );
    my $QPF =
      DeclareXSub( "_QPF",
        "C:\\WINDOWS\\system32\\kernel32.dll!QueryPerformanceFrequency",
        "i", "i", "s" );
    my $QPC =
      DeclareXSub( "_QPC",
        "C:\\WINDOWS\\system32\\kernel32.dll!QueryPerformanceCounter",
        "i", "i", "s" );
    my $qsort =
      DeclareXSub( "_qsort", "C:\\WINDOWS\\system32\\msvcrt.dll!qsort",
        "i,i,i,i", "", "c" );
    my $ClibAtan =
      DeclareXSub( "_atan", "C:\\WINDOWS\\system32\\msvcrt.dll!atan",
        "d", "d", "c" );
    my $atoi64 =
      DeclareXSub( "_atoi64", "C:\\WINDOWS\\system32\\msvcrt.dll!_atoi64",
        "i", "q", "c" );
    my $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;
    my $qstr = "\x00" x 80;
    $QPF->{Call}( SVPtr($Quad) );
    my $QPFreturn = unpack( "i", $QPF->{RetEAX} );

    if ($QPFreturn) {
        $i64toa->{Call}( $Quad, SVPtr($qstr), 10 );
        print "_i64toa tests:\nticks/second: ", $qstr, "\n";
        for ( my $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";
    my $qcompare =
      DeclareCallback( __PACKAGE__ . "::qcompare", "p2,p2", "", "c" )
      ;    #p2==(short *)
    my $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 );
        my $e1 =
          unpack( "s", unpack( "P2", $_[0] ) )
          ;    # $e1 = (Perl scalar) *(short *) $_[0]
        my $e2 = unpack( "s", unpack( "P2", $_[1] ) );
        cbreturn( { cbref => $qcompare, ret32 => $e1 - $e2, } )
          ;    # return result back to C qsort routine
    }
    my $arg1       = "Assembly";
    my $arg2       = "Callback";
    my $arg3       = "To";
    my $arg4       = "Perl";
    my $ptrptrargs = pack( "PPPPI", $arg1, $arg2, $arg3, $arg4, 0 );
    my $cbname     = __PACKAGE__ . "::" . "asm2perl";

    my $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_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";
    my $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";
}