远程调用技术代码追踪(webservice)

marginwidth="0" marginheight="0" src="http://www.zealware.com/csdnblog336280.html" frameborder="0" width="336" scrolling="no" height="280">
 

最近阅读了SocketConn的源码和WebService 的源码,把追踪的过程写了下来,方便大家学习。毕竟这需要精力,时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持,特别是julian兄弟,不是他,我可能没耐心继续下去。如果有时间,大家可以继续完善。从socket和Websevice的底层实现细节,我们发现BORLAND的工程师们的构思和实现的过程。我觉得这对我们的学习应该是非常重要的。学会思考。学会读源码,学会分析。
希望和我交往的朋友可通过QQ或Email联系我。[email protected]
另见:《远程调用技术代码追踪(socket) 》
关注我的:《远程调用技术代码追踪(第三方控件) 》
 
 
 
远程调用技术内幕
有关WebService的相关的知识,我就不说了,我直接分析源码。有问题的地方请参考李维的书。
initialization
InvRegistry.RegisterInterface(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS', 'utf-8');
看过李维的分布式架构的应该都知道,WEB服务端对类和接口进行了注册,客户端这里也进行了注册。然后客户端把数据通过HTTP传输到服务器端,服务器端通过拆包,去到注册管理的类中寻找相应的接口,并创建一个相应的对象,把客户端的数据压进去,调用后,把数据再传回来。
在调用这句的时候,TinvokableClassRegistry类已经创建了,由于inquire_v1也引用了InvRegistry注册,所以在哪里被引用的时候已经被创建了。
function InvRegistry: TInvokableClassRegistry;
begin
 if not Assigned(InvRegistryV) then
    InitIR;
 Result := InvRegistryV;
end;
初次引用会调用InitIR方法。
procedure InitIR;
begin
 InvRegistryV := TInvokableClassRegistry.Create;
 RemTypeRegistryV := TRemotableClassRegistry.Create;
 RemClassRegistryV:= RemTypeRegistry;
 InitBuiltIns; //定们到这一句:
 InitXSTypes;
 InitMoreBuiltIns;
end;
 
先看InvRegistryV := TInvokableClassRegistry.Create;,这个类是用来注册,相应的接口及类,
并能够根据soap封包内容找到相应的接口及方法。
TRemotableClassRegistry        = TRemotableTypeRegistry;
所对应的是TremotableTypeRegistry, 这个类主要是对数据类型进行注册。
 
大致来了解一下这个类。
TInvokableClassRegistry = class(TInterfacedObject)
 private
    FLock: TRTLCriticalSection;
    FRegClasses: array of InvRegClassEntry;
FRegIntfs: array of InvRegIntfEntry;
这里可以看到,声明了两个动态数组。分别用来放接口注册,及类注册信息。
TCreateInstanceProc = procedure(out obj: TObject);
InvRegClassEntry = record
    ClassType: TClass;
    Proc: TCreateInstanceProc;
    URI: string;
 end;
它包含了webservice实现类的指针,以建立实现类的factory函数指针。
 
InvRegIntfEntry = record
    Name: string;                             { Native name of interface    }
    ExtName: Widestring;                      { PortTypeName                }
    UnitName: string;                         { Filename of interface       }
    GUID: TGUID;                              { GUID of interface           }
    Info: PTypeInfo;                          { Typeinfo of interface       }
    DefImpl: TClass;                          { Metaclass of implementation }
    Namespace: Widestring;                    { XML Namespace of type       }
    WSDLEncoding: WideString;                 { Encoding                    }
    Documentation: string;                    { Description of interface    }
    SOAPAction: string;                       { SOAPAction of interface     }
    ReturnParamNames: string;                 { Return Parameter names      }
    InvokeOptions: TIntfInvokeOptions;        { Invoke Options              }
    MethNameMap: array of ExtNameMapItem;             { Renamed methods     }
    MethParamNameMap: array of MethParamNameMapItem; { Renamed parameters }
    IntfHeaders: array of IntfHeaderItem;      { Headers                    }
    IntfExceptions: array of IntfExceptionItem;{ Exceptions                 }
    UDDIOperator: String;                      { UDDI Registry of this porttype }
    UDDIBindingKey: String;                    { UDDI Binding key           }
 end;
 
看到它里面有很多东西,接口名称,单元名,GUID等信息。
 
 procedure InitBuiltIns;
begin
 { DO NOT LOCALIZE }
 RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
对于处理结构型数据,需要进行 SOAP 封包类型的转换
开发人员在使用这种自定义数据类型前必须对其进行注册,分别是 RegisterXSClass RegisterXSInfo 。前一个方法是注册从 Tremotable 继承下来的类,后一个不需要是从 TremotablXS 继承下来的类。
 
InitBuiltIns;   
 InitXSTypes;
 InitMoreBuiltIns;
这三个函数类似,都是注册一些基本类型等。
看看到底怎么处理的,(这里注册一个BOOLEAN类型)
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
procedure TRemotableTypeRegistry.RegisterXSInfo(Info: PTypeInfo; const URI: WideString = '';
                                                const Name: WideString = '';
                                                const ExtName: WideString = ''); 
Index := GetEntry(Info, Found, Name);
 
    if Found then
      Exit;
    if AppNameSpacePrefix <> '' then
      AppURI := AppNameSpacePrefix + '-';
    if URI = '' then
    begin
      if Info.Kind = tkDynArray then
      begin
        UnitName := GetTypeData(Info).DynUnitName;
        URIMap[Index].URI := 'urn:' + AppURI + UnitName;
      end
      else if Info.Kind = tkEnumeration then
      begin
        UnitName := GetEnumUnitName(Info);
        URIMap[Index].URI := 'urn:' + AppURI + UnitName;
      end
      else if Info.Kind = tkClass then
        URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
      else
        URIMap[Index].URI := 'urn:' + AppURI;
    end
    else
      URIMap[Index].URI := URI;
    if Name <> '' then
      URIMap[Index].Name := Name
    else
    begin
      URIMap[Index].Name := Info.Name;
    end;
    URIMap[Index].ExtName := ExtName;
    URIMap[Index].Info := Info;
    if Info.Kind = tkClass then
      URIMap[Index].ClassType := GetTypeData(Info).ClassType;
 finally
    UnLock;
 end;
end;
 
看研究一下GetEntry函数,这里以后多次用到,发现这个函数是TremotableClassRegistry类的,说明实际的注册还是在TremotableClassRegistry这个类完成的。
 
function TRemotableClassRegistry.GetEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString): Integer;
begin
 Result := FindEntry(Info, Found, Name);
 if not Found then
    SetLength(URIMap, Result + 1);
end;
这个函数功能是搜索类型是否已注册,否则,动态数组加1,分配空间进行注册。
 
看看FindEntry (这里传进来的info是TypeInfo(System.Boolean), name: Boolean)
function TRemotableClassRegistry.FindEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString): Integer;
begin
 Result := 0;
 Found := False;
 while Result < Length(URIMap) do
 begin
    if (Info <> nil) and (URIMap[Result].Info = Info) then
    begin
      if (Name = '') or (URIMap[Result].Name = Name) then
      begin
        Found := True;
        Exit;
      end;
    end;
    Inc(Result);
 end;
end;
这个函数的功能是遍历整个动态数组TremRegEntry,利用TypeInfo信息和名字进行搜索,查看是否已进行注册。
 
看看URIMAP的定义:
URIMAP:    array of TRemRegEntry;
 TObjMultiOptions = (ocDefault, ocMultiRef, ocNoMultiRef);
 TRemRegEntry = record
    ClassType: TClass; //类信息
    Info: PtypeInfo;    // typeInfo信息(RTTL)
    URI: WideString;   //
    Name: WideString; //
    ExtName: WideString; //
    IsScalar: Boolean;    //
    MultiRefOpt: TObjMultiOptions; //
    SerializationOpt: TSerializationOptions;
    PropNameMap: array of ExtNameMapItem;             { Renamed properties }
 end;
继续RegisterXSInfo函数:
这是对动态数组的uri赋值:
if AppNameSpacePrefix <> '' then
      AppURI := AppNameSpacePrefix + '-';
    if URI = '' then
    begin
      if Info.Kind = tkDynArray then
      begin
        UnitName := GetTypeData(Info).DynUnitName;
        URIMap[Index].URI := 'urn:' + AppURI + UnitName;
      end
      else if Info.Kind = tkEnumeration then
      begin
        UnitName := GetEnumUnitName(Info);
        URIMap[Index].URI := 'urn:' + AppURI + UnitName;
      end
      else if Info.Kind = tkClass then
        URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
      else
        URIMap[Index].URI := 'urn:' + AppURI;
    end
    else
      URIMap[Index].URI := URI;
    if Name <> '' then
      URIMap[Index].Name := Name
    else
    begin
      URIMap[Index].Name := Info.Name;
end;
 
这句比较关键:
URIMap[Index].Info := Info;
把RTTL信息保存在URL动态数组中。
 
总结一下:一些基本类型,都是通过这种方式,把URI,及INFO信息保存在动态数组中的。
为什么要进行登记,因为WEBSERVICE中的数据类型要转换成DELPHI的PAS类型,用URI标记的XML文件,传输之后,根据这张对照表,就可以分配相应的空间。另外这些类型的注册信息是放在:TremRegEntry动态数组中的。和我们自己定义的接口及类是不同的。
FRegClasses: array of InvRegClassEntry;
 FRegIntfs: array of InvRegIntfEntry; 这是注册自己定义接口及类的动态数组。
 
