如何挂钩 COM 接口？

Question

如何在 Delphi 中正确挂接 COM 接口？下面的代码应该可以工作，但是当我尝试调用原始函数时它崩溃了。

第一次机会异常为 $725E1C46。异常 class $C0000005，消息 'access violation at 0x725e1c46: write of address 0x725de532'。进程 Project.exe (6524)

unit ComHook;

interface

uses
    Winapi.Windows,
    Winapi.WinInet,
    ComObj,
    ComServ,
    ActiveX,
    UrlMon,
    MSHTML,
    SHDocVw,
    DDetours;

const
    CLSID_HttpProtocol: TGUID = '{79EAC9E2-BAF9-11CE-8C82-00AA004BA90B}';

type
  TInternetProtocol = record
    class function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;  static;
    class function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; static;
    class function LockRequest(dwOptions: DWORD): HResult;  static;
    class function UnlockRequest: HResult; static;
  end;

var
    FInternetProtocol: IInternetProtocol;
    FRead: function(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
    FSeek: function(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
    FLockRequest: function(dwOptions: DWORD): HResult;
    FUnlockRequest: function: HResult;

implementation

{ TInternetProtocol }

class function TInternetProtocol.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
begin
  Result := FRead(pv, cb, cbRead);
end;

class function TInternetProtocol.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
begin
  Result := FSeek(dlibMove, dwOrigin, libNewPosition);
end;

class function TInternetProtocol.LockRequest(dwOptions: DWORD): HResult;
begin
  Result := FLockRequest(dwOptions); // Crash!
end;

class function TInternetProtocol.UnlockRequest: HResult;
begin
  Result := FUnlockRequest;
end;

initialization
  CoCreateInstance(CLSID_HttpProtocol, nil, CLSCTX_INPROC_SERVER, IID_IInternetProtocol, FInternetProtocol);
  @FRead := InterceptCreate(FInternetProtocol, 7, @TInternetProtocol.Read);
  @FSeek := InterceptCreate(FInternetProtocol, 8, @TInternetProtocol.Seek);
  @FLockRequest := InterceptCreate(FInternetProtocol, 9, @TInternetProtocol.LockRequest);
  @FUnlockRequest := InterceptCreate(FInternetProtocol, 10, @TInternetProtocol.UnlockRequest);
end.


...

procedure TForm2.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('www.whosebug.com');
end;

Answer 1

我能看到的三个错误：

您错过了调用约定。这些方法应该都是stdcall.
您需要将实例指针作为每个方法的第一个参数。
您的索引有误。需要从零开始算起，占IInterface.

更改后您的代码应如下所示：

type
  TInternetProtocol = record
    class function Read(inst: Pointer; pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall; static;
    class function Seek(inst: Pointer; dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall; static;
    class function LockRequest(inst: Pointer; dwOptions: DWORD): HResult; stdcall; static;
    class function UnlockRequest(inst: Pointer): HResult; stdcall; static;
  end;

var
    FInternetProtocol: IInternetProtocol;
    FRead: function(inst: Pointer; pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
    FSeek: function(inst: Pointer; dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
    FLockRequest: function(inst: Pointer; dwOptions: DWORD): HResult; stdcall;
    FUnlockRequest: function(inst: Pointer): HResult; stdcall;

....

@FRead := InterceptCreate(FInternetProtocol, 9, @TInternetProtocol.Read);
@FSeek := InterceptCreate(FInternetProtocol, 10, @TInternetProtocol.Seek);
@FLockRequest := InterceptCreate(FInternetProtocol, 11, @TInternetProtocol.LockRequest);
@FUnlockRequest := InterceptCreate(FInternetProtocol, 12, @TInternetProtocol.UnlockRequest);

FWIW，最新版本的 Delphi Detours 库允许您通过名称挂接接口方法，这让生活变得更简单。

如何挂钩 COM 接口？

How to hook COM interfaces?

delphi

com

delphi-xe7