xmlworks2.pas

delphi的XMPRPC通讯例子

    StrPCopy(Buffer,Str);
    Stream.Seek(0,soFromBeginning);
    Stream.Write(Buffer^, MemSize);
  finally
    FreeMem(Buffer, MemSize);
  end;
end;{ SaveStringToStream() }

function LoadStringFromFile(const FileName:string): string;
var
  Stream : TFileStream;
begin
  Result := '';
  if FileExists(Filename) then
  begin
    Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
    try
      Result := LoadStringFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
end;{ LoadStringFromFile() }



function LoadStringFromStream(Stream:TStream): string;
var
  Buffer : PChar;
  MemSize : Integer;
begin
  if not Assigned(Stream) then
    raise EXMLIOException.Create('Could not load from Stream: Stream is not assigned');

  Result := '';
  MemSize := Stream.Size;

  Inc(MemSize);
  Buffer := AllocMem(MemSize);
  try
    Stream.Read(Buffer^, MemSize);
    Result := StrPas(Buffer);
  finally
    FreeMem(Buffer, MemSize);
  end;
end; { LoadStringFromStream() }

{
******************************** TXMLCollection ********************************
}
constructor TXMLCollection.Create(ItemClass: TXMLCollectionItemClass);
begin
  inherited Create(ItemClass);
end;

function TXMLCollection.Add: TXMLCollectionItem;
begin
  Result := inherited Add as TXMLCollectionItem;
end;

function TXMLCollection.FindInt(Value: Integer; Compare: 
        TCollectionIntegerCompare): TXMLCollectionItem;
var
  L, H, I, C: Integer;
begin
  result := nil;
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    result := Items[I];
    C := -Compare(Value, Result);
    if C < 0 then
      L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
        exit;
    end;
  
    result := nil;
  end;
end;

function TXMLCollection.FindStr(Value: String; Compare: 
        TCollectionStringCompare): TXMLCollectionItem;
var
  L, H, I, C: Integer;
begin
  result := nil;
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    result := Items[I];
    C := -Compare(Value, Result);
    if C < 0 then
      L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
        exit;
    end;
  
    result := nil;
  end;
end;

function TXMLCollection.getDTDElements: string;
begin
  result := getObjectDTDElements(self);
end;

function TXMLCollection.getDTDSequence: string;
begin
  result := getObjectDTDSequence(self);
  if result = '' then
    result := getItemTagName + '*'
  else
    result := getItemTagName + '*, ' + result;
end;

function TXMLCollection.GetElementText: string;
var
  Index: Integer;
  StringList: TStringList;
  CollectionItemName: string;
begin
  result := '';
  StringList := TStringList.Create;
  try
    StringList.Text := getPropertiesXML;
    CollectionItemName := GetItemTagName;
    for Index := 0 to Count-1 do
    begin
      StringList.Add('<' + CollectionItemName + '>' + Items[Index].ElementText + '</' + CollectionItemName + '>');
    end;
    result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

function TXMLCollection.getItemTagName: string;
begin
  result := TXMLCollectionItemClass(ItemClass).getTagName;
end;

function TXMLCollection.getPropertiesXML: string;
begin
  result := ObjectToXMLElements(self)
end;

function TXMLCollection.getSubsetElementText(Start, Ct: Integer): string;
var
  StringList: TStringList;
  Index: Integer;
begin
  if (Start < 0) or (Start >= Count) then
    raise EXMLException.Create('Invalid Start (' + IntToStr(Start) + ')');
  
  if (Ct < 0) or ((Start + Ct) >= Count) then
    raise EXMLException.Create('Invalid Ct (' + IntToStr(Ct) + ')');
  
  result := '';
  StringList := TStringList.Create;
  try
    StringList.Text := ObjectToXMLElements(self);
    for Index := Start to Start+Ct-1 do
    begin
      StringList.Add(Items[Index].XML);
    end;
    result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

class function TXMLCollection.getTagName: string;
begin
  result := Copy(ClassName, 2, Pos('Collection', ClassName) - 2) + '-list';
end;

function TXMLCollection.GetXML: string;
begin
  result := '<' + getTagName + '>' + ElementText + '</' + getTagName + '>';
end;


function TXMLCollection.GetXMLCollectionItem(Index:Integer): TXMLCollectionItem;
begin
  Result := inherited Items[Index] as TXMLCollectionItem;
end;

procedure TXMLCollection.LoadFromFile(FileName:string);
begin
  XML := LoadStringFromFile(FileName);
end;

procedure TXMLCollection.SaveToFile(FileName:string);
begin
  SaveStringToFile(cs_XMLProlog+XML, FileName);
end;

procedure TXMLCollection.SetElementText(const p_sXML: string);
var
  CurrentTagIndex, OverAllIndex: Integer;
  CollectionItemName, CurrentTag, CurrentTagContent: string;
begin
  Clear;
  
  CollectionItemName := GetItemTagName;
  
  CurrentTagIndex := 1;
  OverallIndex := 1;
  repeat
    CurrentTag := FastParseTag(p_sXML, '<' , '>', OverallIndex);
    CurrentTagContent := FastParseTagXML(p_sXML,  CurrentTag, CurrentTagIndex);
  
    if (Length(CurrentTag) > 0) then
    begin
      if (CurrentTag = CollectionItemName) then
        Add.ElementText := CurrentTagContent
      else
        SetPropAsString(Self, GetPropInfo(ClassInfo, CurrentTag), CurrentTagContent);
    end;
  
    OverAllIndex := CurrentTagIndex;
  until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML));
end;

procedure TXMLCollection.SetXML(const p_sXML: string);
begin
  ElementText := GetTagContent(p_sXML, getTagName);
end;

procedure TXMLCollection.SetXMLCollectionItem(Index:Integer; Value: 
        TXMLCollectionItem);
begin
  inherited SetItem(Index, Value);
end;

procedure TXMLCollection.Sort(Compare: TListSortCompare);
  
  procedure CollectionQuickSort(L, R: Integer);
  var
    I, J: Integer;
    P: TXMLCollectionItem;
  begin
    repeat
      I := L;
      J := R;
      P := Items[(L + R) shr 1];
      repeat
  
        while (Compare(Items[I], P) < 0) and (i < self.Count-1) do
          Inc(I);
  
        while (Compare(Items[J], P) > 0) do
          Dec(J);
  
        if I <= J then
        begin
  
          if I <> J then
          begin
            Items[J].Index := I;
            Items[I+1].Index := J;
          end;
  
          Inc(I);
          Dec(J);
        end;
  
      until I > J;
      if L < J then
        CollectionQuickSort(L, J);
      L := I;
    until I >= R;
  end;
  
begin
  if Count > 0 then
    CollectionQuickSort(0, Count-1);
end;

{
****************************** TXMLCollectionItem ******************************
}
function TXMLCollectionItem.getDTDElements: string;
begin
  result := getObjectDTDElements(self);
end;

function TXMLCollectionItem.getDTDSequence: string;
begin
  result := getObjectDTDSequence(self);
end;

function TXMLCollectionItem.GetElementText: string;
begin
  result := ObjectToXMLElements(self);
end;

class function TXMLCollectionItem.getTagName: string;
begin
  result := Copy(ClassName, 2, Pos('Collection', ClassName) - 2);
end;

function TXMLCollectionItem.GetXML: string;
begin
  result := '<' + getTagName + '>' + ElementText + '</' + getTagName + '>';
end;

function TXMLCollectionItem.getXMLAsProperties: string;
begin
  result := '<' + getTagName + ' ' + ObjectToXMLProperties(self) + ' />'
end;

procedure TXMLCollectionItem.SetElementText(const p_sXML: string);
begin
  SetXMLObject(Self, p_sXML);
end;

procedure TXMLCollectionItem.SetXML(const p_sXML: string);
begin
  ElementText := GetTagContent(p_sXML, getTagName);
end;

{
********************************** TXMLObject **********************************
}
constructor TXMLObject.Create(p_sXML: String = '');
begin
  inherited Create;
  if p_sXML <> '' then
    XML := p_sXML;
end;

function TXMLObject.GetDTD: string;
begin
  result := cs_DocTypeHeader + getTagName + ' [' + #13#10 +
            cs_ElementHeader + getTagName + ' (' + getDTDSequence + ') >' + #13#10 +
            getDTDElements + ']>'
end;

function TXMLObject.getDTDElements: string;
begin
  result := getObjectDTDElements(self);
end;

function TXMLObject.getDTDSequence: string;
begin
  result := getObjectDTDSequence(self);
end;

function TXMLObject.GetElementText: string;
begin
  result := ObjectToXMLElements(self);
end;

class function TXMLObject.getTagName: string;
begin
  result := Copy(ClassName, 2, Length(ClassName) - 1);
end;

function TXMLObject.GetXML: string;
begin
  result := '<' + getTagName + '>' + ElementText + '</' + getTagName + '>';
end;

procedure TXMLObject.LoadFromFile(FileName:string);
begin
  XML := LoadStringFromFile(FileName);
end;

procedure TXMLObject.SaveToFile(FileName:string);
begin
  SaveStringToFile(XML, FileName);
end;

procedure TXMLObject.SetElementText(const p_sXML: string);
begin
  SetXMLObject(Self, p_sXML);
end;

procedure TXMLObject.SetXML(const p_sXML: string);
begin
  ElementText := GetTagContent(p_sXML, getTagName);
end;

{
***************************** TXMLInterfacedObject *****************************
}
constructor TXMLInterfacedObject.Create(p_sXML: String = '');
begin
  inherited Create;
  if p_sXML <> '' then
    XML := p_sXML;
end;

function TXMLInterfacedObject.getDTDElements: string;
begin
  result := getObjectDTDElements(self);
end;

function TXMLInterfacedObject.getDTDSequence: string;
begin
  result := getObjectDTDSequence(self);
end;

function TXMLInterfacedObject.GetElementText: string;
begin
  result := ObjectToXMLElements(self);
end;

class function TXMLInterfacedObject.getTagName: string;
begin
  result := Copy(ClassName, 2, Length(ClassName) - 1);
end;

function TXMLInterfacedObject.GetXML: string;
begin
  result := '<' + getTagName + '>' + ElementText + '</' + getTagName + '>';
end;

procedure TXMLInterfacedObject.LoadFromFile(FileName:string);
begin
  XML := LoadStringFromFile(FileName);
end;

procedure TXMLInterfacedObject.SaveToFile(FileName:string);
begin
  SaveStringToFile(XML, FileName);
end;

procedure TXMLInterfacedObject.SetElementText(const p_sXML: string);
begin
  SetXMLObject(Self, p_sXML);
end;

procedure TXMLInterfacedObject.SetXML(const p_sXML: string);
begin
  ElementText := GetTagContent(p_sXML, getTagName);
end;

{
*********************************** TXMLList ***********************************
}
function TXMLList.getDTDElements: string;
begin
  result := getObjectDTDElements(self);
end;

function TXMLList.getDTDSequence: string;
begin
  result := getObjectDTDSequence(self);
  if result = '' then
    result := getItemTagName + '*'
  else
    result := getItemTagName + '*, ' + result;
end;

function TXMLList.GetElementText: string;
var
  Index: Integer;
  StringList: TStringList;
  ItemTagName: string;
begin
  result := '';
  ItemTagName := getItemTagName;
  StringList := TStringList.Create;
  try
    StringList.Text := ObjectToXMLElements(self);
    for Index := 0 to Count-1 do
    begin
      StringList.Add('<' + ItemTagName + '>' + Strings[Index] + '</' + ItemTagName + '>');
    end;
    result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

class function TXMLList.getItemTagName: string;
begin
  result := cs_XMLLIST_itemTagName;
end;

class function TXMLList.getTagName: string;
begin
  { TMYLIST -> MYLIST }
  result := Copy(ClassName, 2, Length(ClassName) - 2);
end;

function TXMLList.GetXML: string;
begin
  result := '<' + getTagName + '>' + ElementText + '</' + getTagName + '>';
end;

procedure TXMLList.SetElementText(const p_sXML: string);
var
  CurrentTagIndex, OverAllIndex: Integer;
  ItemTagName, CurrentTag, CurrentTagContent: string;
begin
  Clear;
  
  ItemTagName := getItemTagName;
  
  CurrentTagIndex := 1;
  OverallIndex := 1;
  repeat
    CurrentTag := FastParseTag(p_sXML, '<' , '>', OverallIndex);
    CurrentTagContent := FastParseTagXML(p_sXML, CurrentTag, CurrentTagIndex);
  
    if (Length(CurrentTag) > 0) then
    begin
      if (CurrentTag = ItemTagName) then
        Add(CurrentTagContent)
      else
        SetPropAsString(Self, GetPropInfo(ClassInfo, CurrentTag), CurrentTagContent);
    end;
  
    OverAllIndex := CurrentTagIndex;
  until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML));
end;

procedure TXMLList.SetXML(const p_sXML: string);
begin
  ElementText := GetTagContent(p_sXML, getTagName);
end;


end.