Object cloning using the high level RTTI

Someone’s probably demoed this before, and quite possibly demoed it better too, but hey, here’s my idea of generic object cloning using the high level RTTI. To be honest, in practice, I’m not sure this sort of thing – i.e., a completely generalised approach – is a very good idea, as indeed the small workarounds given for handling components and controls indicates. Makes a neat demo though I think:

unit ObjectClone;

interface

type
  TObjectClone = record
    class function From<T: class>(Source: T): T; static;
  end;

implementation

uses
  SysUtils, Classes, TypInfo, RTTI, Controls;

class function TObjectClone.From<T>(Source: T): T;
var
  Context: TRttiContext;
  IsComponent, LookOutForNameProp: Boolean;
  RttiType: TRttiType;
  Method: TRttiMethod;
  MinVisibility: TMemberVisibility;
  Params: TArray<TRttiParameter>;
  Prop: TRttiProperty;
  SourceAsPointer, ResultAsPointer: Pointer;
begin
  RttiType := Context.GetType(Source.ClassType);
  //find a suitable constructor, though treat components specially
  IsComponent := (Source is TComponent);
  for Method in RttiType.GetMethods do
    if Method.IsConstructor then
    begin
      Params := Method.GetParameters;
      if Params = nil then Break;
      if (Length(Params) = 1) and IsComponent and
         (Params[0].ParamType is TRttiInstanceType) and
         SameText(Method.Name, 'Create') then Break;
    end;
  if Params = nil then
    Result := Method.Invoke(Source.ClassType, []).AsType<T>
  else
    Result := Method.Invoke(Source.ClassType, [TComponent(Source).Owner]).AsType<T>;
  try
    //many VCL control properties require the Parent property to be set first
    if Source is TControl then TControl(Result).Parent := TControl(Source).Parent;
    //loop through the props, copying values across for ones that are read/write
    Move(Source, SourceAsPointer, SizeOf(Pointer));
    Move(Result, ResultAsPointer, SizeOf(Pointer));
    LookOutForNameProp := IsComponent and (TComponent(Source).Owner <> nil);
    if IsComponent then
      MinVisibility := mvPublished //an alternative is to build an exception list
    else
      MinVisibility := mvPublic;
    for Prop in RttiType.GetProperties do
      if (Prop.Visibility >= MinVisibility) and Prop.IsReadable and Prop.IsWritable then
        if LookOutForNameProp and (Prop.Name = 'Name') and
          (Prop.PropertyType is TRttiStringType) then
          LookOutForNameProp := False
        else
          Prop.SetValue(ResultAsPointer, Prop.GetValue(SourceAsPointer));
  except
    Result.Free;
    raise;
  end;
end;

end.

The XXXAsPointer thing is to get around a compiler bug/limitation, though the rest of it is perfectly clean code.

To try it out, create a new VCL application, add a button and set its Align property to alLeft, its AlignWithMargins property to True, its Caption to ‘Clone Me!’ and its Name to ‘btnClone’, before assigning its OnClick handler to be as thus:

uses ObjectClone;

procedure TForm1.btnCloneClick(Sender: TObject);
var
  NewButton: TButton;
begin
  NewButton := TObjectClone.From(btnClone);
end;

The local variable is just for clarity – you can remove it if you prefer. Run the application, and you should get something like this in a few clicks:

That said, don’t bother suggesting I use a ‘stream out and back in again’ approach instead since I already know about it. 😉

Postscript: while I’m about it, I thought I’d add a Delphi example to Wikipedia’s ‘Reflection (computer programming)’ page. Here’s the code I added (it’s on the model of the examples for the other languages listed there):

uses RTTI, Unit1;

procedure WithoutReflection;
var
  Foo: TFoo;
begin
  Foo := TFoo.Create;
  try
    Foo.Hello;
  finally
    Foo.Free;
  end;
end;

procedure WithReflection;
var
  RttiContext: TRttiContext;
  RttiType: TRttiInstanceType;
  Foo: TObject;
begin
  RttiType := RttiContext.FindType('Unit1.TFoo') as TRttiInstanceType;
  Foo := RttiType.GetMethod('Create').Invoke(RttiType.MetaclassType, []).AsObject;
  try
    RttiType.GetMethod('Hello').Invoke(Foo, []);
  finally
    Foo.Free;
  end;
end;

Whether it stays there is another matter I guess!