xmlworks2.pas

delphi的XMPRPC通讯例子

    tkEnumeration: result := StrToXML(GetEnumName( PropInfo^.PropType^, GetOrdProp(Instance, PropInfo)));
    tkClass:
      begin
        ObjectProp := TObject(GetOrdProp(Instance, PropInfo));
        if Assigned(ObjectProp) then
        begin
          if ObjectProp.GetInterface(IXMLWorksObject, Intf) then
            result := Intf.ElementText
          else if (ObjectProp is TXMLCollection) then
            result := TXMLCollection(ObjectProp).ElementText
          else if (ObjectProp is TXMLCollectionItem) then
            result := TXMLCollectionItem(ObjectProp).ElementText
          else if (ObjectProp is TXMLObject) then
            result := TXMLObject(ObjectProp).ElementText
          else if (ObjectProp is TXMLList) then
            result := TXMLList(ObjectProp).ElementText   
          else if (ObjectProp is TStrings) then
            result := StrToXML((ObjectProp as TStrings).CommaText)
          else
            if gb_XMLRaiseInvalidPropertyClass then
              raise EXMLException.Create('Invalid Class Property (' + PropInfo.Name + ')');
        end;
      end;
    tkInterface: 
      result := InterfaceToXML(GetIntfProp(Instance, PropInfo));
  end;
end;


procedure setPropAsString(Instance: TObject; PropInfo: PPropInfo; const value : 
        string);
var
  ObjectProp : TObject;
  Intf: IXMLWorksObject;
  vTemp : variant;  
begin
  //  No property          
  if (PropInfo = Nil) OR (value = '') or
    // a read only simple type
    ((PropInfo^.SetProc = NIL) and not (PropInfo^.PropType^.Kind in [tkClass, tkInterface])) then
    exit;
    

  case PropInfo^.PropType^.Kind of
    tkString,
    tkLString,
    tkWString: 
      if AnsiSameText(PropInfo^.PropType^.Name, 'XMLString') then
        SetStrProp(Instance, PropInfo, Value)
      else if AnsiSameText(PropInfo^.PropType^.Name, 'XMLMIMEString') then
        SetStrProp(Instance, PropInfo, Base64Decode(Value))
      else
        SetStrProp(Instance, PropInfo, XMLToStr(Value));
    tkSet,
    tkInteger: 
      if AnsiSameText(PropInfo^.PropType^.Name, 'XMLRGBTColor') then
        SetOrdProp(Instance, PropInfo, SwapRandB(StrToInt(XMLToStr(Value))))
      else
        SetOrdProp(Instance, PropInfo, StrToInt(XMLToStr(Value)));
    tkFloat:
      if AnsiSameText(PropInfo^.PropType^.Name, 'TDateTime')  then
        SetFloatProp(Instance, PropInfo, StrToDateTime(XMLToStr(Value)))
      else if AnsiSameText(PropInfo^.PropType^.Name, 'TTime')  then
        SetFloatProp(Instance, PropInfo, StrToTime(XMLToStr(Value)))
      else if AnsiSameText(PropInfo^.PropType^.Name, 'TDate')  then
        SetFloatProp(Instance, PropInfo, StrToDate(XMLToStr(Value)))
      else
        SetFloatProp(Instance, PropInfo, StrToFloat(XMLToStr(Value)));

    tkVariant: 
      begin
        vTemp := GetVariantProp(Instance,PropInfo);
        XMLToVariant(value,vTemp);
        SetVariantProp(Instance, PropInfo, vTemp);
      end;
                   
    tkInt64: SetInt64Prop(Instance, PropInfo, StrToInt64(XMLToStr(Value)));

    tkChar,
    tkWChar: SetOrdProp(Instance, PropInfo, Ord(XMLToStr(Value)[1]));

    tkEnumeration: SetOrdProp(Instance, PropInfo, GetEnumValue( PropInfo^.PropType^, XMLToStr(Value)));
    tkClass :
      begin
        try
          ObjectProp := TObject(GetOrdProp(Instance, PropInfo));
          if Assigned(ObjectProp) then
          begin
            if ObjectProp.GetInterface(IXMLWorksObject, Intf) then
              Intf.ElementText := Value
            else if (ObjectProp is TXMLCollection) then
              TXMLCollection(ObjectProp).ElementText := Value
            else if (ObjectProp is TXMLCollectionItem) then
              TXMLCollectionItem(ObjectProp).ElementText := Value
            else if (ObjectProp is TXMLObject) then
              TXMLObject(ObjectProp).ElementText := Value
            else if (ObjectProp is TXMLList) then
              TXMLList(ObjectProp).ElementText := Value   
            else if (ObjectProp is TStrings) then
              TStrings(ObjectProp).CommaText := XMLToStr(Value)
          end;
        except
          on e: Exception do
            raise EXMLException.Create('(' + e.Message + ')Error with property - ' + PropInfo^.Name);
        end;
      end;
    tkInterface: 
      XMLtoInterface(Value,GetIntfProp(Instance, PropInfo));
{
  Types not supported :
    tkRecord
    tkArray
    tkDynArray
    tkMethod
    tkUnknown
}
  end;

end;


function ObjectToXMLElements(const aObject:TObject): String;
var
  i : Integer;
  s : string;
  StringList : TStringList;
  Props: TList;
begin
  result := '';
  StringList := TStringList.Create;
  try
    Props := GetPropertyList(aObject.ClassInfo);
    try
      for i := 0 to Props.Count-1 do
      begin
        s := GetPropAsString(AObject, PPropInfo(Props.Items[i]));

        StringList.Add('<' + PPropInfo(Props.Items[i]).Name + '>' + s + '</' + PPropInfo(Props.Items[i]).Name + '>');
      end;
      result := StringList.Text;
    finally
      Props.Free;
    end;
  finally
    StringList.Free;
  end;
end;


function ObjectToXMLProperties(const aObject:TObject): String;
var
  i : Integer;
begin
  result := ' ';
  with GetPropertyList(aObject.ClassInfo) do
  try
    for i := 0 to Count-1 do
      result := result + PPropInfo(Items[i]).Name + '="' + GetPropAsString(AObject, PPropInfo(Items[i])) + '" ';
  finally
    Free;
  end;
end;

function getObjectDTDSequence(const aObject:TObject): string;
var
  i : Integer;
begin
  result := '';
  with GetPropertyList(aObject.ClassInfo) do
  try
    if Count < 1 then
      exit;
      
    for i := 0 to Count-2 do
      result := result + PPropInfo(Items[i]).Name + ', ';
    result := result + PPropInfo(Items[Count-1]).Name;
  finally
    Free;
  end;
end;

function getPropertyDTD(Instance: TObject; PropInfo: PPropInfo) : string;
var
  ObjectProp : TObject;
  Intf: IXMLWorksObject;
begin
  case PropInfo^.PropType^.Kind of
    tkString,
    tkLString,
    tkWString,
    tkInt64,
    tkInteger,
    tkFloat,
    tkVariant,
    tkChar,
    tkWChar,
    tkEnumeration : result := '#PCDATA';
    tkClass:
      begin
        ObjectProp := TObject(GetOrdProp(Instance, PropInfo));
        if Assigned(ObjectProp) then
        begin
          if ObjectProp.GetInterface(IXMLWorksObject, Intf) then
            result := Intf.getDTDSequence
          else if (ObjectProp is TXMLCollection) then
            result := TXMLCollection(ObjectProp).getDTDSequence
          else if (ObjectProp is TXMLCollectionItem) then
            result := TXMLCollectionItem(ObjectProp).getDTDSequence
          else if (ObjectProp is TXMLObject) then
            result := TXMLObject(ObjectProp).getDTDSequence
          else if (ObjectProp is TXMLList) then
            result := TXMLList(ObjectProp).getDTDSequence
          else
            if gb_XMLRaiseInvalidPropertyClass then
              raise EXMLException.Create('Invalid Class Property (' + PropInfo.Name + ')');
        end;
      end;
    else
      Result := '';
  end;
end;

function getPropertyDTDElements(Instance: TObject; PropInfo: PPropInfo) : string;
var
  ObjectProp : TObject;
  Intf: IXMLWorksObject;
begin
  case PropInfo^.PropType^.Kind of
    tkClass:
      begin
        ObjectProp := TObject(GetOrdProp(Instance, PropInfo));
        if Assigned(ObjectProp) then
        begin
          if ObjectProp.GetInterface(IXMLWorksObject, Intf) then
            result := Intf.getDTDElements
          else if (ObjectProp is TXMLCollection) then
            result := TXMLCollection(ObjectProp).getDTDElements
          else if (ObjectProp is TXMLCollectionItem) then
            result := TXMLCollectionItem(ObjectProp).getDTDElements
          else if (ObjectProp is TXMLObject) then
            result := TXMLObject(ObjectProp).getDTDElements
          else if (ObjectProp is TXMLList) then
            result := TXMLList(ObjectProp).getDTDElements
          else
            if gb_XMLRaiseInvalidPropertyClass then
              raise EXMLException.Create('Invalid Class Property (' + PropInfo.Name + ')');
        end;
      end;
    else
      Result := '';
  end;
end;

function getObjectDTDElements(const aObject:TObject): String;
var
  i : Integer;
  s : string;
  StringList : TStringList;
  Props: TList;
begin
  result := '';
  StringList := TStringList.Create;
  try
    Props := GetPropertyList(aObject.ClassInfo);
    try
      for i := 0 to Props.Count-1 do
      begin
        StringList.Add(cs_ElementHeader + PPropInfo(Props.Items[i]).Name + '(' + getPropertyDTD(AObject, PPropInfo(Props.Items[i])) + ')>');

        s := getPropertyDTDElements(AObject, PPropInfo(Props.Items[i]));
        if s <> '' then
          StringList.Add(s);
      end;
      result := StringList.Text;
    finally
      Props.Free;
    end;
  finally
    StringList.Free;
  end;
end;

function FastPosChecked(const aSourceString, aFindString : String;
  const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  Offset, MaxPos : integer;
  c : Char;
begin
  Offset := StartPos;
  MaxPos := aSourceLen - aFindLen -1;
  c := aFindString[aFindLen];
  repeat
    Result := FastStrings.FastPos(aSourceString, aFindString, aSourceLen, aFindLen, Offset);
    if (Result > 0) and (Result <= MaxPos) then
    begin
      if aSourceString[Result+aFindLen-1] = c then
      begin
        Offset := -1;
      end else begin
        Offset := Result+aFindLen;
      end;
    end;
  until (Result = 0) or (Offset = -1) or (Result > MaxPos);
end;

function FastParseTag(const Source, Start, Stop: AnsiString; var Index: Integer): AnsiString;
var
  StartLen, StopLen, SourceLen: Integer;
  StartIndex, StopIndex: Integer;
begin
  StartIndex := 0;
  Result := '';
  SourceLen := Length(Source);
  StartLen := Length(Start);
  StopLen := Length(Stop);

  if (Index > 0) and (Index < SourceLen) and (StartLen > 0) and (StopLen > 0) then
  begin
    StartIndex := FastPosChecked(Source, Start, SourceLen, StartLen, Index);
    if StartIndex > 0 then
    begin
      Inc(StartIndex, StartLen);
      StopIndex := FastPosChecked(Source, Stop, SourceLen, StopLen, StartIndex);
      if StopIndex > 0 then
      begin
        Result := Copy(Source, StartIndex, StopIndex - StartIndex);
        StartIndex := StopIndex + StopLen;
      end
      else
        StartIndex := 0;
    end;
  end;
  Index := StartIndex;
end;


function FastParse(const Source: AnsiString; const Delim: Char; var Index: 
        Integer): AnsiString;
var
  SourceLen: Integer;
  NewIndex: Integer;
  StopIndex: Integer;
begin
  Result := '';
  SourceLen := Length(Source);

  if (Index > 0) and (Index <= SourceLen) then
  begin
    StopIndex := FastPos(Source, Delim, SourceLen, 1, Index);
    if StopIndex = 0 then
    begin
      StopIndex := SourceLen + 1;
      NewIndex := 0; 
    end
    else
      NewIndex := StopIndex + 1;
    
    result := Copy(Source, Index, StopIndex-Index); 
  end
  else
    NewIndex := 0;

  Index := NewIndex;
end;

function FastToken(const Source: AnsiString; const Delim: Char; Index: 
        Integer): AnsiString;
var
  SourceLen: Integer;
  StartIndex, StopIndex: Integer;
begin
  Result := '';
  SourceLen := Length(Source);

  if (Index > 0) and (Index <= SourceLen) and (Source[Index] <> Delim) then
  begin
    if (Index = SourceLen) then
    begin
      StartIndex := FastPosBack(Source, Delim, SourceLen, 1, Index) + 1;
      
      StopIndex := SourceLen;
    end
    else if (Index = 1) then
    begin
      StartIndex := 1; 
      StopIndex := FastPos(Source, Delim, SourceLen, 1, Index) - 1;
    end
    else
    begin
      StartIndex := FastPosBack(Source, Delim, SourceLen, 1, Index) + 1; 
      StopIndex := FastPos(Source, Delim, SourceLen, 1, Index) - 1;  
    end;

    if StartIndex = 0 then
      StartIndex := 1;
    if StopIndex = 0 then
      StopIndex := SourceLen;

    Result := Copy(Source, StartIndex, StopIndex - StartIndex + 1);
  end;
end;

function FastParseTagXML(const Source, Tag: AnsiString; var Index: Integer): 
        AnsiString;
var
  NestLevel: Integer;
  StartTag, StopTag: AnsiString;
  StartLen, StopLen, SourceLen: Integer;
  StartIndex, StopIndex: Integer;
begin
  SourceLen := Length(Source);
  StartIndex := Index;
  Index := 0;
  result := '';
  if (StartIndex > 0) and (StartIndex < SourceLen) then
  begin
    StartTag := '<' + Tag + '>';
    StartLen := Length(StartTag);

    if StartLen > 2 then
    begin
      StopTag := '</' + Tag + '>';
      StopLen := Length(StopTag);

      StartIndex := FastPosChecked(Source, StartTag, SourceLen, StartLen, StartIndex);
      if StartIndex > 0 then   // StartTag Found
      begin
        NestLevel := 1;
        Inc(StartIndex, StartLen);
        Index := StartIndex; // This is beginning of Content within Tag
        repeat
          StopIndex := FastPosChecked(Source, StopTag, SourceLen, StopLen, StartIndex);
          if StopIndex >= Index then
          begin
            Dec(NestLevel);
            repeat
              StartIndex := FastPosChecked(Source, StartTag, StopIndex, StartLen, StartIndex);
              if StartIndex > 0 then
              begin
                Inc(NestLevel);
                Inc(StartIndex, StartLen); 
              end;
            until StartIndex = 0;
            StartIndex := StopIndex + StopLen;
          end;
        until (NestLevel = 0) or (StopIndex = 0);

        if NestLevel = 0 then
        begin
          result := Copy(Source, Index, StopIndex - Index);
          Index := StopIndex + StopLen;
        end
        else
          Index := 0;
      end;
    end;
  end;
end;

procedure setXMLObject(Instance: TObject; p_sXML: AnsiString);
var
  CurrentTagIndex, OverAllIndex: Integer;
  CurrentTag, CurrentTagContent :string;
begin
  try
    CurrentTagIndex := 1;
    OverallIndex := 1;
    repeat
      CurrentTag := FastParseTag(p_sXML, '<' , '>', OverallIndex);
      CurrentTagContent := FastParseTagXML(p_sXML, CurrentTag, CurrentTagIndex);
      if (Length(CurrentTag) > 0) then
        SetPropAsString(Instance, GetPropInfo(Instance.ClassInfo, CurrentTag), CurrentTagContent);
  
      OverAllIndex := CurrentTagIndex;
    until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML));
  except
    on EXMLException do
      raise;
    on e : Exception do
      raise EXMLException.Create('(' + e.Message + ')Error Processing XML - ' + CurrentTag);
  end;
end;

function isXMLPI(const TagStr : string):Boolean;
begin
  result := AnsiSameText('?xml', copy(TagStr,1,4));
end;

function getTagContent(const p_sXML, TargetTagName: String): string;
VAR
  CurrentTagIndex, OverAllIndex: Integer;
  CurrentTag, CurrentTagContent, DocType :string;
begin
  result := '';
  CurrentTagIndex := 1;
  OverallIndex := 1;
  DocType := FastParseTag(p_sXML, cs_DocTypeHeader, cs_DocTypeHeader_Close, OverallIndex);
  if length(DocType) = 0 then OverAllIndex := 1;
  repeat
    CurrentTag := FastParseTag(p_sXML, '<' , '>', OverallIndex);
    if not isXMLPI(CurrentTag) then
    begin
      CurrentTagContent := FastParseTagXML(p_sXML, CurrentTag, CurrentTagIndex);
      OverAllIndex := CurrentTagIndex;
    end;
  until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML)) or SameText(CurrentTag, TargetTagName);

  if SameText(CurrentTag, TargetTagName) then
    result := CurrentTagContent;
end;



{:
  Generic File and Stream Routines 
}

procedure SaveStringToFile(const Str, FileName:string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate or fmShareDenyNone);
  try
    SaveStringToStream(Str, Stream);
  finally
    Stream.Free;
  end;
end;{ SaveStringToFile() }

procedure SaveStringToStream(const Str:string; Stream:TStream);
var
  Buffer : PChar;
  MemSize : Integer;
begin
  if not Assigned(Stream) then
    raise EXMLIOException.Create('Could not save to Stream: Stream is not assigned');
  MemSize := Length(Str);
  Buffer := AllocMem(MemSize+1);
  try