optosoapdomconv.pas

Delphi开发webservice的一套例子

                ID := FindMultiRefNodeByInstance(Obj);
                if ID = '' then
                  ID := CreateObjectNode(Obj, RootNode, InstNode, ExtPropName, ElemURI);
                ElemNode.Attributes[SXMLHREF] := SHREFPre + ID;
              end;
            end;
          end;
        end else if Kind = tkDynArray then
        begin
          P := Pointer(GetOrdProp(Instance, PropList[I]));
          ConvertNativeArrayToSoap(RootNode, InstNode, ExtPropName, (PropList[I].PropType)^, P, 0);
        end else if Kind = tkVariant then
        begin
           V := GetVariantProp(Instance, PropList[I]);
           ConvertVariantToSoap(RootNode, InstNode, ExtPropName, nil, nil, 0, V, True);
        end else
        begin
          if not RemTypeRegistry.TypeInfoToXSD((PropList[I].PropType)^, ElemURI, TypeName) then
            raise ESOAPDomConvertError.CreateFmt(SRemTypeNotRegistered, [(PropList[I].PropType)^.Name]);
          ElemNode := CreateScalarNodeXS(RootNode, InstNode, ExtPropName, ElemURI, TypeName, GetObjectPropAsText(Instance, PropList[I]));
        end;
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;
procedure TSOAPDomConv.ConvertObjectToSOAP(Name: InvString;
  ObjP: Pointer; RootNode, Node: IXMLNOde; NumIndirect: Integer);
var
  ElemNode: IXMLNOde;
  I: Integer;
  ID: string;
  URI, TypeName: WideString;
  IsScalar: Boolean;
  P: Pointer;
  Instance: TObject;
  MultiRefOpt: TObjMultiOptions;
begin
  P := ObjP;
  for I := 0 to NumIndirect - 1 do
    P := Pointer(PInteger(P)^);
  Instance := P;

  if Assigned(Instance) and not Instance.InheritsFrom(TRemotable) then
    raise ESOAPDomConvertError.CreateFmt(SUnsuportedClassType, [Instance.ClassName]);

  if not Assigned(Instance) then
    CreateNULLNode(RootNode, Node, Name)
  else
  begin
    if not RemClassRegistry.ClassToURI(Instance.ClassType, URI, TypeName, IsScalar) then
      raise ESOAPDomConvertError.CreateFmt(SRemTypeNotRegistered, [Instance.ClassName]);
    if IsScalar then
    begin
      if not Instance.ClassType.InheritsFrom(TRemotableXS) then
        raise ESOAPDomConvertError.CreateFmt(SScalarFromTRemotableS, [Instance.ClassType.ClassName]);

      ElemNode := CreateScalarNodeXS(RootNode, Node, Name, URI, TypeName, TRemotableXS(Instance).NativeToXS, True);
    end else
    begin
      MultiRefOpt :=  RemTypeRegistry.ClassOptions(Instance.ClassType);
      if not (soSendMultiRefObj in FOptions) or  (ocNoMultiRef = MultiRefOpt) then
      begin
        if IsObjectWriting(Instance) then
          raise ESOAPDomConvertError.Create(SNoSerializeGraphs);
        AddObjectAsWriting(Instance);
        CreateObjectNode(Instance, RootNode, Node, Name, URI);
        RemoveObjectAsWriting(Instance);
      end
      else
      begin
        ID := FindMultiRefNodeByInstance(Instance);
        if ID = '' then
          ID := CreateObjectNode(Instance, RootNode, ElemNode, Name, URI);
        ElemNode := Node.AddChild(Name);
        ElemNode.Attributes[SXMLHREF] := SHREFPre + ID;
      end;

    end;
  end;
end;


function TSOAPDomConv.GetObjectPropAsText(Instance: TObject;
  PropInfo: PPropInfo): WideString;
var
 I: LongInt;
 E: Extended;
 I64: Int64;
