rio.pas

Delphi的Soap一些使用功能控件

  IncPtr(VTable, 4);
  Crack.ObjFn := _AddRefFromIntf;
  VTable^ := Crack.Ptr;
  IncPtr(VTable, 4);
  Crack.ObjFn := _ReleaseFromIntf;
  VTable^ := Crack.Ptr;
  IncPtr(VTable, 4);

  { Skip over the IInterface entries }
  VTable := AddPtr(IntfTable, NumEntriesInIInterface * 4);

  Thunk := AddPtr(IntfStubs, NumEntriesInIInterface * StubSize);

  { Now walk all the interface entries, and generate vtable thunks }
  for I := NumEntriesInIInterface to Length(IntfMD.MDA) - 1 do
  begin
    { Reset the call stub buffer }
    CallStubIdx := 0;

    if not IntfMD.MDA[I].HasRTTI then
    begin
      { Generate the CALL [mem] to the error stub }
      GenByte($FF);  { FF15xxxxxxxx Call [mem]    }
      GenByte($15);
      Crack.Fn := ErrorEntry;
      GenDWORD(LongWord(@ErrorStubAddr));
    end else
    begin
      { PUSH the method ID }
      GenPushI(I);

      { PUSH the info about return value location }
      if RetOnStack(IntfMD.MDA[I].ResultInfo)  then
      begin
        if IntfMD.MDA[I].CC in [ccStdcall, ccCdecl] then
          GenPushI(2)
        else
          GenPushI(1);
      end
      else
        GenPushI(0);

      { Generate the CALL [mem] to the generic stub }
      GenByte($FF);  { FF15xxxxxxxx Call [mem] }
      GenByte($15);
      GenDWORD(LongWord(@StubAddr));

      { Generate the return sequence }
      if IntfMD.MDA[I].CC in [ccCdecl] then
      begin
        { For cdecl calling convention, the caller will do the cleanup, so  }
        { we convert to a regular ret. }
        GenRET;
      end
      else
      begin
        { For all other calling conventions, the callee is supposed to do cleanup.  }
        { Figure out how many bytes we pushed in parameters, and clean it all up.   }
        BytesPushed := 0;
        for J := 0 to IntfMD.MDA[I].ParamCount - 1 do
        begin
           if IsParamByRef(IntfMD.MDA[I].Params[J].Flags, IntfMD.MDA[I].Params[J].Info, IntfMD.MDA[I].CC) then
             Inc(BytesPushed, 4)
           else
             Inc(BytesPushed, GetStackTypeSize(IntfMD.MDA[I].Params[J].Info, IntfMD.MDA[I].CC ));
        end;
        Inc(BytesPushed, GetStackTypeSize(IntfMD.MDA[I].SelfInfo, IntfMD.MDA[I].CC ));
        { TODO: Investigate why not always 4 ?? }
        if RetOnStack(IntfMD.MDA[I].ResultInfo) or (IntfMD.MDA[I].CC = ccSafeCall) then
          Inc(BytesPushed, 4);

        if BytesPushed > 252 then
          raise Exception.CreateFmt(STooManyParameters, [IntfMD.MDA[I].Name]);

        GenRET(BytesPushed);
      end;
    end;
    { Copy as much of the stub that we initialized over to the  }
    { block of memory we allocated. }
    P := PByte(Thunk);
    for J := 0 to CallStubIdx - 1 do
    begin
      P^ := CallStub[J];
      IncPtr(P);
    end;

    { And then fill the remainder with INT 3 instructions for             }
    { cleanliness and safety.  If we do the allocated more smartly, we    }
    { can remove all the wasted space, except for maybe alignment.        }
    for J := CallStubIdx to StubSize - 1 do
    begin
      P^ := $CC;
      IncPtr(P);
    end;

    { Finally, put the new thunk entry into the vtable slot.  }
    VTable^ := Thunk;
    IncPtr(VTable, 4);
    IncPtr(Thunk, StubSize);
  end;
end;