再来分析:
InitBuiltIns函数中的:
RemClassRegistry.RegisterXSClass(TSOAPAttachment, XMLSchemaNamespace, 'base64Binary', '', False, ocNoMultiRef);
大致和基本类型差不多。
procedure TRemotableTypeRegistry.RegisterXSClass(AClass: TClass; const URI: WideString = '';
                                                 const Name: WideString = '';
                                                 const ExtName: WideString = '';
                                                 IsScalar: Boolean = False;
                                                 MultiRefOpt: TObjMultiOptions = ocDefault);
var
 Index: Integer;
 Found: Boolean;
 AppURI: WideString;
begin
 Lock;
 try
    Index := GetEntry(AClass.ClassInfo, Found, Name);
    if not Found then
    begin
      if AppNameSpacePrefix <> '' then
        AppURI := AppNameSpacePrefix + '-';
      if URI = '' then
        URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(AClass.ClassInfo).UnitName { do not localize }
      else
        URIMap[Index].URI := URI;
      if Name <> '' then
        URIMap[Index].Name := Name
      else
      begin
        URIMap[Index].Name := AClass.ClassName;
       end;
      URIMap[Index].ExtName := ExtName;
      URIMap[Index].ClassType := AClass;
      URIMap[Index].Info := AClass.ClassInfo;
      URIMap[Index].IsScalar := IsScalar;
      URIMap[Index].MultiRefOpt := MultiRefOpt;
    end;
 finally
    UnLock;
 end;
end;
 
 
前面都是说系统类型的注册。下面看看我们自己定义的接口,是如何注册的:
procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString;
                    const WSDLEncoding: InvString; const Doc: string; const ExtName: InvString);
 
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
        Exit;
 
Index := Length(FRegIntfs);
SetLength(FRegIntfs, Index + 1);
 
GetIntfMetaData(Info, IntfMD, True);
    FRegIntfs[Index].GUID := IntfMD.IID;
    FRegIntfs[Index].Info := Info;
    FRegIntfs[Index].Name := IntfMD.Name;
    FRegIntfs[Index].UnitName := IntfMD.UnitName;
    FRegIntfs[Index].Documentation := Doc;
    FRegIntfs[Index].ExtName := ExtName;
    FRegIntfs[Index].WSDLEncoding := WSDLEncoding;
 
    if AppNameSpacePrefix <> '' then
      URIApp := AppNameSpacePrefix + '-';
 
    { Auto-generate a namespace from the filename in which the interface was declared and
      the AppNameSpacePrefix }
    if Namespace = '' then
      FRegIntfs[Index].Namespace := 'urn:' + URIApp + IntfMD.UnitName + '-' + IntfMD.Name
    else
    begin
      FRegIntfs[Index].Namespace := Namespace;
      FRegIntfs[Index].InvokeOptions := FRegIntfs[Index].InvokeOptions + [ioHasNamespace];
    end;
 
    if FRegIntfs[Index].DefImpl = nil then
    begin
      { NOTE: First class that implements this interface wins!! }
      for I := 0 to Length(FRegClasses) - 1 do
      begin
 
        Table := FRegClasses[I].ClassType.GetInterfaceTable;
        if (Table = nil) then
        begin
          Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceTable;
        end;
        for J := 0 to Table.EntryCount - 1 do
        begin
          if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
          begin
            FRegIntfs[Index].DefImpl := FRegClasses[I].ClassType;
            Exit;
          end;
        end;
      end;
    end;
 finally
    Unlock;
 end;
end;
 
功能:
for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
        Exit;
遍历FRegIntfs: array of InvRegIntfEntry;数组,根据TypeInfo信息判断该接口是否已注册。
Index := Length(FRegIntfs);
SetLength(FRegIntfs, Index + 1);
新增一个数组元素。
GetIntfMetaData(Info, IntfMD, True);
//得到接口的RTTL信息,然后动态增加到注册的动态数组中。
    FRegIntfs[Index].GUID := IntfMD.IID;
    FRegIntfs[Index].Info := Info;
    FRegIntfs[Index].Name := IntfMD.Name;
    FRegIntfs[Index].UnitName := IntfMD.UnitName;
    FRegIntfs[Index].Documentation := Doc;
    FRegIntfs[Index].ExtName := ExtName;
FRegIntfs[Index].WSDLEncoding := WSDLEncoding;
 
DefImpl里存放的是classType信息:
if FRegIntfs[Index].DefImpl = nil then
    begin
      for I := 0 to Length(FRegClasses) - 1 do
      begin
 
        Table := FRegClasses[I].ClassType.GetInterfaceTable;
        if (Table = nil) then
        begin
          Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceTable;
        end;
        for J := 0 to Table.EntryCount - 1 do
        begin
          if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
          begin
            FRegIntfs[Index].DefImpl := FRegClasses[I].ClassType;
            Exit;
          end;
        end;
      end;
    end;
注意这里:
FRegClasses: array of InvRegClassEntry;
到注册类的动态数组中去搜寻接口的实现类是否注册,如果注册,便把实现类的指针拷贝到DefImpl数据字段。
 
顺便看一下类是怎么注册的:
procedure TInvokableClassRegistry.RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc);
var
 Index, I, J: Integer;
 Table: PInterfaceTable;
 
begin
 Lock;
 try
Table := AClass.GetInterfaceTable;
     。。。。。。
    Index := Length(FRegClasses);
    SetLength(FRegClasses, Index + 1);
    FRegClasses[Index].ClassType := AClass;
    FRegClasses[Index].Proc := CreateProc;
 
    for I := 0 to Table.EntryCount - 1 do
    begin
      for J := 0 to Length(FRegIntfs) - 1 do
        if IsEqualGUID(FRegIntfs[J].GUID, Table.Entries[I].IID) then
          if FRegIntfs[J].DefImpl = nil then
            FRegIntfs[J].DefImpl := AClass;
    end;
 finally
    UnLock;
 end;
end;
可以看到和注册接口非常相似。在调用上面方法时,会传入实现类的指针及factory函数指针,调用GetInterfaceTable判断是否实现接口。否则为NIL, 然后在FregClasses增加一元素,把值写入。最后再到FregIntfs是搜寻此实现类的接口是否已经注册。是的话,就把指针储存在FRegIntfs[J].DefImpl中。
继续:
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS#%operationName%');
 
procedure TInvokableClassRegistry.RegisterDefaultSOAPAction(Info: PTypeInfo; const DefSOAPAction: InvString);
var
 I: Integer;
begin
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
FRegIntfs[I].SOAPAction := DefSOAPAction; 
//值为:urn:MyFirstWSIntf-IMyFirstWS#%operationName
 
      FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasDefaultSOAPAction];
      Exit;
    end;
end;
 
设置接口的SOAPAction, 及InvokeOptions属性。
上面讲了用户接口及自定义类注册的实现。
 
看看这几句为何如此神奇,竟然可以实现对象的远程调用?
MyHTTPRIO := THTTPRIO.Create(nil);
MyHTTPRIO.URL :='http://localhost/soap/MyCGI.exe/soap/IMyFirstWS';
ShowMessage(( MyHTTPRIO As IMyFirstWS ).GetObj);
 
研究一下客户端代码:
constructor THTTPRIO.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 { Converter }
  FDomConverter := GetDefaultConverter;
 FConverter := FDomConverter as IOPConvert;
 { WebNode }
 FHTTPWebNode := GetDefaultWebNode;
 FWebNode := FHTTPWebNode as IWebNode;
end;
 
继续到父类中TRIO查看相应代码:
constructor TRIO.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FInterfaceBound := False;
 FContext := TInvContext.Create;
 
 FSOAPHeaders := TSOAPHeaders.Create(Self);
 FHeadersInbound := THeaderList.Create;
 FHeadersOutBound:= THeaderList.Create;
 FHeadersOutbound.OwnsObjects := False;
 (FSOAPHeaders as IHeadersSetter).SetHeadersInOut(FHeadersInbound, FHeadersOutBound);
end;
 
创建了TinvContext,这个对象是用来创建一个和服务器端一样的调用环境。
客户端的参数信息一个个的填入这个环境中。
创建一个TSOAPHeaders头对象。
 
回到
constructor THTTPRIO.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 { Converter }
 FDomConverter := GetDefaultConverter;
 FConverter := FDomConverter as IOPConvert;
 { WebNode }
 FHTTPWebNode := GetDefaultWebNode;
 FWebNode := FHTTPWebNode as IWebNode;
end;
 
function THTTPRIO.GetDefaultConverter: TOPToSoapDomConvert;
begin
 if (FDefaultConverter = nil) then
 begin
    FDefaultConverter := TOPToSoapDomConvert.Create(Self);
    FDefaultConverter.Name := 'Converter1';                 { do not localize }
    FDefaultConverter.SetSubComponent(True);
 end;
 Result := FDefaultConverter;
end;
而TOPToSoapDomConvert可以把Object Pascal的呼叫和參數自動轉換為SOAP封裝的格式資訊,再藉由THTTPReqResp傳送HTTP封包。
 
