最近阅读了SocketConn的源码和WebService 的源码,把追踪的过程写了下来,方便大家学习。毕竟这需要精力,时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持,特别是julian兄弟,不是他,我可能没耐心继续下去。如果有时间,大家可以继续完善。从socket和Websevice的底层实现细节,我们发现BORLAND的工程师们的构思和实现的过程。我觉得这对我们的学习应该是非常重要的。学会思考。学会读源码,学会分析。
function THTTPRIO.GetDefaultWebNode: THTTPReqResp;
希望和我交往的朋友可通过QQ或Email联系我。Wu_yanan2003@yahoo.com.cn
远程调用技术内幕
有关WebService的相关的知识,我就不说了,我直接分析源码。有问题的地方请参考李维的书。
initialization
看过李维的分布式架构的应该都知道,WEB服务端对类和接口进行了注册,客户端这里也进行了注册。然后客户端把数据通过HTTP传输到服务器端,服务器端通过拆包,去到注册管理的类中寻找相应的接口,并创建一个相应的对象,把客户端的数据压进去,调用后,把数据再传回来。
function InvRegistry: TInvokableClassRegistry;
begin
if not Assigned(InvRegistryV) then
InitIR;
Result := InvRegistryV;
end;
procedure InitIR;
begin
InvRegistryV := TInvokableClassRegistry.Create;
RemTypeRegistryV := TRemotableClassRegistry.Create;
RemClassRegistryV:= RemTypeRegistry;
InitBuiltIns; //定们到这一句:
InitXSTypes;
InitMoreBuiltIns;
end;
先看InvRegistryV := TInvokableClassRegistry.Create;,这个类是用来注册,相应的接口及类,
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 }
InvokeOptions: TIntfInvokeOptions; { Invoke Options }
MethNameMap: array of ExtNameMapItem; { Renamed methods }
IntfExceptions: array of IntfExceptionItem;{ Exceptions }
end;
看到它里面有很多东西,接口名称,单元名,GUID等信息。
procedure InitBuiltIns;
begin
{ DO NOT LOCALIZE }
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean),XMLSchemaNameSpace,'boolean');
对于处理结构型数据,需要进行
SOAP
封包类型的转换
开发人员在使用这种自定义数据类型前必须对其进行注册,分别是
RegisterXSClass
和
RegisterXSInfo
。前一个方法是注册从
Tremotable
继承下来的类,后一个不需要是从
TremotablXS
继承下来的类。
InitBuiltIns;
InitXSTypes;
InitMoreBuiltIns;
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean),'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
finally
UnLock;
end;
end;
function TRemotableClassRegistry.GetEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString): Integer;
begin
Result := FindEntry(Info,Name);
if not Found then
SetLength(URIMap,Result + 1);
end;
看看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;
看看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; //
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,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
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,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;
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
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;
顺便看一下类是怎么注册的:
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;
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';
研究一下客户端代码:
constructor THTTPRIO.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ Converter }
FDomConverter := GetDefaultConverter;
FConverter := FDomConverter as IOPConvert;
{ WebNode }
FHTTPWebNode := GetDefaultWebNode;
FWebNode := FHTTPWebNode as IWebNode;
end;
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;
end;
客户端的参数信息一个个的填入这个环境中。
创建一个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,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。
利用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
begin
Result := inherited QueryInterface(IID,Obj);
if Result = 0 then
begin
if IsEqualGUID(IID,FIID) then
begin
FHTTPWebNode.soapAction := InvRegistry.GetActionURIOfIID(IID);
begin
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);
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,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;
Crack.Fn结构的指针指向
从左到右,从右到左压入堆栈。调整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+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}
VTable := PPointer(IntfTable);
Crack.QIFn := _QIFromIntf;
QI查询指针赋值给 Crack结构体
VTable^ := Crack.Ptr; 赋给VT指针
Crack.ObjFn := _AddRefFromIntf;
VTable^ := Crack.Ptr;
IncPtr(VTable,4);
Crack.ObjFn := _ReleaseFromIntf;
VTable^ := Crack.Ptr;
IncPtr(VTable,4);
VTable := AddPtr(IntfTable,NumEntriesInIInterface * 4);
Thunk := AddPtr(IntfStubs,NumEntriesInIInterface * StubSize);
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
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;
{ 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);
把thunk指针赋给vtable之后,压入堆栈。
IncPtr(Thunk,StubSize);
把存根相应调用信息压入堆栈。
end;
end;
procedure IncPtr(var P; I: Integer = 1);
asm
ADD [EAX],EDX
end;
首先遍历整个动态数组,然后,得到接口的RTTL信息,随后把Tcracker结构内存入相应的调用信息。然后再分配两块内存,一块放接口信息,一块放存根调用信息,再把接口内存的指针赋给TRIO的IntfTableP变量。IntfStubs存放存根指针IntfTable指接口信息后,又加入了IunkNown的指针空间。最近遍历接口函数,把函数信息写入CallStub数组之后(生成机器代码),再填入堆栈之中。
继续:
THTTPRIO.QueryInterface
TInvokableClassRegistry.GetActionURIOfInfo
调用之后:
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;
。。。。
FContext.SetMethodInfo(MethMD); // FContext 产生虚拟的表函数表格。
procedure TInvContext.SetMethodInfo(const MD: TIntfMethEntry);
begin
SetLength(DataP,MD.ParamCount + 1);
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
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];
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模式
GetDOM函数如下:
//根据传递进去的名字,创建相应在的实例:
begin
if vendorDesc = '' then
Result := DOMvendorList[0]
else
if not Assigned(Result) then
end;
最后取得一个IDOMImplementation,它有一个createDocument(….):IDOMDocument;函数,这个函数将返回一个IDOMDocument;接口让IXMLDoucment使用。
//由此可见,默认状态下是创建DOM,微软的XML解析器。
begin
if not Assigned(DOMvendors) then
Result := DOMvendors;
end;
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;
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
Line,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',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);
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;
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info,MethMD.Name);
再回到函数中: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的结果如下:
'<?xml version="1.0"?>'#$D#$A'<SOAP-ENV:Envelope xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A' <SOAP-ENV:Body SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A'
<NS1:Getobj xmlns:NS1="urn:MyFirstWSIntf-IMyFirstWS">'#$D#$A' <a xsi:type="xsd:int">3</a>'#$D#$A' <b xsi:type="xsd:int">4</b>'#$D#$A' </NS1:Getobj>'#$D#$A' </SOAP-ENV:Body>'#$D#$A'</SOAP-ENV:Envelope>'#$D#$A
。。。。
FWebNode.BeforeExecute(IntfMD,MethMD,MethNum-3,nil);
if (BindingType = btMIME) then
begin
。。。
FWebNode.BeforeExecute(IntfMD,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,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,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,
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,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,@StrStr.DataString[1],Length(StrStr.DataString)));
RetVal := InternetErrorDlg(GetDesktopWindow(),
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;
这个函数可以说非常
简单,只是尝试计算机连接到网络。
创建HINTERNET句柄,并初始化WinInet的API函数:
Check(not Assigned(FInetRoot));
try
FInetConnect := InternetConnect(FInetRoot,PChar(FURLHost),FURLPort,PChar(FUserName),
PChar(FPassword),INTERNET_SERVICE_HTTP,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,
nil,0{Integer(Self)});
Check(not Assigned(Request));。
打开一个HTTP的请求。向WEB服务器提出请求:
。。
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request,HTTP_ADDREQ_FLAG_ADD);
end;
。。。
HttpAddRequestHeaders(Request,HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息:
StrStr := TStringStream.Create('');
try
StrStr.copyFrom(ASrc,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,Index: DWord;
S: string;
begin
..
//获取请求信息:
HttpQueryInfo(Pointer(Context),HTTP_QUERY_CONTENT_TYPE,@FContentType[1],Size,Index);
repeat
Check(not InternetQueryDataAvailable(Pointer(Context),0));
if Size > 0 then
begin
SetLength(S,Size);
Check(not InternetReadFile(Pointer(Context),@S[1],Downloaded));
//下载数据:
Resp.Write(S[1],Size);
{ Receiving Data event }
if Assigned(FOnReceivingData) then
FOnReceivingData(Size,Downloaded)
end;
until Size = 0;
S的结果如下和刚才跟踪器里的是一模一样的:
'<?xml version="1.0"?>'#$D#$A'<SOAP-ENV:Envelope xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A' <SOAP-ENV:Body SOAP-ENC:encodingStyle="http://schemas.xmlsoap.org/soap/envelope/">'#$D#$A'
<NS1:GetobjResponse xmlns:NS1="urn:MyFirstWSIntf-IMyFirstWS">'#$D#$A' <return xsi:type="xsd:string">12</return>'#$D#$A' </NS1:GetobjResponse>'#$D#$A' </SOAP-ENV:Body>'#$D#$A'</SOAP-ENV:Envelope>'#$D#$A
最后关闭HTTP会话句柄:
InternetCloseHandle(Pointer(Context));
RespXML := Resp;
返回信息的内存流
FConverter.ProcessResponse(RespXML,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,MD,Context,Headers);
end;
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
const IntfMD: TIntfMetaData;
const MD: TIntfMethEntry;
Context: TInvContext;
Headers: THeaderList);
var
ProcessSuccess(RespNode,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,InvContext,RespNode,Node,True,ByRef,1);
ConvertSoapToNativeData(InvData,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,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,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),IsNull) then
raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam,[node.nodeName]);
end;
end;
end;
作为整型数据,处理方式为:
if not TypeTranslator.CastSoapToNative(TypeInfo,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,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);
继续创建了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函数,这里是关键部分:
Response: TWebResponse): Boolean;
…………………
while not Result and (I < FdispatchList.Count) do
begin
begin
Request,Response,False);
end;
Inc(I);
end;
继续:
function dispatchHandler(Sender: TObject; dispatch: IWebdispatch; Request: TWebRequest; Response: TWebResponse;
DoDefault: Boolean): Boolean;
begin
Result := False;
dispatch.Mask.Matches(Request.InternalPathInfo)) then
begin
end;
end;
http调用在到达服务器后,WebModule父类TCustomWebdispatcher
会对其进行分析,抽取参数等信息。然后在TCustomWebdispatcher.HandleRequest
方法中调用TCustomWebdispatcher.dispatchAction方法,将调用
根据其path info重定向到相应的处理方法去。而dispatchAction方法将
Action重定向到FdispatchList字段中所有的实现了IWebdispatch接口的组件。
会对其进行分析,抽取参数等信息。然后在TCustomWebdispatcher.HandleRequest
方法中调用TCustomWebdispatcher.dispatchAction方法,将调用
根据其path info重定向到相应的处理方法去。而dispatchAction方法将
Action重定向到FdispatchList字段中所有的实现了IWebdispatch接口的组件。
而THTTPSoapdispatcher正是实现了IWebdispatch,其将在
TCustomWebdispatcher.InitModule方法中被自动检测到并加入FdispatchList字段
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),dispatchIntf) then
FdispatchList.Add(Component);
end;
end;
...
THTTPSoapdispatcher = class(THTTPSoapdispatchNode,IWebdispatch)
因此 Web Service 程序的 http 请求处理实际上是由 THTTPSoapdispatcher 进行的。
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),dispatchIntf) then
FdispatchList.Add(Component);
end;
end;
...
THTTPSoapdispatcher = class(THTTPSoapdispatchNode,IWebdispatch)
因此 Web Service 程序的 http 请求处理实际上是由 THTTPSoapdispatcher 进行的。
我们接着看看THTTPSoapdispatcher.dispatchRequest方法中对SOAP
协议的处理,关键代码如下
function THTTPSoapdispatcher.dispatchRequest(Sender: TObject;
协议的处理,关键代码如下
function THTTPSoapdispatcher.dispatchRequest(Sender: TObject;
Request: TWebRequest; Response: TWebResponse): Boolean;
var
…..
http信息被封装在TwebRequest里:我们来看是怎么进行分析的:
SoapAction := Request.GetFieldByName(SHTTPSoapAction);
….
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
这句是最重要的:
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
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
procedure dispatchSOAP(const Path,SoapAction: WideString; const Request: TStream;
Response: TStream); virtual;
published
end;
THTTPSoapPascalInvoker = class(TSoapPascalInvoker,IHTTPSoapdispatch)
public
procedure dispatchSOAP(const Path,SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType); virtual;
end;
相应于调用了:
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,AMeth);
end;
由InvRegistry的注册信息,返回相应的类名,接口信息等信息。
这了这些准备信息,下步才是真正的调用。
Invoke(InvClasstype,ActionMeth,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,True); 得到接口RTTL信息;
InvContext := TInvContext.Create; 构造调用堆栈。
{ Convert XML to Invoke Context }
FConverter.MsgToInvContext(Request,fheadersIn);
try
Obj := InvRegistry.GetInvokableObjectFromClass(AClass);
搜寻注册信息,创建实例:
if Obj = nil then
raise Exception.CreateFmt(SNoClassRegistered,[IntfMD.Name]);
……………..
Inv := TInterfaceInvoker.Create;
Inv.Invoke(Obj,InvContext);
源代码为:
有时间再仔细研究。
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,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
asm
PUSH DWORD PTR [DataP] //压入堆栈。
end
else
begin
PushStackParm(DataP,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);
asm
PUSH DWORD PTR [DataP]
end
else
begin
//
PushStackParm(DataP,GetStackTypeSize(MD.Params[I].Info,MD.CC));
PushStackParm(DataP,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;