begin
  case (PropInfo.PropType)^.Kind of
    tkInteger:
      begin
        I := GetOrdProp(Instance, PropInfo);
        Result := IntToStr(I);
      end;
    tkFloat:
      begin
        E := GetFloatProp(Instance, PropInfo);
        Result := FloatToStr(E);
      end;
    tkWString:
      Result := GetWideStrProp(Instance, PropInfo);
    tkString,
    tkLString:
      Result := GetStrProp(Instance, PropInfo);
    tkInt64:
      begin
        I64 := GetInt64Prop(Instance, PropInfo);
        Result := IntToStr(I64);
      end;
    tkEnumeration:
      Result := GetEnumProp(Instance, PropInfo);
    tkChar:
      begin
        I := GetOrdProp(Instance, PropInfo);
        Result :=  InvString(Char(I));
      end;
    tkWChar:
      begin
        I := GetOrdProp(Instance, PropInfo);
        Result :=  InvString(WideChar(I));
      end;
    tkClass:
      ;
    tkSet,
    tkMethod,

    tkArray,
    tkRecord,
    tkInterface,


    tkDynArray,
    tkVariant:
      raise ESOAPDomConvertError.CreateFmt(SUnexpectedDataType, [KindNameArray[(PropInfo.PropType)^.Kind]]); 

  end;

end;

function TSOAPDomConv.GetTypeBySchemaNS(Node: IXMLNode; URI: InvString): Variant;
var
  I: Integer;
begin
  Result := Node.GetAttributeNS(SSoapType, URI);
  if VarIsNull(Result) and (soTryAllSchema in Options) then
  begin
    for I := Low(XMLSchemaInstNamepspaces) to High(XMLSchemaInstNamepspaces) do
    begin
      Result := Node.GetAttributeNS(SSoapType, XMLSchemaInstNamepspaces[I]);
      if not VarIsNull(Result) then
        break;
    end;
  end;
end;

function TSOAPDomConv.GetElementType(Node: IXMLNode; var TypeURI, TypeName: InvString): Boolean;
var
  Idx: Integer;
  S : InvString;
  V: Variant;
  Pre: InvString;
begin
  TypeURI := '';
  TypeName := '';
  Result := False;
  if (Node.NamespaceURI = SSoap11EncodingS5) and (Node.LocalName = SSoapEncodingArray) then
  begin
    TypeURI := SSoap11EncodingS5;
    TypeName := SSoapEncodingArray;
    Result := True;
  end else
  begin
    V := GetTypeBySchemaNS(Node, XMLSchemaInstNameSpace);
    if VarIsNull(V) then
      V := Node.GetAttribute(SSoapType);
    if not VarIsNull(V) then
    begin
      S := V;
      Idx := Pos(':', S);  { do not localize }
      if Idx <> 0 then
      begin
        TypeName := Copy(S, Idx + 1, High(Integer));
        Pre := Copy(S, 1, Idx - 1);
        TypeURI := Node.FindNamespaceURI(Pre);
      end
      else
      begin
        TypeName := S;
        TypeURI := ''; 
      end;
      Result := True;
    end;
  end
end;

procedure TSOAPDomConv.SetObjectPropFromText(Instance: TObject; PropInfo: PPropInfo; SoapData: WideString);
var
 I: LongInt;
 E: Extended;
 I64: Int64;
begin
  case (PropInfo.PropType)^.Kind of
    tkInteger:
      begin
        I := StrToInt(SoapData);
        SetOrdProp(Instance, PropInfo, I);
      end;
    tkFloat:
      begin
        E := StrToFloat(SoapData);
        SetFloatProp(Instance, PropInfo, E);
      end;
    tkWString:
      SetWideStrProp(Instance, PropInfo, SoapData);
    tkString,
    tkLString:
       SetStrProp(Instance, PropInfo, SoapData);

    tkInt64:
      begin
        I64 := StrToInt64(SoapData);
        SetInt64Prop(Instance, PropInfo, I64);
      end;
    tkEnumeration:
      SetEnumProp(Instance, PropInfo, SoapData);
    tkChar,
    tkWChar:
      if SoapData <> '' then
        SetOrdProp(Instance, PropInfo, Integer(SoapData[1]));
    tkClass:
      ;
    tkSet,
    tkMethod,
    tkArray,
    tkRecord,
    tkInterface,
    tkDynArray,
    tkVariant:
      raise ESOAPDomConvertError.CreateFmt(SUnexpectedDataType, [KindNameArray[(PropInfo.PropType)^.Kind]]); 

  end;
end;

procedure TSOAPDomConv.LoadObject(Instance: TObject; RootNode, Node: IXMLNode);
var
  PropList: PPropList;
  Count: Integer;
  Kind: TTypeKind;
  I, K: Integer;
  Obj: TObject;
  IsNull: Boolean;
  URI, TypeName: InvString;
  ArrayPtr: Pointer;
  V: Variant;
  SoapTypeInfo: PTypeInfo;
  DT: TXSDateTime;
  InternalName: string;