function THTTPRIO.GetDefaultWebNode: THTTPReqResp;
begin
 if (FDefaultWebNode = nil) then
 begin
    FDefaultWebNode := THTTPReqResp.Create(Self);
    FDefaultWebNode.Name := 'HTTPWebNode1';                { do not localize }
    FDefaultWebNode.SetSubComponent(True);
 end;
 Result := FDefaultWebNode;
end;
//用来传送HTTP的封包。
 
 
function THTTPRIO.GetDefaultConverter: TOPToSoapDomConvert;
begin
 if (FDefaultConverter = nil) then
 begin
    FDefaultConverter := TOPToSoapDomConvert.Create(Self);
    FDefaultConverter.Name := 'Converter1';                 { do not localize }
    FDefaultConverter.SetSubComponent(True);
 end;
 Result := FDefaultConverter;
end;
 
 
FHTTPWebNode := GetDefaultWebNode;

function THTTPRIO.GetDefaultWebNode: THTTPReqResp;
begin
 if (FDefaultWebNode = nil) then
 begin
    FDefaultWebNode := THTTPReqResp.Create(Self);
    FDefaultWebNode.Name := 'HTTPWebNode1';                { do not localize }
    FDefaultWebNode.SetSubComponent(True);
 end;
 Result := FDefaultWebNode;
end;
 
创建了一个THTTPReqResp,用于HTTP通信。
MyHTTPRIO.URL :='http://localhost/soap/MyCGI.exe/soap/IMyFirstWS';
procedure THTTPRIO.SetURL(Value: string);
begin
 if Assigned(FHTTPWebNode) then
 begin
    FHTTPWebNode.URL := Value;
    if Value <> '' then
    begin
      WSDLLocation := '';
      ClearDependentWSDLView;
    end;
 end;
end;
 
procedure THTTPReqResp.SetURL(const Value: string);
begin
 if Value <> '' then
    FUserSetURL := True
  else
    FUserSetURL := False;
 InitURL(Value);
 Connect(False);
end;
 
procedure THTTPReqResp.InitURL(const Value: string);
 
    InternetCrackUrl(P, 0, 0, URLComp);
    FURLScheme := URLComp.nScheme;
    FURLPort := URLComp.nPort;
    FURLHost := Copy(Value, URLComp.lpszHostName - P + 1, URLComp.dwHostNameLength);
 FURL := Value;
end;
设置THTTPReqResp的属性。和HTTP服务器通信。
 
procedure THTTPReqResp.Connect(Value: Boolean);
if Assigned(FInetConnect) then
      InternetCloseHandle(FInetConnect);
    FInetConnect := nil;
    if Assigned(FInetRoot) then
      InternetCloseHandle(FInetRoot);
    FInetRoot := nil;
FConnected := False;
Value 为FLASE。
 
 
ShowMessage(( MyHTTPRIO As IMyFirstWS ).GetObj);
利用AS转换成webservice的接口。用转换后的接口到客户端的InvRegInftEntry表格中搜寻WEBSERVICE服务接口,根据RTTL生成SOAP封包。
 
procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID);
先看这一句:CALL     DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface
 
function THTTPRIO.QueryInterface(const IID: TGUID; out Obj): HResult;
var
 UDDIOperator, UDDIBindingKey: string;
begin
 Result := inherited QueryInterface(IID, Obj);
 if Result = 0 then
 begin
    if IsEqualGUID(IID, FIID) then
    begin
      FHTTPWebNode.SoapAction := InvRegistry.GetActionURIOfIID(IID);
      if InvRegistry.GetUDDIInfo(IID, UDDIOperator, UDDIBindingKey) then
      begin
        FHTTPWebNode.UDDIOperator := UDDIOperator;
        FHTTPWebNode.UDDIBindingKey := UDDIBindingKey;
      end;
    end;
 end;
end;
 
Result := inherited QueryInterface(IID, Obj);//跟踪一下这一句:
这句比较重要,要重点分析。
这里创建了虚拟表格。
 
function TRIO.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
 Result := E_NOINTERFACE;
 { IInterface, IRIOAccess } //判断接口是不是IRIOAccess类型
 if IsEqualGUID(IID, IInterface) or IsEqualGUID(IID, IRIOAccess) then
 { ISOAPHeaders }//判断接口是不是ISOAPHeaders类型
 if IsEqualGUID(IID, ISOAPHeaders) then
    if GenVTable(IID) then
    begin
      Result := 0;
      FInterfaceBound := True;
      Pointer(Obj) := IntfTableP;
      InterlockedIncrement(FRefCount);
    end;
 
看看GenVTable函数:
function TRIO.GenVTable(const IID: TGUID): Boolean;
Info := InvRegistry.GetInterfaceTypeInfo(IID);
这个函数是去到TinvokableClassRegistry中搜寻该接口是否注册,注册过的接口则返回typeinfo信息赋给指针。
function TInvokableClassRegistry.GetInterfaceTypeInfo(const AGUID: TGUID): Pointer;
var
 I: Integer;
begin
 Result := nil;
 Lock;
 try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if IsEqualGUID(AGUID, FRegIntfs[I].GUID) then
      begin
        Result := FRegIntfs[I].Info;
        Exit;
      end;
    end;
 finally
    UnLock;
 end;
end;
 
继续:通过infotype得到RTTL信息。
 try
    GetIntfMetaData(Info, IntfMD, True);
 except
    HasRTTI := False;
    Exit;
 end;
 
{
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;}
 Crack.Fn := GenericStub;
 StubAddr := Crack.Ptr;
 地址指向函数TRIO.GenericStub函数。
Crack.Fn结构的指针指向
这段代码的意思是用C/stdcall等方式调用函数。
从左到右,从右到左压入堆栈。调整TRIO.IntfTable的指针,最后调用TRIO.Generic
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;
 
 
 Crack.Fn := ErrorEntry;
 ErrorStubAddr := Crack.Ptr;
 
//首先分配vtable空间,接口数加3, 因为有Iunknown接口。
 GetMem(IntfTable, (Length(IntfMD.MDA) + NumEntriesInIInterface) * 4);
 IntfTableP := @IntfTable;
 然后把地址赋给IntfTableP变量
 
 GetMem(IntfStubs, (Length( IntfMD.MDA) + NumEntriesInIInterface) * StubSize );
 分配存根接口空间。
 这是解释 
IntfTable: Pointer;              { Generated vtable for the object   }
    IntfTableP: Pointer;            { Pointer to the generated vtable   }
    IntfStubs: Pointer;             { Pointer to generated vtable thunks}
 
//Load the IUnknown vtable 分配指针,加入三个接口Iunknown
 VTable := PPointer(IntfTable);
 Crack.QIFn := _QIFromIntf;
 QI查询指针赋值给 Crack结构体
 VTable^ := Crack.Ptr; 赋给VT指针
 IncPtr(VTable, 4);     增加一个指针。
 
 Crack.ObjFn := _AddRefFromIntf;
 VTable^ := Crack.Ptr;
 IncPtr(VTable, 4);
 Crack.ObjFn := _ReleaseFromIntf;
 VTable^ := Crack.Ptr;
 IncPtr(VTable, 4);
 
 
 
 VTable := AddPtr(IntfTable, NumEntriesInIInterface * 4);
//增加IunKnown指针的三个方法。压入IntfTable中。
 Thunk := AddPtr(IntfStubs, NumEntriesInIInterface * StubSize);
 //调整Thunk,加入IunKnown接口方法。
 
//遍历所有方法:产生机器相应的汇编机器代码。
 for I := NumEntriesInIInterface to Length(IntfMD.MDA) - 1 do
 begin
    CallStubIdx := 0;
 
    if not IntfMD.MDA[I].HasRTTI then
    begin
      GenByte($FF); { FF15xxxxxxxx Call [mem]    }
      GenByte($15);
      Crack.Fn := ErrorEntry;
      GenDWORD(LongWord(@ErrorStubAddr));
    end else
    begin
      { PUSH the method ID }
      GenPushI(I); 
 
//定位这里:看看函数做了什么:
CallStub: array[0..StubSize-1] of Byte;
I=3。CallStubIdx=2
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;
登记函数调用信息, 数组增加一元素。
 
遍历接口信息,函数ID号压入堆栈中。
 
      { 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);
把返回值压入堆栈中。//把返回参数压入堆栈。
 
    接着把GenericStub压入堆栈中。
      { Generate the CALL [mem] to the generic stub }
      GenByte($FF); { FF15xxxxxxxx Call [mem] }
      GenByte($15);
GenDWORD(LongWord(@StubAddr));
 
