xmlcollections.pas

delphi的XMPRPC通讯例子

  SaveStringToFile(XML, FileName);
end;

procedure TXMLInterfaceCollectionItem.SetCollection(Value: 
        TXMLInterfaceCollection);
begin
  if FCollection <> Value then
  begin
    if FCollection <> nil then FCollection.RemoveItem(Self);
    if Value <> nil then Value.InsertItem(Self);
  end;
end;

procedure TXMLInterfaceCollectionItem.SetDisplayName(const Value: string);
begin
  Changed(False);
end;

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

procedure TXMLInterfaceCollectionItem.SetIndex(Value: Integer);
var
  CurIndex: Integer;
begin
  CurIndex := GetIndex;
  if (CurIndex >= 0) and (CurIndex <> Value) then
  begin
    FCollection.Move(CurIndex, Value);
    Changed(True);
  end;
end;

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

function TXMLInterfaceCollectionItem._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TXMLInterfaceCollectionItem._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

{
*************************** TXMLInterfaceCollection ****************************
}
constructor TXMLInterfaceCollection.Create(ItemClass: 
        TXMLInterfaceCollectionItemClass);
begin
  FItemClass := ItemClass;
  FItems := TList.Create;
  fIDList := TIntegerList.Create;
end;

destructor TXMLInterfaceCollection.Destroy;
begin
  FUpdateCount := 1;
  if FItems <> nil then
    Clear;
  FItems.Free;
  fIDList.Free;
  
  inherited Destroy;
end;

function TXMLInterfaceCollection.Add: IUnknown;
begin
  Result := FItemClass.Create(Self) as IUnknown;
end;

procedure TXMLInterfaceCollection.AfterConstruction;
begin
  // Release the constructor's implicit refcount
  InterlockedDecrement(FRefCount);
end;

procedure TXMLInterfaceCollection.Assign(Source: TPersistent);
begin
  {
  if Source is TXMLInterfaceCollectionItem then
  begin
    BeginUpdate;
    try
      Clear;
      for I := 0 to TCollection(Source).Count - 1 do
        TXMLInterfaceCollectionItem(Add).Assign(TXMLInterfaceCollectionItem(TXMLInterfaceCollection(Source).Items[I]));
    finally
      EndUpdate;
    end;
    Exit;
  end;
  }
  inherited Assign(Source);
end;

procedure TXMLInterfaceCollection.BeforeDestruction;
begin
  if RefCount <> 0 then
    raise Exception.Create('Free must not be explicity called on an interfaced object');
end;

procedure TXMLInterfaceCollection.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TXMLInterfaceCollection.Changed;
begin
  if FUpdateCount = 0 then
    Update(nil);
end;

procedure TXMLInterfaceCollection.Clear;
begin
  if FItems.Count > 0 then
  begin
    BeginUpdate;
    try
      while FItems.Count > 0 do
        Delete(FItems.Count-1);
      fIDList.Clear;
    finally
      EndUpdate;
    end;
  end;
end;

procedure TXMLInterfaceCollection.Delete(Index: Integer);
begin
  TXMLInterfaceCollectionItem(FItems[Index]).Collection := nil;
end;

procedure TXMLInterfaceCollection.EndUpdate;
begin
  Dec(FUpdateCount);
  Changed;
end;

function TXMLInterfaceCollection.FindItemID(ID: Integer): 
        TXMLInterfaceCollectionItem;
begin
  result := fItems[fIDList[ID]];
end;

function TXMLInterfaceCollection.GetAttr(Index: Integer): string;
begin
  Result := '';
end;

function TXMLInterfaceCollection.GetAttrCount: Integer;
begin
  Result := 0;
end;

function TXMLInterfaceCollection.GetCount: Integer;
begin
  Result := FItems.Count;
end;

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

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

function TXMLInterfaceCollection.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 + '>' + TXMLInterfaceCollectionItem(Items[Index]).ElementText + '</' + CollectionItemName + '>');
    end;
    result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

function TXMLInterfaceCollection.GetItem(Index: Integer): IUnknown;
begin
  Result := TXMLInterfaceCollectionItem(FItems[Index]) as IUnknown;
end;

function TXMLInterfaceCollection.GetItemAttr(Index, ItemIndex: Integer): string;
begin
  Result := TXMLInterfaceCollectionItem(Items[ItemIndex]).DisplayName;
end;

function TXMLInterfaceCollection.getItemTagName: string;
begin
  result := ItemClass.getTagName;
end;

function TXMLInterfaceCollection.GetNamePath: string;
var
  S, P: string;
begin
  Result := ClassName;
  if GetOwner = nil then
    Exit;
  
  S := GetOwner.GetNamePath;
  
  if S = '' then
    Exit;
  
  P := PropName;
  if P = '' then
    Exit;
  
  Result := S + '.' + P;
end;

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

function TXMLInterfaceCollection.GetPropName: string;
var
  I: Integer;
  Props: PPropList;
  TypeData: PTypeData;
  Owner: TPersistent;
begin
  Result := FPropName;
  Owner := GetOwner;
  if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit;
  TypeData := GetTypeData(Owner.ClassInfo);
  if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
  GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
  try
    GetPropInfos(Owner.ClassInfo, Props);
    for I := 0 to TypeData^.PropCount-1 do
    begin
      with Props^[I]^ do
        if (PropType^^.Kind = tkClass) and
          (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then
          FPropName := Name;
    end;
  finally
    Freemem(Props);
  end;
  Result := FPropName;
end;

function TXMLInterfaceCollection.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(TXMLInterfaceCollectionItem(Items[Index]).XML);
    end;
    result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

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

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

function TXMLInterfaceCollection.Insert(Index: Integer): IUnknown;
begin
  Result := Add;
  TXMLInterfaceCollectionItem(Result).Index := Index;
end;

procedure TXMLInterfaceCollection.InsertItem(Item: TXMLInterfaceCollectionItem);
begin
  if not (Item is FItemClass) then
    raise EXMLInterfaceException.Create('Invalid Collection Item class - ' + Item.ClassName);
  
  // Force Ref Counting while in list
  Item._AddRef;
  Item.FCollection := Self;
  Item.FID := fIDList.Count;
  
  fIDList.Add(FItems.Add(Item));
end;

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

procedure TXMLInterfaceCollection.Move(CurIndex, NewIndex: Integer);
var
  I: Integer;
begin
  if CurIndex <> NewIndex then
  begin
    fItems.Move(CurIndex, NewIndex);
    if CurIndex > NewIndex then // Resort from New To Cur
      for i := NewIndex to CurIndex do
        fIDList[TXMLInterfaceCollectionItem(fItems[i]).fID] := i
    else
      for i := CurIndex to NewIndex do
        fIDList[TXMLInterfaceCollectionItem(fItems[i]).fID] := i
  end;
end;

class function TXMLInterfaceCollection.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TXMLInterfaceCollection(Result).FRefCount := 1;
end;

function TXMLInterfaceCollection.QueryInterface(const IID: TGUID; out Obj): 
        HResult;
  
  const
    E_NOINTERFACE = HResult($80004002);
  
begin
  if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;

procedure TXMLInterfaceCollection.RemoveItem(Item: TXMLInterfaceCollectionItem);
var
  X, OldID, OldIndex: Integer;
begin
  OldID := Item.fID;
  OldIndex := fIDList[OldID];
  
  
  for x := OldIndex to Count-1 do
    Dec(fIDList.FList^[TXMLInterfaceCollectionItem(fItems[X]).fID]);
  
  
  fIDList.Delete(OldID);
  FItems.Delete(OldIndex);
  
  for x := OldID to Count-1 do
    Dec(TXMLInterfaceCollectionItem(fItems[fIDList[X]]).fID);
  
  Item.FCollection := nil;
  Item._Release;
end;

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

procedure TXMLInterfaceCollection.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
        TXMLInterfaceCollectionItem(Add).ElementText := CurrentTagContent
      else
        SetPropAsString(Self, GetPropInfo(ClassInfo, CurrentTag), CurrentTagContent);
    end;
  
    OverAllIndex := CurrentTagIndex;
  until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML));
end;

procedure TXMLInterfaceCollection.SetItem(Index: Integer; Value: IUnknown);
begin
  //TXMLInterfaceCollectionItem(FItems[Index]).AssignIntf(Value);
  assert(false, 'Not implemented');
  { TODO : Do a query interface for some custom intf, then .Assign ... }
end;

procedure TXMLInterfaceCollection.SetItemName(Item: 
        TXMLInterfaceCollectionItem);
begin
end;

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

procedure TXMLInterfaceCollection.Update(Item: TXMLInterfaceCollectionItem);
begin
end;

function TXMLInterfaceCollection._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TXMLInterfaceCollection._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

{
************************* TXMLOwnedInterfaceCollection *************************
}
constructor TXMLOwnedInterfaceCollection.Create(AOwner: TPersistent; ItemClass: 
        TXMLInterfaceCollectionItemClass);
begin
  FOwner := AOwner;
  inherited Create(ItemClass);
end;

function TXMLOwnedInterfaceCollection.GetOwner: TPersistent;
begin
  result := FOwner;
end;

{
***************************** TXMLOwnedCollection ******************************
}
constructor TXMLOwnedCollection.Create(AOwner: TPersistent; ItemClass: 
        TXMLCollectionItemClass);
begin
  FOwner := AOwner;
  inherited Create(ItemClass);
end;

function TXMLOwnedCollection.GetOwner: TPersistent;
begin
  result := FOwner;
end;


end.