#!/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
####
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;
####
# add this to your .gdbinit file
define vdis
if $argc != 2
help vdis
else
set $_icount = $arg1
set $_iptr = $arg0
while ( $_icount > 0 )
x/2i $_iptr
echo \033[1A
echo \033[K
set $_nbytes = ($_ - $_iptr)
set $_bcount = 0
while ( $_bcount < $_nbytes )
printf "%02X ", *(unsigned char*)($_iptr + $_bcount)
set $_bcount++
end
printf "\n"
set $_iptr = $_iptr + $_nbytes
set $_icount--
end
end
end
document vdis
Verbose Display of Disassembly mnemonics with machine code bytes
Usage: vdis address number
Example:
(gdb) vdis $pc 3
0x400c30 : push %rbx
53
0x400c31 : sub $0x20,%rsp
48 83 EC 20
0x400c35 : mov 0x200604(%rip),%rax # 0x601240
48 8B 05 04 06 20 00
end
# Init parameters
#set output-radix 0x10
#set input-radix 0x10
#set disassembly-flavor intel
set disassembly-flavor att