这几句是生成汇编的代码。可以产生这样的调用:
ff15xxxxxx:地址: caa [mem]编号: //这里调用的。
//看看里面的内容是什么:
 
      { 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
       
        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;
 
//GenRET(BytesPushed); 分配函数参数空间。
    { 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;
Thunk的指针,指向汇编代码相应的调用信息:
 
    { 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;
增加Thunk指向存根相应调用信息:
 
    { Finally, put the new thunk entry into the vtable slot. }
    VTable^ := Thunk;
IncPtr(VTable, 4);
把thunk指针赋给vtable之后,压入堆栈。
IncPtr(Thunk, StubSize);
把存根相应调用信息压入堆栈。
 
然后继续下一个函数的相应操作。
 end;
end;
 
procedure IncPtr(var P; I: Integer = 1);
asm
        ADD     [EAX], EDX
end;
 
总结一下GenVTable函数,这个函数,根据注册的接口,生成了内存表格。
首先遍历整个动态数组,然后,得到接口的RTTL信息,随后把Tcracker结构内存入相应的调用信息。然后再分配两块内存,一块放接口信息,一块放存根调用信息,再把接口内存的指针赋给TRIO的IntfTableP变量。IntfStubs存放存根指针IntfTable指接口信息后,又加入了Iunknown的指针空间。最近遍历接口函数,把函数信息写入CallStub数组之后(生成机器代码),再填入堆栈之中。
继续:
THTTPRIO.QueryInterface
TInvokableClassRegistry.GetActionURIOfInfo
if InvRegistry.GetUDDIInfo(IID, UDDIOperator, UDDIBindingKey) then
调用之后:
function TInvokableClassRegistry.GetUDDIInfo(const IntfInfo: PTypeInfo; var Operator, BindingKey: string): Boolean;
 
返回
procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID);
这里,继续:
procedure TRIO.GenericStub;
JMP      TRIO.Generic
 
 
 
//这里是最重要的地方:这个函数完成了。打包,传递,并返回服务器端结果。我们仔细研究一下。
 
function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;
。。。。
MethMD := IntfMD.MDA[CallID]; //得到方法相应的属性。
FContext.SetMethodInfo(MethMD); // FContext 产生虚拟的表函数表格。
 
procedure TInvContext.SetMethodInfo(const MD: TIntfMethEntry);
begin
 SetLength(DataP, MD.ParamCount + 1);
 SetLength(Data, (MD.ParamCount + 1) * MAXINLINESIZE);
end;
 
if MethMd.CC <> ccSafeCall then
 begin
    if RetOnStack(MethMD.ResultInfo) then
    begin
      RetP := Pointer(PInteger(P)^);
      if MethMD.ResultInfo.Kind = tkVariant then
        IncPtr(P, sizeof(Pointer))
      else
        IncPtr(P, GetStackTypeSize(MethMD.ResultInfo, MethMD.CC));
      if MethMD.CC in [ccCdecl, ccStdCall] then
      begin
        IncPtr(P, sizeof(Pointer));   { Step over self }
      end;
    end else
      RetP := @Result;
    FContext.SetResultPointer(RetP);
 end;
//把相应的返回信息压入Fcontext中。
 
for J := 0 to MethMD.ParamCount - 1 do
 begin
    FContext.SetParamPointer(ParamIdx, P);
    with MethMD.Params[J] do
    begin
      if (Info.Kind = tkVariant) and
         (MethMD.CC in [ccCdecl, ccStdCall, ccSafeCall]) and
         not (pfVar in Flags) and
         not (pfOut in Flags) then
      begin
        IncPtr(P, sizeof(TVarData)); { NOTE: better would be to dword-align!! }
      end
      else if IsParamByRef(Flags, Info, MethMD.CC) then
        IncPtr(P, 4)
      else
        IncPtr(P, GetStackTypeSize(Info, MethMD.CC));
    end;
    Inc(ParamIdx, LeftRightOrder);
 end;
//把相应的参数压入Fcontext中。
//转换成XML封包,并写入流中,这里就是具体打包的地方:
大家看清楚了:
Req := FConverter.InvContextToMsg(IntfMD, MethNum, FContext, FHeadersOutBound);
现在来好好研究一下它是怎么转换成XML封包的。
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;
                                             Con: TInvContext; Headers: THeaderList): TStream;
 
MethMD := IntfMD.MDA[MethNum];
首先得到方法的动态信息。
XMLDoc := NewXMLDocument; 看看这句:
 
function TOPToSoapDomConvert.NewXMLDocument: IXMLDocument;
begin
 Result := XMLDoc.NewXMLDocument;
 Result.Options := Result.Options + [doNodeAutoIndent];
 Result.ParseOptions := Result.ParseOptions + [poPreserveWhiteSpace];
end;
 
function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;
begin
 Result := TXMLDocument.Create(nil);
 Result.Active := True;
 if Version <> '' then
    Result.Version := Version;
end;
创建了一个TXMLDocument对象用于读写XML。
 
procedure TXMLDocument.SetActive(const Value: Boolean);
begin
 。。。。
      CheckDOM;
      FDOMDocument := DOMImplementation.createDocument('', '', nil);
      try
        LoadData;
      except
        ReleaseDoc(False);
        raise;
      end;
      DoAfterOpen;
    end
    else
    begin
      DoBeforeClose;
      ReleaseDoc;
      DoAfterClose;
    end;
 end;
end;
 
procedure TXMLDocument.CheckDOM;
begin
 if not Assigned(FDOMImplementation) then
    if Assigned(FDOMVendor) then
      FDOMImplementation := FDOMVendor.DOMImplementation
    else
      FDOMImplementation := GetDOM(DefaultDOMVendor);
end;
在TXMLDocument内部使用了Abstract Factory模式
Abstract Factory 希望不用指定具体的类,但为了找到它们,在TXMLDocument是通过指定一个字符串,也就是我们点击DOMVendor时出现的哪几个字符串.
 
GetDOM函数如下:
Result := GetDOMVendor(VendorDesc).DOMImplementation;
 
//根据传递进去的名字,创建相应在的实例:
function GetDOMVendor(VendorDesc: string): TDOMVendor;
begin
 if VendorDesc = '' then
    VendorDesc := DefaultDOMVendor;
 if (VendorDesc = '') and (DOMVendorList.Count > 0) then
    Result := DOMVendorList[0]
 else
    Result := DOMVendorList.Find(VendorDesc);
 if not Assigned(Result) then
    raise Exception.CreateFmt(SNoMatchingDOMVendor, [VendorDesc]);
end;
 
最后取得一个IDOMImplementation,它有一个createDocument(….):IDOMDocument;函数,这个函数将返回一个IDOMDocument;接口让IXMLDoucment使用。
//由此可见,默认状态下是创建DOM,微软的XML解析器。
function DOMVendorList: TDOMVendorList;
begin
 if not Assigned(DOMVendors) then
    DOMVendors := TDOMVendorList.Create;
 Result := DOMVendors;
end;
function TDOMVendorList.GetVendors(Index: Integer): TDOMVendor;
begin
 Result := FVendors[Index];
end;
如果为空,就返回默认的。
function TMSDOMImplementationFactory.DOMImplementation: IDOMImplementation;
begin
 Result := TMSDOMImplementation.Create(nil);
end;
 
再返回到函数:
procedure TXMLDocument.SetActive(const Value: Boolean);
 
 FDOMDocument := DOMImplementation.createDocument('', '', nil);
继续:
function TMSDOMImplementation.createDocument(const namespaceURI,
 qualifiedName: DOMString; doctype: IDOMDocumentType): IDOMDocument;
begin
 Result := TMSDOMDocument.Create(MSXMLDOMDocumentCreate);
end;
 
在如果使用MSXML,接口对应的是TMSDOMDocument,TMSDOMDocument是实际上是调用MSXML技术,下面是调用MS COM的代码
 
function CreateDOMDocument: IXMLDOMDocument;
begin
 Result := TryObjectCreate([CLASS_DOMDocument40, CLASS_DOMDocument30,
    CLASS_DOMDocument26, msxml.CLASS_DOMDocument]) as IXMLDOMDocument;
 if not Assigned(Result) then
    raise DOMException.Create(SMSDOMNotInstalled);
end;
 
再返回到函数:
procedure TXMLDocument.SetActive(const Value: Boolean);
..
LoadData
 
//因为是新建的TXMLDocument,所以装内空数据,立即返回。
procedure TXMLDocument.LoadData;
const
 UnicodeEncodings: array[0..2] of string = ('UTF-16', 'UCS-2', 'UNICODE');
var
 Status: Boolean;
 ParseError: IDOMParseError;
 StringStream: TStringStream;
 Msg: string;
begin
 …
Status := True; { No load, just create empty doc. }
创建空的文档:
 
 if not Status then
 begin
    DocSource := xdsNone;
    ParseError := DOMDocument as IDOMParseError;
    with ParseError do
      Msg := Format('%s%s%s: %d%s%s', [Reason, SLineBreak, SLine,
        Line, SLineBreak, Copy(SrcText, 1, 40)]);
    raise EDOMParseError.Create(ParseError, Msg);
 end;
 SetModified(False);
end;
设置不能修改。因为空文档。
 
继续返回到
function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;
begin
 if Version <> '' then
    Result.Version := Version;
end;
procedure TXMLDocument.SetVersion(const Value: DOMString);
begin
 SetPrologValue(Value, xpVersion);
end;
procedure TXMLDocument.SetPrologValue(const Value: Variant;
….
    PrologNode := GetPrologNode;
    PrologAttrs := InternalSetPrologValue(PrologNode, Value, PrologItem);
    NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
    if Assigned(PrologNode) then
      Node.ChildNodes.ReplaceNode(PrologNode, NewPrologNode)
    else
      ChildNodes.Insert(0, NewPrologNode);
 end;
 
 
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
这句调用了:
function TXMLDocument.CreateNode(const NameOrData: DOMString;
 NodeType: TNodeType = ntElement; const AddlData: DOMString = ''): IXMLNode;
begin
 Result := TXMLNode.Create(CreateDOMNode(FDOMDocument, NameOrData,
    NodeType, AddlData), nil, Self);
end;
 
 
在返回到这个函数中:
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;
                                             Con: TInvContext; Headers: THeaderList): TStream;
BodyNode := Envelope.MakeBody(EnvNode);
 
if not (soLiteralParams in Options) then
 begin
    SoapMethNS := GetSoapNS(IntfMD);
    ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name)
 
