/* # Win32::API::Callback - Perl Win32 API Import Facility # # Original Author: Aldo Calpini # Rewrite Author: Daniel Dragan # Maintainer: Cosimo Streppone # # Other Credits: # Changes for gcc/cygwin by Reini Urban (code removed) # # $Id$ */ #define WIN32_LEAN_AND_MEAN #include #include #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);