Persistent Polymorphic Lists in Delphi

Question

I need a list of polymorphic objects (different object classes, but with a common base class) that I can 'persist' as part of a form file.

TList isn't persistent, and TCollection isn't polymorphic.

I can probably roll my own but prefer not to reinvent the wheel. Ideas?

Answer 1

For using default streaming framework you have to create wrapper collection item that can hold and create object instances of different classes.

unit PolyU;

interface

uses
  System.SysUtils,
  System.Classes;

type
  TWrapperItem = class(TCollectionItem)
  protected
    FObjClassName: string;
    FObjClass: TPersistentClass;
    FObj: TPersistent;
    procedure SetObjClass(Value: TPersistentClass);
    procedure SetObjClassName(Value: string);
    procedure SetObj(Value: TPersistent);
    function CreateObject(OClass: TPersistentClass): Boolean; dynamic;
  public
    property ObjClass: TPersistentClass read FObjClass write SetObjClass;
  published
    // ObjClassName must be published before Obj to trigger CreateObject
    property ObjClassName: string read FObjClassName write SetObjClassName;
    property Obj: TPersistent read FObj write SetObj;
  end;

implementation

procedure TWrapperItem.SetObjClass(Value: TPersistentClass);
begin
  if Value <> FObjClass then
    begin
      FObj := nil;
      FObjClass := Value;
      if Value = nil then FObjClassName := ''
      else FObjClassName := Value.ClassName;
      CreateObject(FObjClass);
    end;
end;

procedure TWrapperItem.SetObjClassName(Value: string);
begin
  if Value <> FObjClassName then
    begin
      FObj := nil;
      FObjClassName := Value;
      if Value = '' then FObjClass := nil
      else FObjClass := FindClass(Value);
      CreateObject(FObjClass);
    end;
end;

procedure TWrapperItem.SetObj(Value: TPersistent);
begin
  FObj := Value;
  if Assigned(Value) then
    begin
      FObjClassName := Value.ClassName;
      FObjClass := TPersistentClass(Value.ClassType);
    end
  else
    begin
      FObjClassName := '';
      FObjClass := nil;
    end;
end;

function TWrapperItem.CreateObject(OClass: TPersistentClass): Boolean;
begin
  Result := false;
  if OClass = nil then exit;
  try
    FreeAndNil(FObj);
    if OClass.InheritsFrom(TCollectionItem) then FObj := TCollectionItem(TCollectionItemClass(OClass).Create(nil))
    else
    if OClass.InheritsFrom(TComponent) then FObj := TComponentClass(OClass).Create(nil)
    else
    if OClass.InheritsFrom(TPersistent) then FObj := TPersistentClass(OClass).Create;
    Result := true;
  except
  end;
end;

end.

Classes that are going to be wrapped by TWrapperItem have to be registered with Delphi streaming system via RegisterClass or RegisterClasses methods.

Following test component contains base collection that can be edited and streamed through IDE. For more control it is possible that you may want to write custom IDE editors, but this is base to start from.

unit Unit1;

interface

uses
  System.Classes,
  PolyU;

type
  TFoo = class(TPersistent)
  protected
    FFoo: string;
  published
    property Foo: string read FFoo write FFoo;
  end;

  TBar = class(TPersistent)
  protected
    FBar: integer;
  published
    property Bar: integer read FBar write FBar;
  end;

  TTestComponent = class(TComponent)
  protected
    FList: TOwnedCollection;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property List: TOwnedCollection read FList write FList;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Test', [TTestComponent]);
end;

constructor TTestComponent.Create(AOwner: TComponent);
begin
  inherited;
  FList := TOwnedCollection.Create(Self, TWrapperItem);
end;

destructor TTestComponent.Destroy;
begin
  Flist.Free;
  inherited;
end;

initialization

  RegisterClasses([TFoo, TBar]);

finalization

  UnRegisterClasses([TFoo, TBar]);

end.

This is how streamed TTestComponent (as part of Form) can look like:

  object TestComponent1: TTestComponent
    List = <
      item
        ObjClassName = 'TFoo'
        Obj.Foo = 'abc'
      end
      item
        ObjClassName = 'TBar'
        Obj.Bar = 5
      end>
    Left = 288
    Top = 16
  end