;;;;;
 
//创建一个SOAP的body:
function TSoapEnvelope.MakeBody(ParentNode: IXMLNode): IXMLNode;
begin
   Result := ParentNode.AddChild(SSoapNameSpacePre + ':' + SSoapBody, SSoapNameSpace);
end;
 
 
SoapMethNS := GetSoapNS(IntfMD); 返回:'urn:MyFirstWSIntf-IMyFirstWS'
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
得到调用方法名。剩下的部分就是把参数打包。生成SOAP的源文件。然后写到内存流中。
 
 
再回到函数中:InvContextToMsg
 Result := TMemoryStream.Create();
 DOMToStream(XMLDoc, Result);
把内存块的数据,转化成XML。
具体的函数如下:
procedure TOPToSoapDomConvert.DOMToStream(const XMLDoc: IXMLDocument; Stream: TStream);
var
 XMLWString: WideString;
 StrStr: TStringStream;
begin
 
   if (FEncoding = '') or (soUTF8EncodeXML in Options) then
 begin
    XMLDoc.SaveToXML(XMLWString);
    StrStr := TStringStream.Create(UTF8Encode(XMLWString));
    try
      Stream.CopyFrom(StrStr, 0);
    finally
      StrStr.Free;
    end;
 end else
    XMLDoc.SaveToStream(Stream);
end;
我们跟踪之后StrStr的结果如下:
 
''#$D#$A''#$D#$A' '#$D#$A'     '#$D#$A'      3'#$D#$A'      4'#$D#$A'    '#$D#$A' '#$D#$A''#$D#$A
 
 
转化后继续调用Generic函数:
。。。。
FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);
 
if (BindingType = btMIME) then
begin
。。。
FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);
 
THTTPReqResp.BeforeExecute
。。。。。
MethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
FSoapAction := InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName, MethodIndex);
得到方法名和FsoapAction
FBindingType := btSOAP
 
DoBeforeExecute // TRIO.
if Assigned(FOnBeforeExecute) then
退出:
 
继续:
Resp := GetResponseStream(RespBindingType);
 
 
 
继续返回到TRIO.Generic函数中执行:
try
   FWebNode.Execute(Req, Resp);
比较重要的部分:
 
这个函数就是THTTPReqResp向IIS发出请求。并返回信息:
 
procedure THTTPReqResp.Execute(const Request: TStream; Response: TStream);
begin
 …
    Context := Send(Request);
    try
      try
        Receive(Context, Response);
        Exit;
      except
        on Ex: ESOAPHTTPException do
        begin
          Connect(False);
          if not CanRetry or not IsErrorStatusCode(Ex.StatusCode) then
            raise;
          { Trigger UDDI Lookup }
          LookUpUDDI := True;
          PrevError := Ex.Message;
        end;
        else
        begin
          Connect(False);
          raise;
        end;
      end;
    finally
      if Context <> 0 then
        InternetCloseHandle(Pointer(Context));
    end;
 end;
{$ENDIF}
end;
 
现在看看Send函数,看看到底如何发送数据给WEB服务器的。
function THTTPReqResp.Send(const ASrc: TStream): Integer;
var
 Request: HINTERNET;
 RetVal, Flags: DWord;
 P: Pointer;
 ActionHeader: string;
 ContentHeader: string;
 BuffSize, Len: Integer;
 INBuffer: INTERNET_BUFFERS;
 Buffer: TMemoryStream;
 StrStr: TStringStream;
begin
 { Connect }
 Connect(True);
 
 Flags := INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_NO_CACHE_WRITE;
 if FURLScheme = INTERNET_SCHEME_HTTPS then
 begin
    Flags := Flags or INTERNET_FLAG_SECURE;
    if (soIgnoreInvalidCerts in InvokeOptions) then
      Flags := Flags or (INTERNET_FLAG_IGNORE_CERT_CN_INVALID or
                         INTERNET_FLAG_IGNORE_CERT_DATE_INVALID);
 end;
 
 Request := nil;
 try
     Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,
                               nil, nil, Flags, 0{Integer(Self)});
    Check(not Assigned(Request));
 
    { Timeouts }
    if FConnectTimeout > 0 then
      Check(InternetSetOption(Request, INTERNET_OPTION_CONNECT_TIMEOUT, Pointer(@FConnectTimeout), SizeOf(FConnectTimeout)));
    if FSendTimeout > 0 then
      Check(InternetSetOption(Request, INTERNET_OPTION_SEND_TIMEOUT, Pointer(@FSendTimeout), SizeOf(FSendTimeout)));
    if FReceiveTimeout > 0 then
      Check(InternetSetOption(Request, INTERNET_OPTION_RECEIVE_TIMEOUT, Pointer(@FReceiveTimeout), SizeOf(FReceiveTimeout)));
 
    { Setup packet based on Content-Type/Binding }
    if FBindingType = btMIME then
    begin
      ContentHeader := Format(ContentHeaderMIME, [FMimeBoundary]);
      ContentHeader := Format(ContentTypeTemplate, [ContentHeader]);
      HttpAddRequestHeaders(Request, PChar(MIMEVersion), Length(MIMEVersion), HTTP_ADDREQ_FLAG_ADD);
 
      { SOAPAction header }
      { NOTE: It's not really clear whether this should be sent in the case
              of MIME Binding. Investigate interoperability ?? }
      if not (soNoSOAPActionHeader in FInvokeOptions) then
      begin
        ActionHeader:= GetSOAPActionHeader;
        HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
      end;
 
    end else { Assume btSOAP }
    begin
      { SOAPAction header }
      if not (soNoSOAPActionHeader in FInvokeOptions) then
      begin
        ActionHeader:= GetSOAPActionHeader;
        HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
      end;
 
      if UseUTF8InHeader then
        ContentHeader := Format(ContentTypeTemplate, [ContentTypeUTF8])
      else
        ContentHeader := Format(ContentTypeTemplate, [ContentTypeNoUTF8]);
    end;
 
    { Content-Type }
    HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
 
    { Before we pump data, see if user wants to handle something - like set Basic-Auth data?? }
    if Assigned(FOnBeforePost) then
      FOnBeforePost(Self, Request);
 
    ASrc.Position := 0;
    BuffSize := ASrc.Size;
    if BuffSize > FMaxSinglePostSize then
    begin
      Buffer := TMemoryStream.Create;
      try
        Buffer.SetSize(FMaxSinglePostSize);
 
        { Init Input Buffer }
        INBuffer.dwStructSize := SizeOf(INBuffer);
        INBuffer.Next := nil;
        INBuffer.lpcszHeader := nil;
        INBuffer.dwHeadersLength := 0;
        INBuffer.dwHeadersTotal := 0;
        INBuffer.lpvBuffer := nil;
        INBuffer.dwBufferLength := 0;
        INBuffer.dwBufferTotal := BuffSize;
        INBuffer.dwOffsetLow := 0;
        INBuffer.dwOffsetHigh := 0;
 
        { Start POST }
        Check(not HttpSendRequestEx(Request, @INBuffer, nil,
                                    HSR_INITIATE or HSR_SYNC, 0));
        try
          while True do
          begin
            { Calc length of data to send }
            Len := BuffSize - ASrc.Position;
            if Len > FMaxSinglePostSize then
              Len := FMaxSinglePostSize;
            { Bail out if zip.. }
            if Len = 0 then
              break;
            { Read data in buffer and write out}
            Len := ASrc.Read(Buffer.Memory^, Len);
            if Len = 0 then
              raise ESOAPHTTPException.Create(SInvalidHTTPRequest);
 
            Check(not InternetWriteFile(Request, @Buffer.Memory^, Len, RetVal));
 
            RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
              FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
              FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
            case RetVal of
              ERROR_SUCCESS: ;
              ERROR_CANCELLED: SysUtils.Abort;
              ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
            end;
 
            { Posting Data Event }
            if Assigned(FOnPostingData) then
              FOnPostingData(ASrc.Position, BuffSize);
          end;
        finally
          Check(not HttpEndRequest(Request, nil, 0, 0));
        end;
      finally
        Buffer.Free;
      end;
    end else
    begin
      StrStr := TStringStream.Create('');
      try
        StrStr.CopyFrom(ASrc, 0);
        while True do
        begin
          Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
          RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
            FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
            FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
          case RetVal of
            ERROR_SUCCESS: break;
            ERROR_CANCELLED: SysUtils.Abort;
            ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
          end;
        end;
      finally
        StrStr.Free;
      end;
    end;
 except
    if (Request <> nil) then
      InternetCloseHandle(Request);
    Connect(False);
    raise;
 end;
 Result := Integer(Request);
end;
 
 
 
function THTTPReqResp.Send(const ASrc: TStream): Integer;
先调用了:
procedure THTTPReqResp.Connect(Value: Boolean);
……
if InternetAttemptConnect(0) <> ERROR_SUCCESS then
      SysUtils.Abort;
