rio.pas

Delphi的Soap一些使用功能控件

{*******************************************************}
{                                                       }
{ Borland Delphi Visual Component Library               }
{                Interface Invoker Support              }
{                                                       }
{ Copyright (c) 2001-2005 Borland Software Corporation  }
{                                                       }
{*******************************************************}

unit Rio;

{$IFDEF NO_SOAP_RUNTIME}
{ If SOAP components are not packaged }
(*$HPPEMIT '#pragma link "dclsoap.lib"' *)
{$ENDIF}

{ RIO is currently implemented with WININET }
(*$HPPEMIT '#if defined(__WIN32__)'     *)
(*$HPPEMIT '#pragma link "wininet.lib"' *)
(*$HPPEMIT '#endif'                     *)

{$DEFINE ATTACHMENT_SUPPORT}


interface

uses Classes, IntfInfo, OPConvert, InvokeRegistry, WebNode, SOAPAttachIntf, WSDLIntf;

const
  StubSize = 19;    { Max size of call stubs in the generated vtables }

type

  TRIO = class;

  { This interface provides access back to the RIO
    from an interface that the RIO implements
    NOTE: It is *NOT* implemented at  the RIO level;
          therefore it cannot control the lifetime
          of the RIO;
          therefore you should not hang on to this interface
          as its underlying RIO could go away!
          Use the interface for quick RIO configuration
          when you still have the interface implemented
          by the RIO; then quickly "Let It Go!" }
  IRIOAccess = interface
  ['{FEF7C9CC-A477-40B7-ACBE-487EDA3E5DFE}']
    function GetRIO: TRIO;
    property RIO: TRIO read GetRIO;
  end;

  TBeforeExecuteEvent = procedure(const MethodName: string; var SOAPRequest: InvString) of object;
  TAfterExecuteEvent  = procedure(const MethodName: string; SOAPResponse: TStream) of object;

  TRIO = class(TComponent, IInterface, IRIOAccess)
  private
    FInterfaceBound: Boolean;
    FRefCount: Integer;
    IntfTable: Pointer;             { Generated vtable for the object   }
    IntfTableP: Pointer;            { Pointer to the generated vtable   }
    IntfStubs: Pointer;             { Pointer to generated vtable thunks}
    StubAddr: Pointer;
    ErrorStubAddr: Pointer;
    IntfReg: Boolean;
    LegalCC: Boolean;
    HasRTTI: Boolean;
    { Could make these into a local object to be used by  }
    { GenVTable.  It would save space. }
    CallStub: array[0..StubSize-1] of Byte;
    CallStubIdx: Integer;

    { Headers }
    FSOAPHeaders: TSOAPHeaders;
    FHeadersOutBound: THeaderList;
    FHeadersInbound: THeaderList;

    FContext: TInvContext;
    FOnAfterExecute: TAfterExecuteEvent;
    FOnBeforeExecute: TBeforeExecuteEvent;
    FOnSendAttachment: TOnSendAttachmentEvent;
    FOnGetAttachment: TOnGetAttachmentEvent;

    function  Generic(CallID: Integer; Params: Pointer): Int64;
    procedure GenericStub;

    procedure ErrorEntry;

    function  GenVTable(const IID: TGUID): Boolean;

    { Mini codegenerator assist functions.  Could be bundled with }
    { CallStub in a separate object.  Maybe for next release. }
    procedure GenPushI(I: Integer);
    procedure GenDWORD(DW: LongWord);
    procedure GenByte(B: Byte);
    procedure GenRET(BytesPushed: Word = 0);

    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    { Pseudo AddRef/Release/QI.  See the comment below }
    function _AddRefFromIntf: Integer; stdcall;
    function _ReleaseFromIntf: Integer; stdcall;
    function _QIFromIntf(const IID: TGUID; out Obj): HResult; stdcall;

    { IRIOAccess }
    function GetRIO: TRIO;

  protected
    FIID: TGUID;
    IntfMD: TIntfMetaData;
    FConverter: IOPConvert;
    FWebNode: IWebNode;
    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;

    { Routines that derived RIOs may override }
    procedure DoAfterExecute(const MethodName: string; Response: TStream); virtual;
    procedure DoBeforeExecute(const MethodName: string; Request: TStream); virtual;
    function  GetResponseStream(BindingType: TWebServiceBindingType): TStream; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
    property RefCount: Integer read FRefCount;
    property Converter: IOPConvert read FConverter write FConverter;
    property WebNode: IWebNode read FWebNode write FWebNode;
    property SOAPHeaders: TSOAPHeaders read FSOAPHeaders;
  published
    property OnAfterExecute: TAfterExecuteEvent read FOnAfterExecute write FOnAfterExecute;
    property OnBeforeExecute: TBeforeExecuteEvent read FOnBeforeExecute write FOnBeforeExecute;
    property OnSendAttachment: TOnSendAttachmentEvent read FOnSendAttachment write FOnSendAttachment;
    property OnGetAttachment: TOnGetAttachmentEvent read FOnGetAttachment write FOnGetAttachment;
  end;

implementation

uses {$IFDEF MSWINDOWS}Windows{$ENDIF}{$IFDEF LINUX}Libc{$ENDIF},
  SysUtils, XMLDoc, SOAPConst, InvRules, TypInfo, XMLIntf, WebServExp,
  SOAPAttach, PrivateHeap;


