xmlcollections.pas

delphi的XMPRPC通讯例子

unit XMLCollections;

interface

uses SysUtils, Classes, XMLWorks2;

type
  PIntList = ^TIntList;
  TIntList = array[0..MaxListSize - 1] of Integer;

  TXMLInterfaceCollectionItemClass = class of TXMLInterfaceCollectionItem;

  TXMLInterfaceCollection = class;
  TIntegerList = class (TObject)
  private
    FCapacity: Integer;
    FCount: Integer;
    FList: PIntList;
  protected
    function Get(Index: Integer): Integer;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: Integer);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    destructor Destroy; override;
    function Add(Item: Integer): Integer;
    procedure Clear; virtual;
    procedure Delete(Index: Integer);
    class procedure Error(Msg: string; Data: Integer); overload;
    procedure Exchange(Index1, Index2: Integer);
    function Extract(Item: Integer): Integer;
    function First: Integer;
    function IndexOf(Item: Integer): Integer;
    procedure Insert(Index: Integer; Item: Integer);
    function Last: Integer;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: Integer): Integer;
    property Capacity: Integer read FCapacity write SetCapacity;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: Integer read Get write Put; default;
    property List: PIntList read FList;
  end;
  
  TXMLInterfaceCollectionItem = class (TPersistent, IUnknown, IXMLWorksObject)
  private
    FCollection: TXMLInterfaceCollection;
    FID: Integer;
    procedure SetCollection(Value: TXMLInterfaceCollection);
  protected
    FRefCount: Integer;
    procedure Changed(AllItems: Boolean);
    function GetDisplayName: string; virtual;
    function GetElementText: string; virtual;
    function GetIndex: Integer;
    function GetOwner: TPersistent; override;
    function GetXML: string;
    function getXMLAsProperties: string;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    procedure SetDisplayName(const Value: string); virtual;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetIndex(Value: Integer); virtual;
    procedure SetXML(const p_sXML: string);
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    constructor Create(Collection: TXMLInterfaceCollection); virtual;
    destructor Destroy; override;
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    function getDTDElements: string;
    function getDTDSequence: string;
    function GetNamePath: string; override;
    class function getTagName: string; virtual;
    procedure LoadFromFile(FileName:string);
    class function NewInstance: TObject; override;
    procedure SaveToFile(FileName:string);
    property Collection: TXMLInterfaceCollection read FCollection write 
            SetCollection;
    property DisplayName: string read GetDisplayName write SetDisplayName;
    property ElementText: string read GetElementText write SetElementText;
    property ID: Integer read FID;
    property Index: Integer read GetIndex write SetIndex;
    property RefCount: Integer read FRefCount;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLInterfaceCollection = class (TPersistent, IUnknown, IXMLWorksObject)
  private
    fIDList: TIntegerList;
    FItemClass: TXMLInterfaceCollectionItemClass;
    FItems: TList;
    FPropName: string;
    FUpdateCount: Integer;
    function GetCount: Integer;
    function GetPropName: string;
    procedure InsertItem(Item: TXMLInterfaceCollectionItem);
    procedure RemoveItem(Item: TXMLInterfaceCollectionItem);
  protected
    FRefCount: Integer;
    procedure Changed;
    function GetAttr(Index: Integer): string; dynamic;
    function GetAttrCount: Integer; dynamic;
    function GetElementText: string; virtual;
    function GetItem(Index: Integer): IUnknown;
    function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
    function GetXML: string;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetItem(Index: Integer; Value: IUnknown);
    procedure SetItemName(Item: TXMLInterfaceCollectionItem); virtual;
    procedure SetXML(const p_sXML: string);
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    property PropName: string read GetPropName write FPropName;
    property UpdateCount: Integer read FUpdateCount;
  public
    constructor Create(ItemClass: TXMLInterfaceCollectionItemClass);
    destructor Destroy; override;
    function Add: IUnknown;
    procedure AfterConstruction; override;
    procedure Assign(Source: TPersistent); override;
    procedure BeforeDestruction; override;
    procedure BeginUpdate; virtual;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure EndUpdate; virtual;
    function FindItemID(ID: Integer): TXMLInterfaceCollectionItem;
    function getDTDElements: string;
    function getDTDSequence: string;
    function getItemTagName: string; virtual;
    function GetNamePath: string; override;
    function getPropertiesXML: string;
    function getSubsetElementText(Start, Ct: Integer): string;
    class function getTagName: string; virtual;
    function Insert(Index: Integer): IUnknown;
    procedure LoadFromFile(FileName:string);
    procedure Move(CurIndex, NewIndex: Integer);
    class function NewInstance: TObject; override;
    procedure SaveToFile(FileName:string);
    procedure Update(Item: TXMLInterfaceCollectionItem); virtual;
    property Count: Integer read GetCount;
    property ElementText: string read GetElementText write SetElementText;
    property ItemClass: TXMLInterfaceCollectionItemClass read FItemClass;
    property Items[Index: Integer]: IUnknown read GetItem write SetItem;
    property RefCount: Integer read FRefCount;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLOwnedInterfaceCollection = class (TXMLInterfaceCollection)
  private
    FOwner: TPersistent;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TPersistent; ItemClass: 
            TXMLInterfaceCollectionItemClass); reintroduce; virtual;
  end;
  
  TXMLOwnedCollection = class (TXMLCollection)
  private
    FOwner: TPersistent;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TXMLCollectionItemClass);
            reintroduce;
  end;
  