这个函数可以说非常 简单,只是尝试计算机连接到网络。
 
FInetRoot := InternetOpen(PChar(FAgent), AccessType, PChar(FProxy), PChar(FProxyByPass), 0);
创建HINTERNET句柄,并初始化WinInet的API函数:
 
Check(not Assigned(FInetRoot));
    try
      FInetConnect := InternetConnect(FInetRoot, PChar(FURLHost), FURLPort, PChar(FUserName),
        PChar(FPassword), INTERNET_SERVICE_HTTP, 0, Cardinal(Self));
    //创建一个特定的会话:
      Check(not Assigned(FInetConnect));
      FConnected := True;
    except
      InternetCloseHandle(FInetRoot);
      FInetRoot := nil;
      raise;
    end;
这里已经创建了一个会话:
继续返回function THTTPReqResp.Send(const ASrc: TStream): Integer;函数之中:
。。。。
Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,
                               nil, nil, Flags, 0{Integer(Self)});
Check(not Assigned(Request));。
打开一个HTTP的请求。向WEB服务器提出请求:
。。
if not (soNoSOAPActionHeader in FInvokeOptions) then
      begin
        ActionHeader:= GetSOAPActionHeader;
        HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
。。。
为请求添加一个或多个标头。可以看到标点的信息为:
'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'
 
 
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息:
 
      StrStr := TStringStream.Create('');
      try
        StrStr.CopyFrom(ASrc, 0);
        while True do
        begin
          Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
建立到internet 的连接,并将请求发送到指定的站点。
这句执行完后的图如下(用工具跟踪的结果):
 
看看前面的soap生成的字符 StrStr的结果如下,发现后半部分是一样的。
 
继续
function THTTPReqResp.Execute(const Request: TStream): TStream;
Receive(Context, Response);
 
 
procedure THTTPReqResp.Receive(Context: Integer; Resp: TStream; IsGet: Boolean);
var
 Size, Downloaded, Status, Len, Index: DWord;
 S: string;
begin
 
 ..
//获取请求信息:
 HttpQueryInfo(Pointer(Context), HTTP_QUERY_CONTENT_TYPE, @FContentType[1], Size, Index);
 
 repeat
    Check(not InternetQueryDataAvailable(Pointer(Context), Size, 0, 0));
    if Size > 0 then
    begin
      SetLength(S, Size);
Check(not InternetReadFile(Pointer(Context), @S[1], Size, Downloaded));
//下载数据:
      Resp.Write(S[1], Size);
 
      { Receiving Data event }
      if Assigned(FOnReceivingData) then
        FOnReceivingData(Size, Downloaded)
    end;
 until Size = 0;
 
S的结果如下和刚才跟踪器里的是一模一样的:
''#$D#$A''#$D#$A' '#$D#$A'     '#$D#$A'      12'#$D#$A'    '#$D#$A' '#$D#$A''#$D#$A
 
最后关闭HTTP会话句柄:
 InternetCloseHandle(Pointer(Context));
 
在返回function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;函数中继续查看:
 
RespXML := Resp;
返回信息的内存流
FConverter.ProcessResponse(RespXML, IntfMD, MethMD, FContext, FHeadersInbound);
 
再次把SOAP封包转换成PASCEL调用:
procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;
                                              const IntfMD: TIntfMetaData;
                                              const MD: TIntfMethEntry;
                                              Context: TInvContext;
                                              Headers: THeaderList);
var
 XMLDoc: IXMLDocument;
begin
 XMLDoc := NewXMLDocument;
 XMLDoc.Encoding := FEncoding;
 Resp.Position := 0;
 XMLDoc.LoadFromStream(Resp);
 ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);
end;
 
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
                                              const IntfMD: TIntfMetaData;
                                              const MD: TIntfMethEntry;
                                              Context: TInvContext;
                                              Headers: THeaderList);
var
 ProcessSuccess(RespNode, IntfMD, MD, Context);
 
ProcessSuccess函数如下:
….
 for I := 0 to RespNode.childNodes.Count - 1 do
    begin
      Node := RespNode.childNodes[I];
      { Skip non-valid nodes }
      if Node.NodeType <> ntElement then
        continue;
   
// 处理返回值:
      if I = RetIndex then
      begin
        InvData := InvContext.GetResultPointer;
        ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
        ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
 
 
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
把SOAP的结果,写入返回区地址空间。
 
 
 
procedure TSOAPDomConv.ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;
 Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean;
 NumIndirect: Integer);
var
 TypeUri, TypeName: InvString;
 IsNull: Boolean;
 Obj: TObject;
 P: Pointer;
 I: Integer;
 ID: InvString;
begin
 Node := GetDataNode(RootNode, Node, ID);
 IsNull := NodeIsNull(Node);
 if TypeInfo.Kind = tkVariant then
 begin
    if NumIndirect > 1 then
      DataP := Pointer(PInteger(DataP)^);
    if IsNull then
    begin
      Variant(PVarData(DataP)^) := NULL;
    end else
      ConvertSoapToVariant(Node, DataP);
 end else
 if TypeInfo.Kind = tkDynArray then
 begin
    P := DataP;
    for I := 0 to NumIndirect - 2 do
      P := Pointer(PInteger(P)^);
    P := ConvertSoapToNativeArray(P, TypeInfo, RootNode, Node);
    if NumIndirect = 1 then
      PInteger(DataP)^ := Integer(P)
    else if NumIndirect = 2 then
    begin
      DataP := Pointer(PInteger(DataP)^);
      PInteger(DataP)^ := Integer(P);
    end;
 end else
 if TypeInfo.Kind = tkClass then
 begin
    Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
    if NumIndirect = 1 then
      PTObject(DataP)^ := Obj
    else if NumIndirect = 2 then
    begin
      DataP := Pointer(PInteger(DataP)^);
      PTObject(DataP)^ := Obj;
    end;
 end else
 begin
    if Translate then
    begin
      if NumIndirect > 1 then
        DataP := Pointer(PInteger(DataP)^);
      if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
        raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam, [node.nodeName]);
    end;
 end;
end;
 
作为整型数据,处理方式为:
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
 
function TTypeTranslator.CastSoapToNative(Info: PTypeInfo; const SoapData: WideString; NatData: Pointer; IsNull: Boolean): Boolean;
var
 ParamTypeData: PTypeData;
begin
 DecimalSeparator := '.';
 Result := True;
 if IsNull and (Info.Kind = tkVariant) then
 begin
    Variant(PVarData(NatData)^) := NULL;
    Exit;
 end;
 ParamTypeData := GetTypeData(Info);
 case Info^.Kind of
    tkInteger:
      case ParamTypeData^.OrdType of
        otSByte,
        otUByte:
          PByte(NatData)^ := StrToInt(Trim(SoapData));
        otSWord,
        otUWord:
          PSmallInt(NatData)^ := StrToInt(Trim(SoapData));
        otSLong,
        otULong:
          PInteger(NatData)^ := StrToInt(Trim(SoapData));
      end;
    tkFloat:
      case ParamTypeData^.FloatType of
        ftSingle:
          PSingle(NatData)^ := StrToFloatEx(Trim(SoapData));
        ftDouble:
        begin
          if Info = TypeInfo(TDateTime) then
            PDateTime(NatData)^ := XMLTimeToDateTime(Trim(SoapData))
          else
            PDouble(NatData)^ := StrToFloatEx(Trim(SoapData));
        end;
 
        ftComp:
          PComp(NatData)^ := StrToFloatEx(Trim(SoapData));
        ftCurr:
          PCurrency(NatData)^ := StrToFloatEx(Trim(SoapData));
        ftExtended:
          PExtended(NatData)^ := StrToFloatEx(Trim(SoapData));
      end;
    tkWString:
      PWideString(NatData)^ := SoapData;
    tkString:
      PShortString(NatData)^ := SoapData;
    tkLString:
      PString(NatData)^ := SoapData;
    tkChar:
      if SoapData <> '' then
        PChar(NatData)^ := Char(SoapData[1]);
    tkWChar:
      if SoapData <> '' then
        PWideChar(NatData)^ := WideChar(SoapData[1]);
    tkInt64:
      PInt64(NatData)^ := StrToInt64(Trim(SoapData));
 
    tkEnumeration:
      { NOTE: Here we assume enums to be byte-size; make sure (specially for C++)
              that enums have generated with the proper size }
      PByte(NatData)^ := GetEnumValueEx(Info, Trim(SoapData));
    tkClass:
      ;
    tkSet,
    tkMethod,
 
    tkArray,
    tkRecord,
    tkInterface,
 
    tkDynArray:
      raise ETypeTransException.CreateFmt(SUnexpectedDataType, [ KindNameArray[Info.Kind]] );
    tkVariant:
      CastSoapToVariant(Info, SoapData, NatData);
 end;
end;
 
PWideString(NatData)^ := SoapData;
通过把值赋给了相应的指针地址:
 
另外在看一下传对象时的情况:
Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
 
 
if Assigned(Obj) and LegalRef then
    begin
      if (NodeClass <> nil) and (NodeClass <> Obj.ClassType) then
        Obj := NodeClass.Create;
    end else
    begin
    if (NodeClass <> nil) and NodeClass.InheritsFrom(AClass) then
      Obj := TRemotableClass(NodeClass).Create
    else
      Obj := TRemotableClass(AClass).Create;
    end;
Result := Obj;
 
可以理解,经过双边注册过之后,才可以传递对象。
 
现在研究一下服务器端的代码:
先大概简单介绍一下WEB服务器应用程序的工作模式:
 这里的WEB服务器就是IIS。
 
也就是说WEB服务器会把客户的HTTP请求消息,传递给CGI程序。然后由CGI进行处理:
 
CGIApp单元中的:
procedure InitApplication;
begin
 Application := TCGIApplication.Create(nil);
end;
//创建一个CGI的应用程序
 
constructor TWebApplication.Create(AOwner: TComponent);
begin
 WebReq.WebRequestHandlerProc := WebRequestHandler;
 inherited Create(AOwner);
 
 Classes.ApplicationHandleException := HandleException;
 if IsLibrary then
 begin
    IsMultiThread := True;
    OldDllProc := DLLProc;
    DLLProc := DLLExitProc;
 end
 else
    AddExitProc(DoneVCLApplication);
end;
 
constructor TWebRequestHandler.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FCriticalSection := TCriticalSection.Create;
 FActiveWebModules := TList.Create;
 FInactiveWebModules := TList.Create;
 FWebModuleFactories := TWebModuleFactoryList.Create;
 FMaxConnections := 32;
 FCacheConnections := True;
end;
 
procedure TCGIApplication.Run;
var
 HTTPRequest: TCGIRequest;
 HTTPResponse: TCGIResponse;
begin
 inherited Run;
 if IsConsole then
 begin
    Rewrite(Output);
    Reset(Input);
 end;
 try
    HTTPRequest := NewRequest;
    try
      HTTPResponse := NewResponse(HTTPRequest);
      try
        HandleRequest(HTTPRequest, HTTPResponse);
      finally
        HTTPResponse.Free;
      end;
    finally
      HTTPRequest.Free;
    end;
 except
    HandleServerException(ExceptObject, FOutputFileName);
 end;
end;
HTTPResponse := NewResponse(HTTPRequest);
调用:
function TCGIApplication.GetFactory: TCGIFactory;
begin
 if not Assigned(FFactory) then
    FFactory := TCGIFactory.Create;
 Result := FFactory;
end;
 
 
function TCGIFactory.NewRequest: TCGIRequest;
    Result := TCGIRequest.Create   
。。。
end;
//创建TCGIRequest
HTTPResponse := NewResponse(HTTPRequest);
Result := TCGIResponse.Create(CGIRequest)
HandleRequest(HTTPRequest, HTTPResponse);调用
 
现在看看是怎么响应客户端的:
 
function TWebRequestHandler.HandleRequest(Request: TWebRequest;
 Response: TWebResponse): Boolean;
var
 I: Integer;
 WebModules: TWebModuleList;
 WebModule: TComponent;
 WebAppServices: IWebAppServices;
 GetWebAppServices: IGetWebAppServices;
begin
 Result := False;
 WebModules := ActivateWebModules;
继续:
function TWebRequestHandler.ActivateWebModules: TWebModuleList;
begin
………………
FWebModuleFactories.AddFactory(TDefaultWebModuleFactory.Create(WebModuleClass));
把TWebModule1加入工厂中,并创建TwebModuleList对象。
 
        if FWebModuleFactories.ItemCount > 0 then
        begin
          Result := TWebModuleList.Create(FWebModuleFactories);
………………..
 
继续:
 if Assigned(WebModules) then
 try
WebModules.AutoCreateModules;
 
procedure TWebModuleList.AutoCreateModules
….... AddModule(Factory.GetModule);
 
调用:TWebModule1.create并加入TwebModuleList中。
function TDefaultWebModuleFactory.GetModule: TComponent;
begin
 Result := FComponentClass.Create(nil);
end;
 
constructor TWebModule.Create(AOwner: TComponent);调用
constructor TCustomWebDispatcher.Create(AOwner: TComponent);
 
之后又创建了THTTPSoapDispatcher,创建是在Treader类中创建的,有兴趣的朋友就追踪一下吧,这里实在是太麻烦。我也追了很久才发现。就懒得贴上来了。内容太多。
继续创建了TWSDLHTMLPublish
 
在回到TWebRequestHandler.HandleRequest函数中:
。。。
Result := WebAppServices.HandleRequest;
 
最后调用了:
function TCustomWebDispatcher.HandleRequest(
 Request: TWebRequest; Response: TWebResponse): Boolean;
begin
 FRequest := Request;
 FResponse := Response;
 Result := DispatchAction(Request, Response);
end;
注意HandleRequest函数,这里是关键部分:
 
function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
 Response: TWebResponse): Boolean;
…………………
while not Result and (I < FDispatchList.Count) do
 begin
    if Supports(IInterface(FDispatchList.Items[I]), IWebDispatch, Dispatch) then
    begin
      Result := DispatchHandler(Self, Dispatch,
        Request, Response, False);
    end;
    Inc(I);
 end;
继续:
function DispatchHandler(Sender: TObject; Dispatch: IWebDispatch; Request: TWebRequest; Response: TWebResponse;
 DoDefault: Boolean): Boolean;
begin
 Result := False;
 if (Dispatch.Enabled and ((Dispatch.MethodType = mtAny) or
    (Dispatch.MethodType = Dispatch.MethodType)) and
    Dispatch.Mask.Matches(Request.InternalPathInfo)) then
 begin
    Result := Dispatch.DispatchRequest(Sender, Request, Response);
 end;
end;
 
 
http调用在到达服务器后,WebModule父类TCustomWebDispatcher
会对其进行分析,抽取参数等信息。然后在TCustomWebDispatcher.HandleRequest
方法中调用TCustomWebDispatcher.DispatchAction方法,将调用
根据其path info重定向到相应的处理方法去。而DispatchAction方法将
Action重定向到FDispatchList字段中所有的实现了IWebDispatch接口的组件。
而THTTPSoapDispatcher正是实现了IWebDispatch,其将在
TCustomWebDispatcher.InitModule方法中被自动检测到并加入FDispatchList字段
具体如下:
procedure TCustomWebDispatcher.InitModule(AModule: TComponent);
var
  I: Integer;
  Component: TComponent;
  DispatchIntf: IWebDispatch;
begin
  if AModule <> nil then
    for I := 0 to AModule.ComponentCount - 1 do
    begin
      Component := AModule.Components[I];
      if Supports(IInterface(Component), IWebDispatch, DispatchIntf) then
        FDispatchList.Add(Component);
    end;
end;
...
  THTTPSoapDispatcher = class(THTTPSoapDispatchNode, IWebDispatch)
 
因此 Web Service 程序的 http 请求处理实际上是由 THTTPSoapDispatcher 进行的。
 
 
我们接着看看THTTPSoapDispatcher.DispatchRequest方法中对SOAP
协议的处理,关键代码如下
function THTTPSoapDispatcher.DispatchRequest(Sender: TObject;
 Request: TWebRequest; Response: TWebResponse): Boolean;
var
…..
 http信息被封装在TwebRequest里:我们来看是怎么进行分析的:
 
SoapAction := Request.GetFieldByName(SHTTPSoapAction);
首先得到SOAPAction信息, 这个SOAPAction大家应该比较熟悉了,前面讲过,这里主要是根据相应信息调用方法:() 具体的内容例如:urn:MyFirstWSIntf-IMyFirstWS
….
 
        if SoapAction = '' then
          SoapAction := Request.GetFieldByName('HTTP_' + UpperCase(SHTTPSoapAction)); { do not localize }
CGI或者Apache的处理方式。如果不是SOAP请求,就默认HTTP请求。
 
记录请求的路径。
Path := Request.PathInfo;
XMLStream := TMemoryStream.Create; //把客户端的请求流化。
ReqStream := TWebRequestStream.Create(Request);
创建一个响应的流信息,以例把结果返回客户端
 
RStream := TMemoryStream.Create; 创建返回信息的流。
try
       FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
这句是最重要的:
它把HTTP的调用方法,委托给THTTPSoapPascalInvoker.DispatchSOAP来处理。
 
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
 
IHTTPSoapDispatch = interface
 ['{9E733EDC-7639-4DAF-96FF-BCF141F7D8F2}']
    procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
                           Response: TStream; var BindingType: TWebServiceBindingType);
 end;
父类实现的接口:
THTTPSoapDispatchNode = class(TComponent)
 private
    procedure SetSoapDispatcher(const Value: IHTTPSoapDispatch);
 protected
    FSoapDispatcher: IHTTPSoapDispatch;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
 public
    procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
      Response: TStream); virtual;
 published
    property Dispatcher: IHTTPSoapDispatch read FSoapDispatcher write SetSoapDispatcher;
 end;
 
也被THTTPSoapPascalInvoker实现。所以THTTPSoapDispatcher中的Dispatcher接口的实例其实是:THTTPSoapPascalInvoker
 
THTTPSoapPascalInvoker = class(TSoapPascalInvoker, IHTTPSoapDispatch)
 public
    procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
                           Response: TStream; var BindingType: TWebServiceBindingType); virtual;
 end;
 
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
相应于调用了:
 
procedure THTTPSoapPascalInvoker.DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
                                              Response: TStream; var BindingType: TWebServiceBindingType);
var
 IntfInfo: PTypeInfo;
 PascalBind: IHTTPSOAPToPasBind;
 InvClassType: TClass;
 ActionMeth: String;
  MD: TIntfMetaData;
 