begin
  Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Instance.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        K := 0;
        while K < Node.ChildNodes.Count do
        begin
          InternalName := RemTypeRegistry.GetInternalPropName(Instance.ClassInfo,Node.ChildNodes[K].LocalName);
          if SameText(InternalName, PropList[I].Name) then
            break;
          Inc(K);
        end;
        if K >= Node.ChildNodes.Count then
          continue;

        Kind := (PropList[I].PropType)^.Kind;
        if Kind = tkClass then
        begin
          Obj := ConvertSOAPToObject(RootNode, Node.ChildNodes[K], GetTypeData((PropList[I].PropType)^).ClassType,
            '', '', nil, 0);
          if Obj <> nil then
            SetObjectProp(Instance, PropList[I], Obj);
        end else if Kind = tkDynArray then
        begin
          IsNull := NodeIsNull(Node.ChildNodes[K]);
          if not IsNull then
          begin
            GetElementType( Node.ChildNodes[K], URI, TypeName);
            ArrayPtr := nil;
            ArrayPtr := ConvertSoapToNativeArray(@ArrayPtr, (PropList[I].PropType)^, RootNode,  Node.ChildNodes[K]);
            SetOrdProp(Instance, PropList[I], Integer(ArrayPtr));
          end;
        end else if Kind = tkVariant then
        begin
          if Node.ChildNodes[K].ChildNodes.Count > 1 then
            V := ReadVarArrayDim(Node.ChildNodes[K])
          else
          begin
            if NodeIsNull(Node.ChildNodes[K]) then
              V := NULL
            else
            begin
              GetElementType(Node.ChildNodes[K], URI, TypeName);  
              SoapTypeInfo := RemTypeRegistry.XSDToTypeInfo(URI, 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(Node.ChildNodes[K].Text);
                V := DT.AsDateTime;
                DT.Free;
              end else
                V := TypeTranslator.CastSoapToVariant(SoapTypeInfo, Node.ChildNodes[K].Text);
            end;
          end;
          SetVariantProp(Instance, PropList[I], V);
        end else
          SetObjectPropFromText(Instance, PropList[I], Node.ChildNodes[K].Text);

      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;

function  TSOAPDomConv.ConvertSOAPToObject(RootNode, Node: IXMLNode; AClass: TClass;
  URI, TypeName: WideString; ObjP: Pointer; NumIndirect: Integer): TObject;
var
  ID: InvString;
  ObjNode: IXMLNode;
  IsScalar: Boolean;
  Obj, LoadedObj: TObject;
  P: Pointer;
  I: Integer;
  NodeClass: TClass;
  NodeURI, NodeTypeName: InvString;
  LegalRef: Boolean;
  S: string; // todo
begin
  if NodeIsNULL(Node) then
  begin
    Result := nil;
    Exit;
  end;

  P := ObjP;
  for I := 0 to NumIndirect - 1 do
    P := Pointer(PInteger(P)^);
  Obj := TObject(P);


  IsScalar := RemClassRegistry.IsClassScalar(AClass);
  if IsScalar then
  begin
    if not AClass.InheritsFrom(TRemotableXS) then
        raise ESOAPDomConvertError.CreateFmt(SScalarFromTRemotableS, [AClass.ClassName]);
      Obj := TRemotableXSClass(AClass).Create;
      Result := Obj;
    TRemotableXS(Obj).XSToNative(Node.Text);
  end else
  begin
    S := Node.LocalName;
    ObjNode := GetDataNode(RootNode, Node, ID);
    if ID <> '' then
      LoadedObj :=  FindMultiRefNodeByID(ID)
    else
      LoadedObj := nil;

    if Assigned(LoadedObj) then
      Result := LoadedObj
    else
    begin
      GetElementType(ObjNode, NodeURI, NodeTypeName);
      NodeClass := RemTypeRegistry.URIToClass(NodeURI, NodeTypeName, IsScalar);
      LegalRef := True;
      if Assigned(Obj) then
      begin
        try
          if Obj.ClassType <> nil then
            LegalRef := True;
        except
          LegalRef := False;
        end;
      end;
      if Assigned(Obj) and  LegalRef then
      begin
        if (NodeClass <> nil) and (NodeClass <> Obj.ClassType) then
          Obj := NodeClass.Create;