implementation
uses
  TypInfo;    // RTTI Stuff


{
********************************* TIntegerList *********************************
}
destructor TIntegerList.Destroy;
begin
  Clear;
end;

function TIntegerList.Add(Item: Integer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then
    Grow;
  FList^[Result] := Item;
  Inc(FCount);
end;

procedure TIntegerList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

procedure TIntegerList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then
    Error('Index out of bounds (%d)', Index);
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(Pointer));
end;

class procedure TIntegerList.Error(Msg: string; Data: Integer);
begin
  raise Exception.CreateFmt(Msg, [Data]);
end;

procedure TIntegerList.Exchange(Index1, Index2: Integer);
var
  Item: Integer;
begin
  if (Index1 < 0) or (Index1 >= FCount) then
    Error('Index out of bounds (%d)', Index1);
  if (Index2 < 0) or (Index2 >= FCount) then
    Error('Index out of bounds (%d)', Index2);
  
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TIntegerList.Extract(Item: Integer): Integer;
var
  I: Integer;
begin
  Result := -1;
  I := IndexOf(Item);
  if I >= 0 then
  begin
    Result := Item;
    Delete(I);
  end;
end;

function TIntegerList.First: Integer;
begin
  Result := Get(0);
end;

function TIntegerList.Get(Index: Integer): Integer;
begin
  if (Index < 0) or (Index >= FCount) then
    Error('Index out of bounds (%d)', Index);
  
  Result := FList^[Index];
end;

procedure TIntegerList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else
    if FCapacity > 8 then
      Delta := 16
    else
      Delta := 4;
  
  SetCapacity(FCapacity + Delta);
end;

function TIntegerList.IndexOf(Item: Integer): Integer;
begin
  Result := 0;
  
  while (Result < FCount) and (FList^[Result] <> Item) do
    Inc(Result);
  
  if Result = FCount then
    Result := -1;
end;

procedure TIntegerList.Insert(Index: Integer; Item: Integer);
begin
  if (Index < 0) or (Index > FCount) then
    Error('Index out of bounds (%d)', Index);
  
  if FCount = FCapacity then
    Grow;
  
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(Pointer));
  
  FList^[Index] := Item;
  
  Inc(FCount);
end;

function TIntegerList.Last: Integer;
begin
  Result := Get(FCount - 1);
end;

procedure TIntegerList.Move(CurIndex, NewIndex: Integer);
var
  Item: Integer;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) or (NewIndex >= FCount) then
      Error('Index out of bounds (%d)', NewIndex);
    Item := Get(CurIndex);
    Delete(CurIndex);
    Insert(NewIndex, Item);
  end;
end;

procedure TIntegerList.Put(Index: Integer; Item: Integer);
begin
  if (Index < 0) or (Index >= FCount) then
    Error('Index out of bounds (%d)', Index);
  
  FList^[Index] := Item;
end;

function TIntegerList.Remove(Item: Integer): Integer;
begin
  Result := IndexOf(Item);
  if Result >= 0 then
    Delete(Result);
end;

procedure TIntegerList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    Error('Invalid Capacity (%d)', NewCapacity);
  
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
    FCapacity := NewCapacity;
  end;
end;

procedure TIntegerList.SetCount(NewCount: Integer);
var
  I: Integer;
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    Error('Invalid NewCount (%d)', NewCount);
  
  if NewCount > FCapacity then
    SetCapacity(NewCount);
  
  if NewCount > FCount then
    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Integer), 0)
  else
    for I := FCount - 1 downto NewCount do
      Delete(I);
  
  FCount := NewCount;
end;

{
************************* TXMLInterfaceCollectionItem **************************
}
constructor TXMLInterfaceCollectionItem.Create(Collection: 
        TXMLInterfaceCollection);
begin
  SetCollection(Collection);
end;

destructor TXMLInterfaceCollectionItem.Destroy;
begin
  SetCollection(nil);
  inherited Destroy;
end;

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

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

procedure TXMLInterfaceCollectionItem.Changed(AllItems: Boolean);
var
  Item: TXMLInterfaceCollectionItem;
begin
  if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  begin
    if AllItems then
      Item := nil
    else
      Item := Self;
  
    FCollection.Update(Item);
  end;
end;

function TXMLInterfaceCollectionItem.GetDisplayName: string;
begin
  Result := ClassName;
end;

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

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

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

function TXMLInterfaceCollectionItem.GetIndex: Integer;
begin
  if FCollection <> nil then
    Result := FCollection.FIDList[ID]
  else
    Result := -1;
end;

function TXMLInterfaceCollectionItem.GetNamePath: string;
begin
  if FCollection <> nil then
    Result := Format('%s[%d]',[FCollection.GetNamePath, Index])
  else
    Result := ClassName;
end;

function TXMLInterfaceCollectionItem.GetOwner: TPersistent;
begin
  Result := FCollection;
end;

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

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

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

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

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

function TXMLInterfaceCollectionItem.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 TXMLInterfaceCollectionItem.SaveToFile(FileName:string);
begin