constructor TRIO.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FInterfaceBound := False;
  FContext := TInvContext.Create;

  { Headers }
  FSOAPHeaders := TSOAPHeaders.Create(Self);
  FHeadersInbound := THeaderList.Create;
  FHeadersOutBound:= THeaderList.Create;
  { We don't own sent objects - just like we don't own
    TRemotable parameters sent to a Service -
    We will take ownership of headers received (returned by
    Service) unless Client removes them }
  FHeadersOutbound.OwnsObjects := False;
  (FSOAPHeaders as IHeadersSetter).SetHeadersInOut(FHeadersInbound, FHeadersOutBound);
end;

destructor TRIO.Destroy;
begin
  if IntfTable <> nil then
    FreeMem(IntfTable);
  if IntfStubs <> nil then
    CodeHeap.FreeMem(IntfStubs);
  if FContext <> nil then
    FContext.Free;
  FSOAPHeaders.Free;    
  FHeadersInbound.Free;
  FHeadersOutBound.Free;
  inherited;
end;

procedure TRIO.AfterConstruction;
begin
  { Release the constructor's implicit refcount }
  InterlockedDecrement(FRefCount);
end;

procedure TRIO.BeforeDestruction;
begin
  inherited;
{ TODO: Inform user of incorrect usage - object deleted before refCount reaches 0.
  if FRefCount <> 0 then
    raise Exception.Create(SInvalidPointer);
}
end;

{ Set an implicit refcount so that refcounting  }
{ during construction won't destroy the object. }
class function TRIO.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TRIO(Result).FRefCount := 1;
end;

{
  TRIO._AddRefFromIntf
  TRIO._ReleaseFromIntf

  This function, and TRIO._ReleaseFromIntf below, are both anomalies.  They will
  not participate in reference counting as you would normally expect of
  interfaced objects, because we prevent the normal interfaces from being
  acquired from this object in our implementation of QueryInterface.
  Whenever we enter these implementations of AddRef and Release, our
  interface pointers are not the normal interface pointers that have been
  properly adjusted by the compiler/RTL, but our generated interface
  pointers.  So we adjust these in our implementation to save space.
  The implication is that we cannot ever call these functions directly
  from our member functions, or from any derived members.  That's the
  reason that they're in the private section.
}
function TRIO._AddRefFromIntf: Integer; stdcall;
begin
  { Adjust the self pointer to point to the actual object, not  }
  { our little generated vtable slot. }
  Self := AddPtr(Self, -Integer(LongWord(@Self.IntfTable) - LongWord(Self)));
  Result := InterlockedIncrement(FRefCount);
end;

function TRIO._ReleaseFromIntf: Integer; stdcall;
begin
  { Adjust the self pointer to point to the actual object, not  }
  { our little generated vtable slot.                           }
  Self := AddPtr(Self, -Integer(LongWord(@Self.IntfTable) - LongWord(Self)));
  Result := InterlockedDecrement(FRefCount);
  if (Result = 0) and not (Owner is TComponent) then
    Destroy;
end;

function TRIO._QIFromIntf(const IID: TGUID; out Obj): HResult; stdcall;
begin
  { Adjust the self pointer to point to the actual object, not  }
  { our little generated vtable slot.                           }
  Self := AddPtr(Self, -Integer(LongWord(@Self.IntfTable) - LongWord(Self)));
  { Access to RIO interfaces }
  if IsEqualGUID(IID, IInterface) or
     IsEqualGUID(IID, IRIOAccess) or
     IsEqualGUID(IID, ISOAPHeaders) then
  begin
    Result := Self.QueryInterface(IID, Obj);
    Exit;
  end;

  if (Self.FInterfaceBound) and
     IsEqualGUID(Self.FIID, IID) then
  begin
    Result := Self.QueryInterface(IID, Obj);
    Exit;
  end;
      
  Result := E_NOINTERFACE;
end;

function TRIO.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := E_NOINTERFACE;

  { IInterface, IRIOAccess }
  if IsEqualGUID(IID, IInterface) or
     IsEqualGUID(IID, IRIOAccess) then
  begin
    if GetInterface(IID, Obj) then
      Result := 0;
    Exit;
  end;

  { ISOAPHeaders }
  if IsEqualGUID(IID, ISOAPHeaders) then
  begin
    if FSOAPHeaders.GetInterface(IID, Obj) then
      Result := 0;
    Exit;
  end;

  if FInterfaceBound then
  begin
    if IsEqualGuid(FIID, IID) then
    begin
      Result := 0;
      Pointer(Obj) := IntfTableP;
      InterlockedIncrement(FRefCount);
    end;
  end
  else
  begin
    if GenVTable(IID) then
    begin
      Result := 0;
      FInterfaceBound := True;
      Pointer(Obj) := IntfTableP;
      InterlockedIncrement(FRefCount);
    end;
  end;

  { We override the invoke options to handle document-literal style services}
  if (Result = 0) and (FConverter <> nil) then
  begin
    { Encode or passing document-style? }
    if ioDocument in InvRegistry.GetIntfInvokeOptions(IID) then
      FConverter.Options := FConverter.Options + [soDocument]
    else
      FConverter.Options := FConverter.Options - [soDocument];

    { And did we unwind or do we have literal parameters? }
    if ioLiteral in InvRegistry.GetIntfInvokeOptions(IID) then
      FConverter.Options := FConverter.Options + [soLiteralParams]
    else
      FConverter.Options := FConverter.Options - [soLiteralParams];
  end;
end;

function TRIO._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TRIO._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if (Result = 0) and not (Owner is TComponent) then
    Destroy;
end;

function TRIO.GetRIO: TRIO;
begin
  Result := Self;
end;

{ Assumes jmp to TRIO.Generic has register calling convention and
  the params are:
     eax: self (of a TRIO instance)
     edx: method # in interface
     ecx: address on stack of start of the params & return }
procedure TRIO.GenericStub;
asm
        POP     EAX  { Return address in runtime generated stub }
        POP     EDX  { Is there a pointer to return structure on stack and which CC is used?  }
        CMP     EDX, 2
        JZ      @@RETONSTACKRL
        CMP     EDX, 1
        JZ      @@RETONSTACKLR
        POP     EDX           { Method # pushed by stub  }
        PUSH    EAX           { Push back return address }
        LEA     ECX, [ESP+12] { Calc stack pointer to start of params }
        MOV     EAX, [ESP+8]  { Calc interface instance ptr }
        JMP     @@CONT
@@RETONSTACKLR:
        POP     EDX           { Method # pushed by stub   }
        PUSH    EAX           { Push back return address  }
        LEA     ECX, [ESP+12] { Calc stack pointer to start of params }
        MOV     EAX, [ESP+8]  { Calc interface instance ptr }
        JMP     @@CONT
@@RETONSTACKRL:
        POP     EDX           { Method # pushed by stub  }
        PUSH    EAX           { Push back return address }
        LEA     ECX, [ESP+8]  { Calc stack pointer to start of params }
        MOV     EAX, [ESP+12] { calc interface instance ptr }
@@CONT:
        SUB     EAX, OFFSET TRIO.IntfTable;  { Adjust intf pointer to object pointer }
        JMP     TRIO.Generic
end;

{
  LoadFloatReturn

  Handles the nuances of getting the various different sized floating
  point values from a buffer and onto the FPU for retrieval by the
  caller.
}
procedure LoadFloatReturn(RetP: Pointer; FloatType: TFloatType);
asm
        CMP     EDX, ftSingle
        JE      @@Single
        CMP     EDX, ftDouble
        JE      @@Double
        CMP     EDX, ftExtended
        JE      @@Extended
        CMP     EDX, ftCurr
        JE      @@Curr
        CMP     EDX, ftComp
        JE      @@Curr      { Same as Curr }
        { Should never get here!! }
@@Single:
        FLD     DWORD PTR [EAX]
        RET
@@Double:
        FLD     QWORD PTR [EAX]
        RET
@@Extended: