/*
# Win32::API::Callback - Perl Win32 API Import Facility
#
# Original Author: Aldo Calpini <dada@perl.it>
# Rewrite Author: Daniel Dragan <bulk88@hotmail.com>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
# Other Credits:
# Changes for gcc/cygwin by Reini Urban <rurban@x-ray.at> (code removed)
#
# $Id$
*/
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <memory.h>
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
//undo perl messing with stdio
//perl's stdio emulation layer is not OS thread safe
#define NO_XSLOCKS
#include "XSUB.h"
#define CROAK croak
#ifndef _WIN64
#define WIN32BIT
#define WIN32BITBOOL 1
#else
#define WIN32BITBOOL 0
#endif
#include "../API.h"
#define IMAGE_SNAP_BY_ORDINAL_CAST(x) IMAGE_SNAP_BY_ORDINAL((DWORD_PTR) x )
#define IMAGE_ORDINAL_CAST(x) IMAGE_ORDINAL((DWORD_PTR) x )
//older VSes dont have this flag
#ifndef HEAP_CREATE_ENABLE_EXECUTE
#define HEAP_CREATE_ENABLE_EXECUTE 0x00040000
#endif
HANDLE execHeap;
/*dont run CRT init code on MSVC, see note in API.xs*/
#ifdef _MSC_VER
BOOL WINAPI _DllMainCRTStartup(
#else
BOOL WINAPI DllMain(
#endif
HINSTANCE hinstDLL,
DWORD fdwReason,
LPVOID lpReserved )
{
switch( fdwReason )
{
case DLL_PROCESS_ATTACH:
if(!DisableThreadLibraryCalls(hinstDLL)) return FALSE;
execHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE
| HEAP_GENERATE_EXCEPTIONS, 0, 0);
if(!execHeap) return FALSE;
break;
case DLL_PROCESS_DETACH:
return HeapDestroy(execHeap);
break;
}
return TRUE;
}
/*
* some Perl macros for backward compatibility
*/
#ifdef NT_BUILD_NUMBER
#define boolSV(b) ((b) ? &sv_yes : &sv_no)
#endif
#ifndef PL_na
# define PL_na na
#endif
#ifndef SvPV_nolen
# define SvPV_nolen(sv) SvPV(sv, PL_na)
#endif
#ifndef call_pv
# define call_pv(name, flags) perl_call_pv(name, flags)
#endif
#ifndef call_sv
# define call_sv(name, flags) perl_call_sv(name, flags)
#endif
#define PERL_API_VERSION_LE(R, V, S) (PERL_API_REVISION < (R) || \
(PERL_API_REVISION == (R) && (PERL_API_VERSION < (V) ||\
(PERL_API_VERSION == (V) && (PERL_API_SUBVERSION <= (S))))))
#if PERL_API_VERSION_LE(5, 13, 8)
MAGIC * my_find_mg(SV * sv, int type, const MGVTBL *vtbl){
MAGIC *mg;
for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type && mg->mg_virtual == vtbl)
assert (mg->mg_ptr);
return mg;
}
return NULL;
}
#define mg_findext(a,b,c) my_find_mg(a,b,c)
#endif
#ifdef WIN32BIT
typedef struct {
unsigned short unwind_len;
unsigned char F_Or_D;
unsigned char unused;
} FuncRtnCxt;
#if 0
////the template used in the MakeCB for x86
unsigned __int64 CALLBACK CallbackTemplate2() {
void (*PerlCallback)(SV *, void *, unsigned __int64 *, FuncRtnCxt *) = 0xC0DE0001;
FuncRtnCxt FuncRtnCxtVar;
unsigned __int64 retval;
PerlCallback((SV *)0xC0DE0002, (void*)0xC0DE0003, &retval, &FuncRtnCxtVar);
return retval;
}
typedef union {
float f;
double d;
} FDUNION;
////the template used in the MakeCB for x86
double CALLBACK CallbackTemplateD() {
void (*PerlCallback)(SV *, void *, unsigned __int64 *, FuncRtnCxt *) = 0xC0DE0001;
FuncRtnCxt FuncRtnCxtVar;
FDUNION retval;
PerlCallback((SV *)0xC0DE0002, (void*)0xC0DE0003, (unsigned __int64 *)&retval, &FuncRtnCxtVar);
if(FuncRtnCxtVar.F_Or_D){
return (double) retval.f;
}
else{
return retval.d;
}
}
#endif //#if 0
#endif
////unused due to debugger callstack corruption
////alternate design was implemented
//#ifdef _WIN64
//
//#pragma optimize( "y", off)
//////the template used in the MakeCBx64
//void * CALLBACK CallbackTemplate64fin( void * a
// //, void * b, void * c, void * d
// , ...
// ) {
// void (*LPerlCallback)(SV *, void *, unsigned __int64 *, void *) =
// ( void (*)(SV *, void *, unsigned __int64 *, void *)) 0xC0DE00FFFF000001;
// __m128 arr [4];
// __m128 retval;
// arr[0].m128_u64[0] = 0xFFFF00000000FF10;
// arr[0].m128_u64[1] = 0xFFFF00000000FF11;
// arr[1].m128_u64[0] = 0xFFFF00000000FF20;
// arr[1].m128_u64[1] = 0xFFFF00000000FF21;
// arr[2].m128_u64[0] = 0xFFFF00000000FF30;
// arr[2].m128_u64[1] = 0xFFFF00000000FF31;
// arr[3].m128_u64[0] = 0xFFFF00000000FF40;
// arr[3].m128_u64[1] = 0xFFFF00000000FF41;
//
// LPerlCallback((SV *)0xC0DE00FFFF000002, (void*) arr, (unsigned __int64 *)&retval,
// (DWORD_PTR)&a);
// return *(void **)&retval;
//}
//#pragma optimize( "", on )
//#endif
#ifdef WIN32BIT
typedef unsigned __int64 CBRETVAL; //8 bytes
#else
//using a M128 SSE variable casues VS to use aligned SSE movs, Perl's malloc
//(ithread mempool tracking included) on x64 apprently aligns to 8 bytes,
//not 16, then it crashes so DONT use a SSE type, even though it is
typedef struct {
char arr[16];
} CHAR16ARR;
typedef CHAR16ARR CBRETVAL; //16 bytes
#endif
void PerlCallback(SV * obj, void * ebp, CBRETVAL * retval
#ifdef WIN32BIT
,FuncRtnCxt * rtncxt
#endif
) {
dTHX;
#if defined(USE_ITHREADS)
{
if(aTHX == NULL) {
//due to NO_XSLOCKS, these are real CRT and not perl stdio hooks
fprintf(stderr, "Win32::API::Callback (XS) no perl interp "
"in thread id %u, callback can not run\n", GetCurrentThreadId());
//can't return safely without stack unwind count from perl on x86,
//so exit thread is next safest thing, some/most libs will leak
//from this
ExitThread(0); // 0 means failure? IDK.
}
}
#endif
{
dSP;
SV * retvalSV;
#ifdef WIN32BIT
SV * unwindSV;
SV * F_Or_DSV;
#endif
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, (WIN32BITBOOL?5:3));
mPUSHs(newRV_inc((SV*)obj));
mPUSHs(newSVuv((UV)ebp));
retvalSV = sv_newmortal();
PUSHs(retvalSV);
#ifdef WIN32BIT
unwindSV = sv_newmortal();
PUSHs(unwindSV);
F_Or_DSV = sv_newmortal();
PUSHs(F_Or_DSV);
#endif
PUTBACK;
call_pv("Win32::API::Callback::RunCB", G_VOID);
#ifdef WIN32BIT
rtncxt->F_Or_D = (unsigned char) SvUV(F_Or_DSV);
rtncxt->unwind_len = (unsigned short) SvUV(unwindSV);
#endif
//pad out the buffer, uninit irrelavent
*retval = *(CBRETVAL *)SvGROW(retvalSV, sizeof(CBRETVAL));
FREETMPS;
LEAVE;
return;
}
}
#ifdef _WIN64
//on entry R10 register must be a HV *
//, ... triggers copying to shadow space the 4 param registers on VS
//relying on compiler to not optimize away copying void *s b,c,d to shadow space
void CALLBACK Stage2CallbackX64( void * a
//, void * b, void * c, void * d
, ...
) {
//CONTEXT is a macro in Perl, can't use it
struct _CONTEXT cxt;
CBRETVAL retval; //RtlCaptureContext is using a bomb to light a cigarette
//a more efficient version is to write this in ASM, but that means GCC and
//MASM versions, this func is pure C, "struct _CONTEXT cxt;" is 1232 bytes
//long, pure hand written machine code in a string, like the jump trampoline
//corrupts the callstack in VS 2008, RtlAddFunctionTable is ignored by VS
//2008 but not WinDbg, but WinDbg is impossibly hard to use, if its not
//in a DLL enumeratable by ToolHelp/Process Status API, VS won't see it
//I tried a MMF of a .exe, the pages were formally backed by a copy of the
//original .exe, VMMap verified, did a RtlAddFunctionTable, VS 2008 ignored
//it, having Win32::API::Callback generate 1 function 1 time use DLLs from
//a binary blob template in pure Perl is possible but insane
RtlCaptureContext(&cxt); //null R10 in context is a flag to return
if(!cxt.R10){//stack unwinding is not done
return; //by callee on x64 so all funcs are vararg/cdecl safe
}
//don't assume there aren't any secret variables or secret alignment padding
//, security cookie, etc, dont try to hard code &cxt-&a into a perl const sub
//C compiler won't produce such a offset unless you run callbacktemplate live
//calculating the offset in C watch window and hard coding it is going to
//break in the future
cxt.Rax = (unsigned __int64) &a;
PerlCallback((SV *) cxt.R10, (void*) &cxt, &retval);
cxt.Rax = *(unsigned __int64 *)&retval;
cxt.Xmm0 = *(M128A *)&retval;
cxt.R10 = (unsigned __int64)NULL; //trigger a return
RtlRestoreContext(&cxt, NULL);//this jumps to the RtlCaptureContext line
//unreachable
}
#endif
#if defined(USE_ITHREADS)
//Code here to make a inter thread refcount to deal with ithreads cloning
//to prevent a double free
int HeapBlockMgDup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
InterlockedIncrement((LONG *)mg->mg_ptr);
return 1;
}
const static struct mgvtbl vtbl_HeapBlock = {
NULL, NULL, NULL, NULL, NULL, NULL, HeapBlockMgDup, NULL,
};
#endif
/* loops through the import table of a DLL, if the target import func is found
it will be replaced, if OldFunc not null, old func ptr will be placed in OldFunc.
On failure returns FALSE and error is in GLR. oldFunc is the only parameter
which may be NULL. ImportFunctionName is treated as an ordinal if it is not
POK*/
static BOOL PatchIAT(pTHX_ PIMAGE_DOS_HEADER dosHeader, SV * ImportDllName,
SV * ImportFunctionName, void ** oldFunc, void * newFunc){
#define APPRVA2ABS(x) ((DWORD_PTR)dosHeader + (DWORD_PTR)(x))
if( dosHeader
&& !IsBadReadPtr(dosHeader, sizeof(*dosHeader))
&& dosHeader->e_magic == IMAGE_DOS_SIGNATURE){
PIMAGE_NT_HEADERS ntHeader = (PIMAGE_NT_HEADERS)APPRVA2ABS(dosHeader->e_lfanew);
if( ntHeader
&& !IsBadReadPtr(ntHeader, sizeof(*ntHeader))
&& ntHeader->Signature == IMAGE_NT_SIGNATURE
&& ntHeader->OptionalHeader.Magic == IMAGE_NT_OPTIONAL_HDR_MAGIC
//not a OBJ file, bug below if some of the entrys are not present?
&& ntHeader->FileHeader.SizeOfOptionalHeader >= sizeof(IMAGE_OPTIONAL_HEADER)
&& ntHeader->OptionalHeader.NumberOfRvaAndSizes >= IMAGE_DIRECTORY_ENTRY_IMPORT+1
){
DWORD pDataDirImportRVA = ntHeader->OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress;
DWORD pDataDirImportSize = ntHeader->OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].Size;
PIMAGE_IMPORT_DESCRIPTOR importDescriptor = (PIMAGE_IMPORT_DESCRIPTOR)APPRVA2ABS(pDataDirImportRVA);
if(pDataDirImportSize
&& pDataDirImportRVA
&& !IsBadReadPtr(importDescriptor, pDataDirImportSize)){
STRLEN DllNameLen;
char * DllNameStr = SvPV(ImportDllName, DllNameLen);
while (importDescriptor->Name != 0){
const char * const TargetDllNameStr = (char *)APPRVA2ABS(importDescriptor->Name);
const int TargetDllNameLen = lstrlenA(TargetDllNameStr); /*lstrlenA has SEH, strlen doesn't*/
#ifdef WIN32_API_DEBUG
Perl_warn(aTHX_ "IATPatch::new saw app import dep dll name %s\n", TargetDllNameStr);
#endif
if(TargetDllNameLen == 0) goto NO_MORE_LIBS;
if(TargetDllNameLen == DllNameLen
&& strnicmp(TargetDllNameStr, DllNameStr, TargetDllNameLen) == 0
&& importDescriptor->OriginalFirstThunk
&& importDescriptor->FirstThunk
){
PIMAGE_THUNK_DATA OriginalFirstThunk;
void ** FirstThunk;
STRLEN FunctionNameLen;
char * FunctionNameStr;
SvGETMAGIC(ImportFunctionName);
if(SvPOK(ImportFunctionName)){
FunctionNameStr = SvPV_nomg(ImportFunctionName, FunctionNameLen);
if(IMAGE_SNAP_BY_ORDINAL_CAST(FunctionNameStr)) croak("IATPatch 3GB mode not supported");
}
else{ /*is an ordinal*/
FunctionNameStr = (char *) (IMAGE_ORDINAL_FLAG | (DWORD_PTR)SvIV_nomg(ImportFunctionName));
}/*XXX should we croak if not IOK but NOK or ROK?*/
OriginalFirstThunk = (PIMAGE_THUNK_DATA)APPRVA2ABS(importDescriptor->OriginalFirstThunk);
FirstThunk = (void**)APPRVA2ABS(importDescriptor->FirstThunk);
/*note only the first slice in the array is probed, they others should be valid if the 1st one is*/
if(! IsBadReadPtr(OriginalFirstThunk, sizeof(IMAGE_THUNK_DATA))
&& ! IsBadReadPtr(FirstThunk, sizeof(void *))){
while(OriginalFirstThunk->u1.ForwarderString != 0){
/*ordinal status of want == ordinal status of have entry*/
if(IMAGE_SNAP_BY_ORDINAL_CAST(FunctionNameStr) == IMAGE_SNAP_BY_ORDINAL(OriginalFirstThunk->u1.Ordinal)){
/*want ordinal*/ if(IMAGE_SNAP_BY_ORDINAL_CAST(FunctionNameStr)){
/*ordinals match*/ if(IMAGE_ORDINAL_CAST(FunctionNameStr)
== IMAGE_ORDINAL_CAST(OriginalFirstThunk->u1.Ordinal))
goto FOUND_IMPORT_ENTRY;
}/*end of want ordinal*/
/*want name*/ else{
PIMAGE_IMPORT_BY_NAME TargetImport = (PIMAGE_IMPORT_BY_NAME)APPRVA2ABS(OriginalFirstThunk->u1.AddressOfData);
char * TargetFunctionNameStr = TargetImport->Name;
int TargetFunctionNameLen = lstrlenA(TargetFunctionNameStr); /*lstrlenA has SEH, strlen doesn't*/
if(TargetFunctionNameLen == FunctionNameLen
&& memcmp(TargetFunctionNameStr, FunctionNameStr, TargetFunctionNameLen) == 0){
FOUND_IMPORT_ENTRY:
if(oldFunc) *oldFunc = *FirstThunk;
if(IsBadWritePtr(FirstThunk, sizeof(void *))){ /*dont touch page flags unless mandatory*/
DWORD newProtectFlag, oldProtectFlag;
MEMORY_BASIC_INFORMATION mbi;
if(!VirtualQuery(FirstThunk, &mbi, sizeof(mbi) )) goto ERROR;
newProtectFlag = mbi.Protect;
newProtectFlag &= ~(PAGE_READONLY | PAGE_EXECUTE_READ);
newProtectFlag |= PAGE_READWRITE;
if (!VirtualProtect(FirstThunk, sizeof(void *), newProtectFlag, &oldProtectFlag)) goto ERROR;
*FirstThunk = newFunc;
if (!VirtualProtect(FirstThunk, sizeof(void *), oldProtectFlag, &newProtectFlag)) goto ERROR;
return TRUE;
}
*FirstThunk = newFunc;
return TRUE;
}
}/*end of want name*/
}/*end of ordinal status test*/
#ifdef WIN32_API_DEBUG
/*this dont not print all import dll names and func names, only the ones seen
until the import we want to patch is found, if the import we want is not found,
then you see all of them
*/
if(IMAGE_SNAP_BY_ORDINAL(OriginalFirstThunk->u1.Ordinal))
Perl_warn(aTHX_ "IATPatch::new saw app import dep ordinal %u\n",
IMAGE_ORDINAL_CAST(OriginalFirstThunk->u1.Ordinal));
else{
PIMAGE_IMPORT_BY_NAME TargetImport = (PIMAGE_IMPORT_BY_NAME)APPRVA2ABS(OriginalFirstThunk->u1.AddressOfData);
char * TargetFunctionNameStr = TargetImport->Name;
int TargetFunctionNameLen = lstrlenA(TargetFunctionNameStr); /*lstrlenA has SEH, strlen doesn't*/
Perl_warn(aTHX_ "IATPatch::new saw app import dep func name %s\n"
, TargetFunctionNameLen? TargetFunctionNameStr : "is NULL" );
}
#endif
OriginalFirstThunk++;
FirstThunk++;
}
}
SetLastError(IMAGE_SNAP_BY_ORDINAL_CAST(FunctionNameStr) ? ERROR_INVALID_ORDINAL : ERROR_PROC_NOT_FOUND);
goto ERROR;
}
importDescriptor++;
}
NO_MORE_LIBS:
SetLastError(ERROR_MOD_NOT_FOUND);
goto ERROR;
}
}
}
SetLastError(ERROR_BAD_EXE_FORMAT);
ERROR:
return FALSE;
#undef APPRVA2ABS
}
MODULE = Win32::API::Callback PACKAGE = Win32::API::Callback
PROTOTYPES: DISABLE
BOOT:
{
SV * PtrHolder = get_sv("Win32::API::Callback::Stage2FuncPtrPkd", 1);
#ifdef _WIN64
void * p = (void *)Stage2CallbackX64;
HV *stash;
#else
void * p = (void *)PerlCallback;
#endif
sv_setpvn(PtrHolder, (char *)&p, sizeof(void *)); //gen a packed value
#ifdef _WIN64
stash = gv_stashpv("Win32::API::Callback", TRUE);
newCONSTSUB(stash, "CONTEXT_XMM0", newSViv(offsetof(struct _CONTEXT, Xmm0)));
newCONSTSUB(stash, "CONTEXT_RAX", newSViv(offsetof(struct _CONTEXT, Rax)));
#endif
}
void
PackedRVTarget(sv)
SV * sv
PPCODE:
mPUSHs(newSVpvn((char*)&(SvRV(sv)), sizeof(SV *)));
# MakeParamArr is written without null checks or lvalue=true since
# the chance of crashing is zero unless someone messed with the PM file and
# broke it, this isn't a public sub, putting in null checking
# and croaking if null is a waste of resources, if someone is
# modifying ::Callback, the crash will
# alert them to their errors similar to an assert(), but without the cost of
# asserts or lack of them in non-debugging builds
#
# all parts of MakeParamArr must be croak safe, all SVs must be mortal where
# appropriate, the type letters are from the user, they are not sanitized,
# so group upper and lower together where 1 of the letters is meaningless
#
# arr is emptied out of elements/cleared/destroyed by this sub, so Dumper() it
# before this is called for debugging if you want but not after calling this
void
MakeParamArr( self, arr)
HV * self
AV * arr
PREINIT:
AV * retarr = (AV*)sv_2mortal((SV*)newAV()); //croak possible
int iTypes;
AV * Types;
I32 lenTypes;
PPCODE:
//intypes array ref is always created in PM file
Types = (AV*)SvRV(*hv_fetch(self, "intypes", sizeof("intypes")-1, 0));
lenTypes = av_len(Types)+1;
for(iTypes=0;iTypes < lenTypes;iTypes++){
SV * typeSV = *av_fetch(Types, iTypes, 0);
char type = *SvPVX(typeSV);
//both are never used on 64 bits
#if IVSIZE == 4
#define MK_PARAM_OP_8B 0x1
#define MK_PARAM_OP_32BIT_QUAD 0x2
#endif
char op = 0;
SV * packedParamSV;
char * packedParam;
SV * unpackedParamSV;
switch(type){
case 's':
case 'S':
croak("Win32::API::Callback::MakeParamArr type letter \"S\" and"
" struct support not implemented");
//in Perl this would be #push(@arr, MakeStruct($self, $i, $packedparam));
//but ::Callback doesn't have C prototype type parsing
//intypes arr is letters not C types
break;
case 'I': //type is already the correct unpack letter
case 'i':
break;
case 'F':
type = 'f';
case 'f':
break;
case 'D':
type = 'd';
case 'd':
#if IVSIZE == 4
op = MK_PARAM_OP_8B;
#endif
break;
case 'N':
case 'L':
#if IVSIZE == 8
case 'Q':
#endif
type = 'J';
break;
case 'n':
case 'l':
#if IVSIZE == 8
case 'q':
#endif
type = 'j';
break;
#if IVSIZE == 4
case 'q':
case 'Q':
op = MK_PARAM_OP_32BIT_QUAD | MK_PARAM_OP_8B;
break;
#endif
case 'P': //p/P are not documented and not implemented as a Callback ->
type = 'p'; //return type, as "in" type probably works but this is
case 'p': //untested
break;
default:
croak("Win32::API::Callback::MakeParamArr "
"\"in\" parameter %d type letter \"%c\" is unknown", iTypes+1, type);
}
packedParamSV = sv_2mortal(av_shift(arr));
#if IVSIZE == 4
if(op & MK_PARAM_OP_8B)
sv_catsv_nomg(packedParamSV, sv_2mortal(av_shift(arr)));
if((op & MK_PARAM_OP_32BIT_QUAD) == 0){
#endif
packedParam = SvPVX(packedParamSV);
if(type == 'p'){ //test if acc vio before a null is found, ret undef then
if(IsBadStringPtr(packedParam, ~0)){
unpackedParamSV = &PL_sv_undef;
}
else{
unpackedParamSV = newSVpv(packedParam, 0);
}
goto HAVEUNPACKED;
}
PUTBACK;
unpackstring(&type, &type+1, packedParam, packedParam+SvCUR(packedParamSV), 0);
SPAGAIN;
unpackedParamSV = POPs;
#if IVSIZE == 4
}
else{//have MK_PARAM_OP_32BIT_QUAD
SV ** tmpsv = hv_fetch(self, "UseMI64", sizeof("UseMI64")-1, 0);
if(tmpsv && sv_true(*tmpsv)){
ENTER;
PUSHMARK(SP); //stack extend not needed since we got 2 params
//on the stack already from caller, so stack minimum 2 long
PUSHs(packedParamSV); //currently mortal
PUTBACK; //don't check return count, assume its 1
call_pv(type == 'Q' ? "Math::Int64::native_to_uint64":
"Math::Int64::native_to_int64", G_SCALAR);
SPAGAIN;
unpackedParamSV = POPs; //this is also mortal
LEAVE;
}
else{//pass through the 8 byte packed string
unpackedParamSV = packedParamSV;
}
}
#endif
SvREFCNT_inc_simple_NN(unpackedParamSV);//cancel the mortal
HAVEUNPACKED: //used by 'p'/'P' for returning undef or a SVPV
av_push(retarr, unpackedParamSV);
}
mPUSHs(newRV_inc((SV*)retarr)); //cancel the mortal, no X needed, 2 in params
#if IVSIZE == 4
#undef MK_PARAM_OP_8B
#undef MK_PARAM_OP_32BIT_QUAD
#endif
MODULE = Win32::API::Callback PACKAGE = Win32::API::Callback::HeapBlock
void
new(classSV, size)
SV * classSV
UV size
PREINIT:
SV * newSVUVVar;
char * block;
#if defined(USE_ITHREADS)
MAGIC * mg;
int alignRemainder;
#endif
PPCODE:
//Code here to make a inter thread refcount to deal with ithreads cloning
//to prevent a double free
#if defined(USE_ITHREADS)
alignRemainder = (size % sizeof(LONG)); //4%4 = 0, we are aligned
size += sizeof(LONG) + (alignRemainder ? sizeof(LONG)-alignRemainder : 0);
#endif
block = HeapAlloc(execHeap, 0, size);
newSVUVVar = newSVuv((UV)block);
#if defined(USE_ITHREADS)
mg = sv_magicext(newSVUVVar, NULL, PERL_MAGIC_ext,&vtbl_HeapBlock,NULL,0);
mg->mg_flags |= MGf_DUP;
mg->mg_ptr = block+size-sizeof(LONG);
*((LONG *)mg->mg_ptr) = 1; //initial reference count
#endif
mXPUSHs(sv_bless(newRV_noinc(newSVUVVar),
gv_stashsv(classSV,0)
)
);
void
DESTROY( ptr_obj )
SV * ptr_obj
PREINIT:
SV * SVUVVar;
#if defined(USE_ITHREADS)
LONG refcnt;
MAGIC * mg;
#endif
PPCODE:
//Code here to make a inter thread refcount to deal with ithreads cloning
//to prevent a double free
SVUVVar = SvRV(ptr_obj);
#if defined(USE_ITHREADS)
mg = mg_findext(SVUVVar, PERL_MAGIC_ext,&vtbl_HeapBlock);
refcnt = InterlockedDecrement((LONG *) mg->mg_ptr);
if(refcnt == 0 ){ //if -1 or -2, means another thread will free it
#endif
HeapFree(execHeap, 0, (LPVOID)SvUV(SVUVVar));
#if defined(USE_ITHREADS)
}
#endif
MODULE = Win32::API::Callback PACKAGE = Win32::API::Callback::IATPatch
void
new(classSV, callback, HookDll, ImportDllName, ImportFunctionName)
SV * classSV
W32AC_T * callback
SV * HookDll
SV * ImportDllName
SV * ImportFunctionName
PREINIT:
PIMAGE_DOS_HEADER dosHeader;
HV * returnHV;
void * oldFunction;
char * HookDllName;
PPCODE:
SvGETMAGIC(HookDll);
if(SvPOK(HookDll)){
HookDllName = SvPV_nomg_nolen(HookDll);
goto USE_GMH;
}
else if(SvIOK(HookDll)){
dosHeader = (PIMAGE_DOS_HEADER) SvIV_nomg(HookDll);
if(!dosHeader) goto BAD_USAGE;
}
else if(SvOK(HookDll)){ /*NVs RVs not valid*/
BAD_USAGE:
croak_xs_usage(cv, "classSV, callback, HookDll, ImportDllName, ImportFunctionName");
}
else{ /* undef means patch the .exe that created the process*/
HookDllName = NULL;
USE_GMH:
dosHeader = (PIMAGE_DOS_HEADER) GetModuleHandle(HookDllName);
if(!dosHeader) goto ERROR;
}
if(!PatchIAT(aTHX_ dosHeader, ImportDllName, ImportFunctionName,
&oldFunction, (void *)SvUVX(*hv_fetch(callback, "code", sizeof("code")-1, 0)))){
ERROR:
PUSHs(&PL_sv_undef);
PUTBACK;
return;
}
returnHV = newHV();
//save the hmod, not dll str name, other dlls with same name might have been
//loaded in the meantime/sxs/etc
hv_store(returnHV, "HookDllHmod", sizeof("HookDllHmod")-1,
newSVuv((UV)dosHeader), 0);
hv_store(returnHV, "OrigFunc", sizeof("OrigFunc")-1,
newSVuv((UV)oldFunction) , 0);
hv_store(returnHV, "ImportDllName", sizeof("ImportDllName")-1,
newSVsv(ImportDllName), 0);
hv_store(returnHV, "ImportFunctionName", sizeof("ImportFunctionName")-1,
newSVsv(ImportFunctionName), 0);
hv_store(returnHV, "callback", sizeof("callback")-1,
newRV_inc((SV*)callback), 0);
mPUSHs(sv_bless(newRV_noinc((SV*)returnHV),
gv_stashsv(classSV,0)
)
);
void
Unpatch(...)
PREINIT:
I32 flagvar = 1; /*no param default is to restore*/
SV * OrigFuncSV;
void * OrigFunc;
HV * self;
CODE:
if (items < 1 || items > 2)
croak_xs_usage(cv, "self [, flag=true]");
else if(items == 2){
flagvar = sv_true(POPs);
}
{SV * TmpRV = POPs;
if (SvROK(TmpRV) && sv_derived_from(TmpRV, "Win32::API::Callback::IATPatch")) {
self = (HV*)SvRV(TmpRV);
}
else
croak("%s: %s is not of type %s",
"Win32::API::Callback::IATPatch::Unpatch",
"self", "Win32::API::Callback::IATPatch");};
OrigFuncSV = *hv_fetch(self, "OrigFunc", sizeof("OrigFunc")-1, 0);
if(flagvar){
if(OrigFunc = (void *)SvUVX(OrigFuncSV)){
if(!PatchIAT(aTHX_
(PIMAGE_DOS_HEADER)SvUVX(*hv_fetch(self, "HookDllHmod", sizeof("HookDllHmod")-1, 0)),
*hv_fetch(self, "ImportDllName", sizeof("ImportDllName")-1, 0),
*hv_fetch(self, "ImportFunctionName", sizeof("ImportFunctionName")-1, 0),
NULL, OrigFunc /*we don't collect the patch func ptr and
compare it to $self->{'callback'}->{'code'}, to see if something else patched
after us maybe we should????*/
)){
goto FAILED;
}
else goto SUCCESS_LABEL;
}
else SetLastError(ERROR_NO_MORE_ITEMS);
}
else{ //flag is false, never restore original function
SUCCESS_LABEL:
sv_setuv(OrigFuncSV, 0);
PUSHs(&PL_sv_yes);
PUTBACK;
return;
}
FAILED:
PUSHs(&PL_sv_undef);
PUTBACK;
return;
void
DESTROY(self)
SV * self
PREINIT:
SV * retsv;
DWORD error;
PPCODE:
error = GetLastError(); //dont let DESTROY screw up a new
PUSHMARK(SP);
PUSHs(self);
PUSHs(&PL_sv_yes);
PUTBACK;
XS_Win32__API__Callback__IATPatch_Unpatch(aTHX_ cv); /*the cv is wrong with this hack*/
//call_pv("Win32::API::Callback::IATPatch::Unpatch", 0);
retsv = POPs;
if(!sv_true(retsv) /*ERROR_NO_MORE_ITEMS means it was already unpatched*/
&& GetLastError() != ERROR_NO_MORE_ITEMS){
croak("%s: Failed to unpatch DLL, error number %u ",
"Win32::API::Callback::IATPatch::DESTROY", GetLastError());
}
SetLastError(error);
# GetOriginalFunction is reserved for future
# GetOriginalFunction should return a fully working Win32::API obj that calls
# the original function, the prototype should be obtained automatically from the
# Win32::API::Callback obj
void
GetOriginalFunctionPtr(self)
W32ACIATP_T * self
PPCODE:
PUSHs(sv_mortalcopy(*hv_fetch(self, "OrigFunc", sizeof("OrigFunc")-1, 0)));
void
CLONE_SKIP(...)
PPCODE:
/* Prevent double unpatching from a fork. I dont think it makes sense to clone
IATPatches, there is only one DLL per process. You can't have 2 different
patches on it and have 2 different hooks expect to work based on the calling
psuedo process. Well you could have a aTHX based dispatcher that will look up
the correct weak ref ::Callback HV to use each time the PerlCallback() is
called, but that is s alot of work for little gain. Currently the HV * of
the ::Callback is hard coded into the ASM callback, and that HV * is interp
specific.
*/
PUSHs(&PL_sv_yes);