if not PascalBind.BindToPascalByPath(Path, InvClassType, IntfInfo, ActionMeth) or (InvClassType = nil) then
调用:
function THTTPSOAPToPasBind.BindToPascalByPath(Path: String;
 var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: String): Boolean;
begin
 Result := InvRegistry.GetInfoForURI(Path, '', AClass, IntfInfo, AMeth);
end;
由InvRegistry的注册信息,返回相应的类名,接口信息等信息。
这了这些准备信息,下步才是真正的调用。
Invoke(InvClassType, IntfInfo, ActionMeth, Request, Response, BindingType);
函数最后一句:调用了父类:这里是真正工作的地方:
这里了仔细认真研究一下:
 
procedure TSoapPascalInvoker.Invoke(AClass: TClass; IntfInfo: PTypeInfo; MethName: string; const Request: TStream;
                                     Response: TStream; var BindingType: TWebServiceBindingType);
var
 Inv: TInterfaceInvoker;
 Obj: TObject;
 InvContext: TInvContext;
 IntfMD: TIntfMetaData;
 MethNum: Integer;
 SOAPHeaders: ISOAPHeaders;
 Handled: Boolean;
begin
 try
 
GetIntfMetaData(IntfInfo, IntfMD, True); 得到接口RTTL信息;
InvContext := TInvContext.Create;    构造调用堆栈。
   { Convert XML to Invoke Context }
          FConverter.MsgToInvContext(Request, IntfMD, MethNum, InvContext, FHeadersIn);
这个函数请见前面的参考InvContextToMsg, 把TinvContext内容转化成XML封包。
 
这个函数是逆操作,把XML内容转化成Context。
 
 
 
try
Obj := InvRegistry.GetInvokableObjectFromClass(AClass);
搜寻注册信息,创建实例:
            if Obj = nil then
raise Exception.CreateFmt(SNoClassRegistered, [IntfMD.Name]);
……………..
Inv := TInterfaceInvoker.Create;
Inv.Invoke(Obj, IntfMD, MethNum, InvContext);
真正调用的地方:

源代码为:
这段代码,就是根据对象,接口信息等,把CONtext的信息压入相应参数,应调用。
有时间再仔细研究。
 
procedure TInterfaceInvoker.Invoke(const Obj: TObject;
      IntfMD: TIntfMetaData; const MethNum: Integer;
      const Context: TInvContext);
var
 MethPos: Integer;
 Unk: IUnknown;
 IntfEntry: PInterfaceEntry;
 IntfVTable: Pointer;
 RetIsOnStack, RetIsInFPU, RetInAXDX: Boolean;
 I: Integer;
 RetP : Pointer;
 MD : TIntfMethEntry;
 DataP: Pointer;
 Temp, Temp1: Integer;
 RetEAX: Integer;
 RetEDX: Integer;
 TotalParamBytes: Integer;
 ParamBytes: Integer;
begin
{$IFDEF LINUX}
 try
{$ENDIF}
 TotalParamBytes := 0;
 MD := IntfMD.MDA[MethNUm]; //得到方法的动态数组信息:
 if not Obj.GetInterface(IntfMD.IID, Unk) then
    raise Exception.CreateFmt(SNoInterfaceGUID,
      [Obj.ClassName, GUIDToString(IntfMD.IID)]);
 IntfEntry := Obj.GetInterfaceEntry(IntfMD.IID); //得到接口的动态数组信息
 IntfVTable := IntfEntry.VTable; //指向VTB表的指针
 MethPos := MD.Pos * 4; { Pos is absolute to whole VMT } //定位
 if MD.ResultInfo <> nil then
 begin
    RetIsInFPU := RetInFPU(MD.ResultInfo);
    RetIsOnStack := RetOnStack(MD.ResultInfo);
    RetInAXDX := IsRetInAXDX(MD.ResultInfo);
    RetP := Context.GetResultPointer;     //根据context  得到返回参数的地址。
 end else
 begin
    RetIsOnStack := False;
    RetIsInFPU := False;
    RetInAXDX := False;
 end;
 
 if MD.CC in [ccCDecl, ccStdCall, ccSafeCall] then
 begin
    if (MD.ResultInfo <> nil) and (MD.CC = ccSafeCall) then
      asm PUSH DWORD PTR [RetP] end;    //把函数返回参数压入堆栈中。
    for I := MD.ParamCount - 1 downto 0 do   //遍历参数。
    begin
      DataP := Context.GetParamPointer(I);    //指向一个参数地址:
      if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then {基本类型}
      asm
        PUSH DWORD PTR [DataP]       //压入堆栈。
      end
      else
      begin
        ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);    {特殊类型}
        PushStackParm(DataP, ParamBytes);
        Inc(TotalParamBytes, ParamBytes);
      end;
    end;
    asm PUSH DWORD PTR [Unk] end;         //压入Iunknown指针
    if RetIsOnStack and (MD.CC <> ccSafeCall) then
      asm PUSH DWORD PTR [RetP] end;
 end
 else if MD.CC = ccPascal then
 begin
    for I := 0 to MD.ParamCount - 1 do
    begin
      DataP := Context.GetParamPointer(I);
      if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then
      asm
         PUSH DWORD PTR [DataP]
      end
      else
      begin
//         PushStackParm(DataP, GetStackTypeSize(MD.Params[I].Info, MD.CC));
        ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);
        PushStackParm(DataP, ParamBytes);
        Inc(TotalParamBytes, ParamBytes);
      end;
    end;
    if RetIsOnStack then
      asm PUSH DWORD PTR [RetP] end;
    asm PUSH DWORD PTR [Unk] end;
 end else
     raise Exception.CreateFmt(SUnsupportedCC, [CallingConventionName[MD.CC]]);
 
 if MD.CC <> ccSafeCall then
 begin
    asm
      MOV DWORD PTR [Temp], EAX   //把EAX保存到临时变量中
      MOV DWORD PTR [Temp1], ECX //把ECX保存到临时变量中
 
      MOV EAX, MethPos     //函数定位的地方
      MOV ECX, [IntfVtable]   //虚拟表的入口
      MOV ECX, [ECX + EAX]   //真正调用的地址
      CALL ECX
      MOV DWORD PTR [RetEAX], EAX //把结果返回的信息保存在变量RetEAX(低位)
      MOV DWORD PTR [RetEDX], EDX //把结果返回的信息保存在变量RetEDX(高位)
      MOV EAX, DWORD PTR [Temp]    //恢复寄存器EAX
      MOV ECX, DWORD PTR [Temp1]   //恢复寄存器ECX
 
    end;
 end else
 begin
    asm
      MOV DWORD PTR [Temp], EAX
      MOV DWORD PTR [Temp1], ECX
      MOV EAX, MethPos
      MOV ECX, [IntfVtable]
      MOV ECX, [ECX + EAX]
      CALL ECX
      CALL System.@CheckAutoResult
      MOV DWORD PTR [RetEAX], EAX
      MOV DWORD PTR [RetEDX], EDX
      MOV EAX, DWORD PTR [Temp]
      MOV ECX, DWORD PTR [Temp1]
    end;
 end;
 
 if MD.CC = ccCDecl then /如果是CCDECL方式,必须自己清除使用的堆栈。
 asm
    MOV EAX, DWORD PTR [TotalParamBytes]
    ADD ESP, EAX
 end;
 
//调用后,返回参数的处理:
 if MD.ResultInfo <> nil then 
 begin
    if MD.CC <> ccSafeCall then //返回类型不为ccSafeCall时,必须进行处理。
    begin
      if RetIsInFPU then //tkFloat类型:
      begin
        GetFloatReturn(RetP, GetTypeData(MD.ResultInfo).FloatType);
      end else if not RetIsOnStack then 
      begin
        if RetInAXDX then //tkInt64整型64位类型处理:
        asm
            PUSH EAX
            PUSH ECX
            MOV EAX, DWORD PTR [RetP]
            MOV ECX, DWORD PTR [RetEAX]
            MOV [EAX], ECX
            MOV ECX, DWORD PTR [RetEDX]
            MOV [EAX + 4], ECX
            POP ECX
            POP EAX
        end
        else
        asm                     //堆栈类型:
            PUSH EAX                      //EAX入栈
            PUSH ECX                      //ECX入栈
            MOV EAX, DWORD PTR [RetP]    //返回地址MOV到EAX
            MOV ECX, DWORD PTR [RetEAX] // RetEAX中是调用后得到的值
            MOV [EAX], ECX        //把调用后的结果写入返回的地址中 
            POP ECX                        //ECX出栈
            POP EAX                        //EAX出栈 (先入后出)
 
        end;
      end;
    end;
 end;
{$IFDEF LINUX}
 except
    // This little bit of code is required to reset the stack back to a more
    // resonable state since the exception unwinder is completely unaware of
    // the stack pointer adjustments made in this function.
    asm
      MOV EAX, DWORD PTR [TotalParamBytes]
      ADD ESP, EAX
    end;
    raise;
 end;
{$ENDIF}
end;
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
返回调用后的内存块为。
Response.ContentStream := RStream;
然后再发送给客户端。
到这里,基本上客户端和服务器端都进行了分析。
 
 
 
 


你可能感兴趣的:(webservice,integer,function,internet,soap,constructor)