type
  TProc =  procedure of object;
  TObjFunc = function: Integer of Object;  stdcall;
  TQIFunc =  function(const IID: TGUID; out Obj): HResult of object; stdcall;
  PProc = ^TProc;
  TCracker = record
    case integer of
      0: (Fn: TProc);
      1: (Ptr: Pointer);
      2: (ObjFn: TObjFunc);
      3: (QIFn: TQIFunc);
    end;

  TTempFileStream = class(THandleStream)
  private
    FTempFile: string;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
  end;

{
  IncPtr

  Slower than doing it inline, but not much.  This function just
  bumps a pointer value by the number of bytes specified.  It modifies
  the pointer in place, so you can use it just like Inc.  Also makes
  the code much more readable.
}
procedure IncPtr(var P; I: Integer = 1);
asm
        ADD     [EAX], EDX
end;

{
  AddPtr

  Slower than doing it inline, but not much.  This function just
  bumps a pointer value by the number of bytes specified.  It does
  not modify the pointer in place like IncPtr.  You use this where
  you want to do the addition, and then assign the result to some
  other variable.  Use it to make the code more readable.
}
function AddPtr(P: Pointer; I: Integer = 1): Pointer;
asm
        ADD     EAX, EDX
end;


{ TTempFileStream }
constructor TTempFileStream.Create;
begin
{$IFDEF MSWINDOWS}
  FTempFile := GetTempDir + 'BorlandSoapMimeCache';
{$ENDIF}
{$IFDEF LINUX}
  FTempFile := GetTempDir + 'BorlandSoapMimeCacheXXXXXX';
{$ENDIF}
  inherited Create(GetTempHandle(FTempFile));
end;

destructor TTempFileStream.Destroy;
var
  Handle: Integer;
begin
  Handle := Self.Handle;
  inherited;
  FileClose(Handle);
  if FileExists(FTempFile) then
    DeleteFile(FTempFile);
end;


{
  TRIO.GenPushI

  Generates a PUSH immediate instruction to the call stub buffer.  If the
  immediate value fits in a byte, we encode it efficiently, otherwise
  we use the PUSH imm32 encoding.
}
procedure TRIO.GenPushI(I: Integer);
begin
  if I < 128 then
  begin
    CallStub[CallStubIdx] := $6A;
    CallStub[CallStubIdx + 1] := I;
    Inc(CallStubIdx, 2);
  end
  else
  begin
    CallStub[CallStubIdx] := $68;
    PInteger(@CallStub[CallStubIdx + 1])^ := I;
    Inc(CallStubIdx, 5);
  end;
end;

{
  TRIO.GenByte

  Generates a byte to the call stub buffer.
}
procedure TRIO.GenByte(B: Byte);
begin
  CallStub[CallStubIdx] := B;
  Inc(CallStubIdx);
end;

{
  TRIO.GenDWORD

  Generates a DWORD (4 bytes) to the call stub buffer.
}
procedure TRIO.GenDWORD(DW: LongWord);
begin
{$R-}
  CallStub[CallStubIdx] := DW;
{$R+}
  PLongWord(@CallStub[CallStubIdx])^ := DW;
  Inc(CallStubIdx, 4);
end;

{
  TRIO.GenRet

  Generates a return instruction to the call stub buffer .  If BytesPushed
  is 0, then we generate a one byte return.  Otherwise, we generate the
  3 byte encoding.
}
procedure TRIO.GenRET(BytesPushed: Word);
begin
  if BytesPushed > 0 then
  begin
    GenByte($C2);
    GenByte(Byte(BytesPushed and $FF));
    GenByte(Byte((BytesPushed and $FF00) shr 8));
  end
  else
    GenByte($C3);
end;

const
  NumEntriesInIInterface = 3; { QI, AddRef, Release }

function TRIO.GenVTable(const IID: TGUID): Boolean;
var
  Info: Pointer;
  I, J, BytesPushed: Integer;
  VTable: PPointer;
  Thunk: Pointer;
  P: PByte;
  Crack: TCracker;
begin
  { Assume success }
  Result := True;
  FIID := IID;

  Info := InvRegistry.GetInterfaceTypeInfo(IID);
  if Info = nil then
  begin
    Result := False;
    IntfReg := False;
    Exit;
  end else
    IntfReg := True;

  { Can we get RTTI for this interface? }
  try
    GetIntfMetaData(Info, IntfMD, True);
  except
    HasRTTI := False;
    Exit;
  end;
  HasRTTI := True;

  { Check to make sure that we don't have a bad calling convention in here. }
  { TODO: Should we check for unsupported types, parameter qualifiers
          ( i.e. do we support untyped params ? ),
          Also, what is checked here and what is checked in the IOPConvert methods ? }
  LegalCC := True;
  for I := 0 to Length(IntfMD.MDA) -1 do
  begin
    if IntfMD.MDA[I].HasRTTI then
      with IntfMD.MDA[I]  do
        if CC in [ccReg {, ccSafeCall} ] then
        begin
          Result := False;
          LegalCC := False;
          Exit;
        end;
  end;

  Crack.Fn := GenericStub;
  StubAddr := Crack.Ptr;

  Crack.Fn := ErrorEntry;
  ErrorStubAddr := Crack.Ptr;

  { Allocate two blocks - one for the vtable itself, one for }
  { the thunks. }

  GetMem(IntfTable, (Length(IntfMD.MDA) + NumEntriesInIInterface) * 4);
  IntfTableP := @IntfTable;
  // Stubs need to be allocated specially so we can set exectue permission on the memory block
  CodeHeap.GetMem(IntfStubs, (Length(IntfMD.MDA) + NumEntriesInIInterface) * StubSize );

  { Load the IUnknown vtable entries }
  VTable := PPointer(IntfTable);
  Crack.QIFn := _QIFromIntf;
  VTable^ := Crack.Ptr;