RtfLabel, Version 1.3b (alt)
Hinweis: dies ist nicht die neueste Version!
Datei: ThiscallWrapper.pas
{ ThiscallWrapper.pas Pascal unit to wrap stdcall around incoming (foreign) and outgoing (own) interfaces that use the MS Visual C++ `thiscall´ calling convention. Both functions below allow up to 207 virtual methods (including QueryInterface, AddRef and Release, which are handled in a special way). Version 1.3b - always find the most current version at http://flocke.vssd.de/prog/code/pascal/rtflabel/ Copyright (C) 2005, 2006, 2007 Volker Siebert <flocke@vssd.de> All rights reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. } unit ThiscallWrapper; {$RANGECHECKS OFF} {$TYPEDADDRESS OFF} {$LONGSTRINGS ON} {$EXTENDEDSYNTAX ON} {$I DelphiVersion.inc} interface uses SysUtils, Windows; { Use `QueryThiscallInterface´ instead of `QueryInterface´ or the `as´ operator to get an `stdcall´ proxy for a `thiscall´ interface. Example: Instead of Svc := Obj as ITextServices; simply use QueryThiscallInterface(Obj, IID_ITextServices, Svc); After that, just use the returned interface like the original one (using `stdcall´). Note: you should *NOT* pass such an interface back to a C/C++ function that expects it to be `thiscall´. You must use the original object for this instead. } function QueryThiscallInterface(const Intf: IUnknown; const IID: TGUID; out Obj): HRESULT; { Use `CreateThiscallInterface´ to build a proxy around an `stdcall´ interface created with Delphi and a foreign caller that expects a `thiscall´ interface. Example: Instead of Host := Obj as ITextHost; CreateTextServices(nil, Host, Unk); simply use CreateThiscallInterface(Obj, IID_ITextHost, Host); CreateTextServices(nil, Host, Unk); If `Obj´ itself is an independent interface, you can use it just like this and the final `Release´ on `Host´ will also do a `Release´ on `Obj´. If `Obj´ itself controls the `Host´ variable's lifetime, you should pass TRUE as additional parameter and use `FreeThiscallInterface´ to free `Host´. Otherwise setting `Host´ to NIL will cause `Obj´s destruction in its own destructor. } function CreateThiscallInterface(const Intf: IUnknown; const IID: TGUID; out Obj; Controlled: Boolean {= False}): HRESULT; procedure FreeThiscallInterface(var Intf); implementation {$IFNDEF DELPHI_6_UP} uses ActiveX; {$ENDIF} {------------------------------------------------------------} { Common things for both, incoming and outgoing interfaces } type // Classless types of IUnknown methods TInterfaceQuery = function(This: Pointer; const IID: TGUID; out Obj): HRESULT; stdcall; TInterfaceAddRef = function(This: Pointer): LongInt; stdcall; TInterfaceRelease = function(This: Pointer): LongInt; stdcall; // The base VMT for IUnknown PUnknownVMT = ^TUnknownVMT; TUnknownVMT = packed record // IUnknown interface (stdcall) QueryInterface: TInterfaceQuery; AddRef: TInterfaceAddRef; Release: TInterfaceRelease; end; // The base wrapper class we use for both wrappers PUnknownWrapper = ^TUnknownWrapper; TUnknownWrapper = packed record VMT: PUnknownVMT; // Virtual method table Intf: PUnknownWrapper; // Original interface pointer RefCount: LongInt; // Reference counter GUID: PGUID; // Pointer to GUID end; { Wrapper for `AddRef´: first call the original interface and additionally increment our own reference counter. } function Unk_AddRef(This: PUnknownWrapper): LongInt; stdcall; begin Result := InterlockedIncrement(This^.RefCount); end; { Wrapper for `QueryInterface´, just replaces `this´ and jumps to the original procedure. Note that this function will always return our own interface (AddRef'd) when asked for our own GUID. } function Unk_QueryInterface(This: PUnknownWrapper; const IID: TGUID; out Obj): HRESULT; stdcall; begin if IsEqualGUID(This^.GUID^, IID) then begin Unk_AddRef(This); Pointer(Obj) := This; Result := S_OK; end else begin { Note that interfaces returned by QueryInterface are automatically AddRef'fed, but since the foreign QueryInterface will never return our interface, we do not increment our reference counter in that case. } Result := This^.Intf^.VMT^.QueryInterface(This^.Intf, IID, Obj); end; end; { Wrapper for `Release´: first call the original interface and additionally decrement our own reference counter. If it becomes zero, free the whole structure } function Unk_Release(This: PUnknownWrapper): LongInt; stdcall; begin Result := InterlockedDecrement(This^.RefCount); if Result = 0 then begin This^.Intf^.VMT^.Release(This^.Intf); This^.Intf := nil; This^.VMT := nil; FreeMem(This); end; end; {------------------------------------------------------------} { Incoming (foreign) `thiscall´ interfaces. The following assembler code fragment is used to build a proxy between Delphi expecting an `stdcall´ interface and a foreign `thiscall´ interface. Each VMT index needs its own fragment with exactly the same offset in `Index´ as in the original VMT, but *ALL* such interfaces can share the same function for the same index. } type TCallingWrapper = packed record Before: packed array [0 .. 9] of Byte; Index: Integer; After: packed array [0 .. 1] of Byte; end; const CCallingWrapper: TCallingWrapper = ( Before: ( // Get `Self´ off the stack -> ECX $58, // 00: pop eax ; return address $59, // 01: pop ecx ; Self $50, // 02: push eax ; return address // Dereference This := Self^.Intf $8B,$49,$04, // 03: mov ecx, [ecx + 4] // Now call This^.VMT^.proc_XX(This) $8B,$01, // 06: mov eax, [ecx] $FF,$A0{,xx,xx,xx,xx} // 08: jmp [eax + *] ); Index: 0; After: ( $90,$90 // 0E: nop, nop ) ); const // 4096 Bytes -> 207 Entries (including the 3 base interfaces) CNumCallingMethods = 3 + (4096 - 12) div (SizeOf(TCallingWrapper) + 4); type PCallingWrapperVMT = ^TCallingWrapperVMT; TCallingWrapperVMT = packed record BaseVMT: array [0 .. 2] of Pointer; DynVMT: array [0 .. CNumCallingMethods - 4] of Pointer; Wraps: array [0 .. CNumCallingMethods - 4] of TCallingWrapper; end; var CallingWrapperVMT: PCallingWrapperVMT; function GetCallingWrapperVMT: PUnknownVMT; var p: PCallingWrapperVMT; k: Integer; begin if CallingWrapperVMT = nil then begin p := VirtualAlloc(nil, SizeOf(TCallingWrapperVMT), MEM_COMMIT, PAGE_EXECUTE_READWRITE); if p = nil then {$IFDEF DELPHI_6_UP} RaiseLastOSError; {$ELSE} RaiseLastWin32Error; {$ENDIF} p^.BaseVMT[0] := @Unk_QueryInterface; p^.BaseVMT[1] := @Unk_AddRef; p^.BaseVMT[2] := @Unk_Release; for k := 0 to CNumCallingMethods - 4 do begin p^.Wraps[k] := CCallingWrapper; p^.Wraps[k].Index := 4 * (k + 3); p^.DynVMT[k] := @p^.Wraps[k]; end; CallingWrapperVMT := p; end; Result := PUnknownVMT(CallingWrapperVMT); end; function QueryThiscallInterface(const Intf: IUnknown; const IID: TGUID; out Obj): HRESULT; var Res: PUnknownWrapper; begin Res := AllocMem(SizeOf(TUnknownWrapper)); Res^.VMT := GetCallingWrapperVMT; Result := Intf.QueryInterface(IID, Res^.Intf); if Result = S_OK then begin Res^.RefCount := 1; Res^.GUID := @IID; PUnknownWrapper(Obj) := Res; end else begin FreeMem(Res); Pointer(Obj) := nil; end; end; {------------------------------------------------------------} { Outgoing (own) `thiscall´ interfaces. The following assembler code fragment is used to build a proxy between a foreign caller expecting a `thiscall´ interface and an `stdcall´ interface built using Delphi. Each VMT index needs its own fragment with exactly the same offset in `Index´ as in the original VMT, but *ALL* such interfaces can share the same function for the same index. } type TCalledWrapper = packed record Before: packed array [0 .. 9] of Byte; Index: Integer; After: packed array [0 .. 1] of Byte; end; const CCalledWrapper: TCalledWrapper = ( Before: ( // Dereference Self := This^.Intf $8B,$49,$04, // 00: mov ecx, [ecx + 4] // Push `Self´ onto the stack $58, // 03: pop eax $51, // 04: push ecx $50, // 05: push eax // Now call Self^.VMT^.proc_XX(Self) $8B,$01, // 06: mov eax, [ecx] $FF,$A0{,xx,xx,xx,xx} // 08: jmp [eax + *] ); Index: 0; After: ( $90,$90 // 0C: nop, nop ) ); const // 4096 Bytes -> 207 Entries (including the 3 base interfaces) CNumCalledMethods = 3 + (4096 - 12) div (SizeOf(TCalledWrapper) + 4); type PCalledWrapperVMT = ^TCalledWrapperVMT; TCalledWrapperVMT = packed record BaseVMT: array [0 .. 2] of Pointer; DynVMT: array [0 .. CNumCalledMethods - 4] of Pointer; Wraps: array [0 .. CNumCalledMethods - 4] of TCalledWrapper; end; var CalledWrapperVMT: PCalledWrapperVMT; function GetCalledWrapperVMT: PUnknownVMT; var p: PCalledWrapperVMT; k: Integer; begin if CalledWrapperVMT = nil then begin p := VirtualAlloc(nil, SizeOf(TCalledWrapperVMT), MEM_COMMIT, PAGE_EXECUTE_READWRITE); if p = nil then {$IFDEF DELPHI_6_UP} RaiseLastOSError; {$ELSE} RaiseLastWin32Error; {$ENDIF} p^.BaseVMT[0] := @Unk_QueryInterface; p^.BaseVMT[1] := @Unk_AddRef; p^.BaseVMT[2] := @Unk_Release; for k := 0 to CNumCalledMethods - 4 do begin p^.Wraps[k] := CCalledWrapper; p^.Wraps[k].Index := 4 * (k + 3); p^.DynVMT[k] := @p^.Wraps[k]; end; CalledWrapperVMT := p; end; Result := PUnknownVMT(CalledWrapperVMT); end; function CreateThiscallInterface(const Intf: IUnknown; const IID: TGUID; out Obj; Controlled: Boolean): HRESULT; var Res: PUnknownWrapper; begin Res := AllocMem(SizeOf(TUnknownWrapper)); Res^.VMT := GetCalledWrapperVMT; Result := Intf.QueryInterface(IID, Res^.Intf); if Result = S_OK then begin Res^.RefCount := 1; Res^.GUID := @IID; if Controlled then begin Intf._Release; inc(Res^.RefCount); end; PUnknownWrapper(Obj) := Res; end else begin FreeMem(Res); Pointer(Obj) := nil; end; end; procedure FreeThiscallInterface(var Intf); begin if Pointer(Intf) <> nil then if PUnknownWrapper(Intf)^.Intf <> nil then begin PUnknownWrapper(Intf)^.Intf := nil; PUnknownWrapper(Intf)^.VMT := nil; FreeMem(Pointer(Intf)); Pointer(Intf) := nil; end; end; end. |