optosoapdomconv.pas

Delphi开发webservice的一套例子

procedure TSOAPDomConv.WriteVariant(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
var
  S, URI, TypeName: InvString;
  Info: PTypeInfo;
  AClass: TClass;
  IsScalar: Boolean;
  DT: TXSDateTime;
begin
  if VarIsArray(V) then
  begin
    if VarType(V) and varTypeMask = varByte then
    begin
      WriteVarArrayAsB64(RootNode, Node, Name, V);
    end
    else
    WriteVarArray(RootNode, Node, Name, V);
  end
  else
  begin
    if VarIsNull(V) or VarIsEmpty(V) then
       CreateNULLNode(RootNode,Node, Name)
    else
    begin
      Info :=  RemTypeRegistry.VariantToInfo(V, soTryAllSchema in Options);
      if Info = nil then
         raise ESOAPDomConvertError.Create(SUnsupportedVariant);
      RemTypeRegistry.InfoToURI(Info, URI, TypeName, IsScalar);
      if Info.Kind = tkClass then
      begin
        AClass := GetTypeData(Info).ClassType;
        if not AClass.InheritsFrom(TRemotableXS) then
          raise ESOAPDomConvertError.Create(SUnsupportedVariant);
        DT := DateTimeToXSDateTime(V);
        S := DT.NativeToXS;
        DT.Free;
      end else
        S := V;
      CreateScalarNodeXS(RootNode, Node, Name, URI, TypeName, S);
    end;
  end;
end;

function TSOAPDomConv.MakeArrayNode(RootNode, Node: IXMLNode;  Name, URI, TypeName: InvString;
  Indices: array of Integer): IXMLNode;
var
  ArraySpec, Dims: InvString;
  I: Integer;
  First: Boolean;
  SoapPre, Pre: InvString;
  ID: string;
  MultiRefNode: IXMLNode;
begin
  if (URI = '') or (TypeName = '') then  // assume we have a variant type and don't create an array node
  begin
    Result := Node.AddChild(Name);
  end else
  begin

    if soSendMultiRefArray in Options then
    begin
      ID := GetNewID;
      Pre := FindPrefixForURI(RootNode, Node,  URI, True);
      Result :=  Node.AddChild(Pre + ':' + Name);  { do not localize }
      Result.Attributes[SXMLHREF] := SHREFPre + ID;
      Pre := FindPrefixForURI(RootNode, Node, SSoap11EncodingS5, True);
      MultiRefNode := CreateMultiRefNode(RootNode, Pre + ':' + SSoapEncodingArray, ID);   { do not localize }
      Result := MultiRefNode;
    end else
    begin
       MultiRefNode := nil;
       Result := CreateTypedNode(RootNode, Node, Name, SSoap11EncodingS5, SSoapEncodingArray);
    end;
    begin
      I := 0;
      if Indices[I] = 0 then
      begin
        while (I < Length(Indices) - 1) and (Indices[I] = 0) do
        begin
          Dims := Dims + '[]';    { do not localize }
          Inc(I);
        end;
      end;


      First := True;
      if I < Length(Indices)  then
      begin
        Dims := Dims + '[';          { do not localize }
        while I < Length(Indices)  do
        begin
          if not First then
          begin
            Dims := Dims + ',';      { do not localize }
          end;
          First := False;
          if Indices[I] <> 0 then
            Dims := Dims + IntToStr(Indices[I]);
          Inc(I);
        end;
        Dims := Dims +  ']';       { do not localize }
      end;
    end;
    SoapPre := FindPrefixForURI(RootNode, Node, SSoap11EncodingS5, True);
    Pre := FindPrefixForURI(RootNode, Node, URI, True);
    if not (soSendUntyped in Options) then
    begin
      ArraySpec := Pre + ':' + TypeName + Dims;     { do not localize }
      Result.Attributes[SoapPre + ':' + SSoapEncodingArrayType] := ArraySpec;    { do not localize }
    end;
  end;
end;

procedure TSOAPDomConv.WriteVarArrayAsB64(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
var
  I, DimCount, VSize: Integer;
  LoDim, HiDim: array of integer;
  P: Pointer;
  S, Encd: String;
  ElemNode: IXMLNode;
begin
  DimCount := VarArrayDimCount(V);
  SetLength(LoDim, DimCount);
  SetLength(HiDim, DimCount);
  for I := 1 to DimCount do
  begin
    LoDim[I - 1] := VarArrayLowBound(V, I);
    HiDim[I - 1] := VarArrayHighBound(V, I);
  end;
  VSize := 0;
  for i := 0 to DimCount - 1 do
    VSize := (HiDim[i] - LoDim[i] + 1);
  P := VarArrayLock(V);
  try
    SetString(S, PChar(P), VSize);
  finally
    VarArrayUnlock(V);
  end;
  Encd :=  EncodeString(S);
  ElemNode := CreateScalarNodeXS(RootNode, Node, Name, XMLSchemaNamespace, 'base64Binary', Encd);   { do not localize }
end;

procedure TSOAPDomConv.WriteVarArray(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
var
  I, DimCount: Integer;
  LoDim, HiDim, Indices: array of integer;
  V1: Variant;
  ElemNode: IXMLNode;
begin
  if  not VarIsArray(V) then
  begin
    WriteVariant(RootNode, Node, Name, V);
  end
  else
  begin
    ElemNode := Node.AddChild(Name);
    DimCount := VarArrayDimCount(V);
    SetLength(LoDim, DimCount);
    SetLength(HiDim, DimCount);
    for I := 1 to DimCount do
    begin
      LoDim[I - 1] := VarArrayLowBound(V, I);
      HiDim[I - 1] := VarArrayHighBound(V, I);
    end;
    SetLength(Indices, DimCount);
    for I := 0 to DimCount - 1 do
      Indices[I] := LoDim[I];
    while True do
    begin
      V1 := VarArrayGet(V, Indices);
      if VarIsArray(V1) then
        WriteVarArray(RootNode, ElemNode, SDefVariantElemName, V1)
      else
        WriteVariant(RootNode, ElemNode, SDefVariantElemName, V1);

      Inc(Indices[DimCount - 1]);
      if Indices[DimCount - 1] > HiDim[DimCount - 1] then
        for i := DimCount - 1 downto 0 do
          if Indices[i] > HiDim[i] then
          begin
            if i = 0 then Exit;
            Inc(Indices[i - 1]);
            Indices[i] := LoDim[i];
          end;
    end;
  end;
end;



function  TSOAPDomConv.ReadVarArrayDim(Node: IXMLNode): Variant;
var
  I: Integer;
  SoapTypeInfo: PTypeInfo;
  ChildNode: IXMLNode;
  TypeURI, TypeName: InvString;
  IsNull: Boolean;
  DT: TXSDateTime;
begin
  if Node.ChildNodes.Count = 0 then
  begin
    Result := NULL;
    Exit;
  end;

  IsNull := NodeIsNull(Node.ChildNodes[0]);
  if not IsNull then
  begin
    Result := VarArrayCreate([0, Node.ChildNodes.Count-1], VarVariant);
    for I := 0 to Node.ChildNodes.Count -1 do
    begin
      ChildNode := Node.ChildNodes[I];
      if ChildNode.ChildNodes.Count > 1 then
      begin
        Result[I] := ReadVarArrayDim(ChildNode);
      end else
      begin
        if not NodeIsNULL(ChildNode) then
        begin
          GetElementType(ChildNode, TypeURI, TypeName);
          SoapTypeInfo := RemTypeRegistry.XSDToTypeInfo(TypeURI, TypeName);
          if SoapTypeInfo = nil then
            SoapTypeInfo := TypeInfo(System.WideString);
          if (SoapTypeInfo.Kind = tkClass) and (GetTypeData(SoapTypeInfo).ClassType = TXSDateTime) then
          begin
            DT := TXSDateTime.Create;
            DT.XSToNative(ChildNode.Text);
            Result[I] := DT.AsDateTime;
            DT.Free;
          end else
          Result[I] := TypeTranslator.CastSoapToVariant(SoapTypeInfo, ChildNode.Text);
        end else
          Result[I] := NULL;
      end;
    end;
  end else
    Result := NULL;
end;

procedure TSOAPDomConv.ConvertSoapToVariant(Node: IXMLNode; InvData: Pointer);
var
  Info: PTypeInfo;
  TypeURI, TypeName: InvString;
  DT: TXSDateTime;
begin
  if not Assigned(Node.ChildNodes) then
    Exit;
  if Node.ChildNodes.Count = 0 then
    Variant(PVarData(InvData)^) := NULL;
  if (Node.ChildNodes.Count > 1) or Node.ChildNodes[0].IsTextElement then
    Variant(PVarData(InvData)^) := ReadVarArrayDim(Node)
  else
  begin
    GetElementType(Node, TypeURI, TypeName);
    Info := RemTypeRegistry.XSDToTypeInfo(TypeURI, TypeName);
    if Info = nil then
      Info := TypeInfo(System.WideString);
    if (Info.Kind = tkClass) and (GetTypeData(Info).ClassType = TXSDateTime) then
    begin
      DT := TXSDateTime.Create;
      try
        DT.XSToNative(Node.Text);
        Variant(PVarData(InvData)^) := DT.AsDateTime;
      finally
        DT.Free;
      end;
    end else
      TypeTranslator.CastSoapToVariant(Info, GetNodeAsText(Node), InvData);
  end;
end;


function TSOAPDomConv.FindNodeByHREF(RootNode: IXMLNode; HREF: InvString): IXMLNode;
var
  I: Integer;
  V: Variant;
begin
  Result := nil;
  for I := 0 to RootNode.ChildNodes.Count -1 do
  begin
    V := RootNode.ChildNodes[I].Attributes[SXMLID];
    if not VarIsNull(V) and (SHREFPre + V = HREF) then
    begin
      Result := RootNode.ChildNodes[I];
      Exit;
    end;
  end;
end;


function GetDynArrayLength(P: Pointer): Integer;
begin
  asm
    MOV  EAX, DWORD PTR P
    CALL System.@DynArrayLength
    MOV DWORD PTR [Result], EAX
  end;
end;

function RecurseArray(P: Pointer; var Dims: Integer): Boolean;
var
  I, Len, Size: Integer;
  ElemDataP: Pointer;
  Size2: Integer;
begin
  Result := True;
  if Dims > 1 then
  begin
    Len := GetDynArrayLength(P);
    ElemDataP := Pointer(PInteger(P)^);
    Size := GetDynArrayLength(ElemDataP);
    for i := 0 to Len - 1 do
    begin
      Size2 :=  GetDynArrayLength(ElemDataP);
      if Size <> Size2 { GetDynArrayLength(ElemDataP) } then
      begin
        Result := False;
        Exit;
      end;
      if Dims > 1 then
      begin
        Dec(Dims);
        Result := RecurseArray(ElemDataP, Dims);
        if not Result then
          Exit;
      end;
      ElemDataP := Pointer(PInteger(Pointer(Integer(P) + 4))^);
    end;
  end;
end;

function IsArrayRect(P: Pointer; Dims: Integer): Boolean;
var
  D: Integer;
begin
  D := Dims;
  Result := RecurseArray(P, D);
end;



procedure GetDims(ArrP: Pointer; DimAr: TIntegerDynArray; Dims: Integer);
var
  I: Integer;
begin
  for I := 0 to Dims - 1 do
  begin
    DimAr[I] := GetDynArrayLength(ArrP);
    if I < Dims - 1 then
      ArrP := Pointer(PInteger(ArrP)^);
  end;
end;

procedure TSOAPDomConv.WriteRectDynArrayElem(RootNode, Node: IXMLNode; Info: PTypeInfo; Size, Dim: Integer; P: Pointer);
var
  I: Integer;
  S: InvString;
  IsNull: Boolean;
  ArNode: IXMLNode;
  ElemSize: Integer;
begin
  if Dim > 1 then
  begin
    Dec(Dim);
    for I := 0 to Size - 1 do
    begin
      ElemSize := GetDynArrayLength(Pointer(PInteger(P)^));
      WriteRectDynArrayElem(RootNode, Node, Info, ElemSize, Dim, Pointer(PInteger(P)^));
      P := Pointer(Integer(P) + sizeof(Pointer));
    end;
  end
  else
  begin
    for I := 0 to Size - 1 do
    begin
      if Info.Kind = tkClass then
      begin
        ConvertObjectToSOAP(DefArrayElemName, P, RootNode,  Node, 1);
      end else
      if Info.Kind = tkVariant then
      begin
        ConvertVariantToSoap(RootNode, Node, DefArrayElemName, Info, P, 1, NULL, False);
      end else
      begin
        if Info.Kind = tkEnumeration then
          S := ConvertEnumToSoap(Info, P, 1)
        else
          TypeTranslator.CastNativeToSoap(Info, S, P, IsNull);
        ArNode := Node.AddChild(DefArrayElemName);
        ArNode.Text := S;
      end;
      P := Pointer( Integer(P) + GetTypeSize(Info));
    end;
  end;
end;

procedure  TSOAPDomConv.WriteRectDynArray(RootNode, Node: IXMLNode; Info: PTypeInfo; Dims: Integer; P: Pointer);
begin