Dot net framework for Delphi?

One idea that has been lurking in the back of my head regarding the QTX framework, is that we could – actually, simply implements a light version of the dot net framework instead.

I realize that this may be anathema to many people, and the first question will no doubt be “why” rather than “how”, but it does make sense from a purely strategic point of view.

• It makes porting software from C# easier
• To some degree simplified coding style (read: easier)
• Many powerful concepts which object pascal lacks
• Benefit of both worlds: object pascal and the dot net theorem

To see if this would work even on a conceptual level I decided to implement the System.Object class in object pascal. To get the benefit of garbage collection I have derived the base class from TPersistent and implemented IInterface. Destruction of un-managed resources are under the dot net framework ensured destruction through IDisposable, which I also added.

As most people know, objects that uses reference-counting can be harder to work with under native languages. If you place them in an object-list and expects them to survive you are in for a surprise, because even though TObjectList retains the pointer the instance is released.

To avoid this I have implemented the IRetainable interface. So remember to invoke the RetainObject() method. Calling RetainObject() ensures that an element self-references; read: will never automatically release itself because the reference counter never reaches zero.

Well, here is the unit. If anyone else is interested in implementing the dot net framework in Delphi then let me know, we could setup a repository and work together on it.

unit qtx.system;

interface

uses  System.Sysutils, 
      System.Classes, 
      System.rtti,
      System.TypInfo;

type

  EQTXObject  = Class(Exception);

  (* Exception classes *)
  EQTXObjectAlreadyRetained = Class(EQTXObject);
  EQTXObjectNotRetained     = Class(EQTXObject);
  EQTXObjectRetained        = Class(EQTXObject);
  EQTXObjectCloneFailed     = Class(EQTXObject);

  (* Forward declarations *)
  TQTXObject                = Class;
  TQTXPersistent            = Class;
  TQTXSerializationInfo     = Class;
  
  IDisposable = interface
    ['{56714944-F3D0-43C9-8C4B-F2F00BA5F83D}']
    procedure Dispose;
  end;

  IRetainedObject = Interface
    ['{27B152DC-6553-4309-8C51-2B5C7D89A9EB}']
    procedure RetainObject;
    procedure ReleaseObject;
  end;

  ICloneable = interface
    ['{6BAB94D0-32B9-4C4C-9D71-4C88AA9E6D0B}']
    function  Clone:TQTXObject;
  end;

  ISerializable = interface
    ['{FAD5405E-34B8-4264-8F8D-EE2A0D257213}']
    function  GetObjectData:TQTXSerializationInfo;
  end;

  TQTXObject = Class(TPersistent,IRetainedObject)
  strict private
    FRefCount:  Integer;
    FRetained:    Boolean;
  strict protected
    procedure CloneProperties(aSource,aTarget:TQTXObject;
              Recursive:Boolean=False);
  strict protected
    Property  RefCount:Integer read FRefCount;
  strict protected
    { IInterface }
    function _AddRef: Integer;virtual;stdcall;
    function _Release: Integer;virtual;stdcall;
  strict protected
    procedure RetainObject;virtual;
    procedure ReleaseObject;virtual;
  public
    function CloneMemberWise(var aClone):Boolean;

    procedure Finalize;virtual;
    
    class function  ReferenceEquals(const ObjA,ObjB:TQTXObject):Boolean;
    class function  GetHashCode:Longword;reintroduce;
    class function  GetType:TClass;

    function  ToString:String;override;

    Procedure Free;reintroduce;virtual;

  public
    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;

    Procedure BeforeDestruction;Override;
    Procedure AfterConstruction;Override;
  end;

    (* See: http://msdn.microsoft.com/en-us/library/
            system.runtime.serialization.serializationinfo(v=vs.110).aspx
       For member info
    *)
  TQTXSerializationInfo = Class(TQTXObject)
  end;  

  TQTXPersistent = Class(TQTXObject,ICloneable,ISerializable)
  strict protected
    (* ICloneable *)
    function  Clone:TQTXObject;
  strict protected
    (* ISerializable *)
    function  GetObjectData:TQTXSerializationInfo;virtual;
  end;
  
implementation

uses brage;

//#############################################################################
// TQTXPersistent
//#############################################################################

function  TQTXPersistent.GetObjectData:TQTXSerializationInfo;
begin
  result:=TQTXSerializationInfo.Create;
end;

function TQTXPersistent.Clone:TQTXObject;
var
  mClass: TClass;
begin
  result:=NIL;
  mClass:=getType;
  if mClass<>NIl then
  Begin
    (* Create instance *)
    result:=TQTXObject(mClass.Create);

    (* Do a recursive "deep-copy" of the object properties *)
    try
      cloneProperties(self,result,true);
    except
      on e: exception do
      begin
        freeAndNIL(result);
        Raise EQTXObjectCloneFailed.CreateFmt
        ('Failed to clone %s, method %s threw exception %s with message %s',
        [self.ClassType.ClassName,'Clone',e.ClassName,e.Message]);
      end;
    end;
  end;
end;      

//#############################################################################
// TQTXObject
//#############################################################################

Procedure TQTXObject.AfterConstruction;
begin
  inherited;
  AtomicDecrement(FRefCount);
end;

Procedure TQTXObject.BeforeDestruction;
Begin
  if RefCount <> 0 then
  Error(reInvalidPtr);
    
  Finalize;
  inherited;
end;    

Procedure TQTXObject.Free;
Begin
  if FRetained then
  Raise EQTXObjectRetained.Create
  ('Object is retained and cannot be released error');
  Inherited free;
end;    

function TQTXObject._AddRef: Integer;
begin
  Result := AtomicIncrement(FRefCount);
end;

procedure TQTXObject.RetainObject;
Begin
  (* Prevent automatic release through self-increment *)
  if not FRetained then
  FRetained:=_addRef>0 else
  raise EQTXObjectAlreadyRetained.Create
  ('Object is already marked as retained error'); 
end;

procedure TQTXObject.ReleaseObject;
Begin
  if FRetained then
  _release else
  raise EQTXObjectNotRetained.Create
  ('Object is not retained error');
end;    

function TQTXObject._Release: Integer;
begin
  (* Note: Delphi calls destroy directly, but since we want to
     be in tune with future possible changes to the VCL/FMX where
     free is expanded, I decided to invoke that instead *)
  Result := AtomicDecrement(FRefCount);
  if result<1 then
  free;
end;

function TQTXObject.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;


(* This is the dot net variation of "beforedestruction". I have included
   it for completeness and compatability only. It is invoked from
   beforedestruction. Also, this is where IDisposable is checked for *)
Procedure TQTXObject.Finalize;
var
  mAccess:  IDisposable;
begin
  (* Release unmanaged data *)
  if getInterface(IDisposable,mAccess) then
  mAccess.Dispose;
end;

function TQTXObject.ToString:String;
Begin
  result:=self.ClassType.ClassName;
end;    

class function TQTXObject.ReferenceEquals(const ObjA,ObjB:TQTXObject):Boolean;
Begin
  result:=(objA<>NIL)
  and (objB<>NIL)
  and (objA = objB);
end;    

class function TQTXObject.GetHashCode:longword;
begin
  result:=brage.TBRBuffer.ElfHash(ClassName);
end;    

class function TQTXObject.GetType:TClass;
var
  ctx: TRttiContext;
  objType: TRttiType;
begin
  result:=NIL;
  ctx := TRttiContext.Create;
  objType := ctx.GetType(ClassInfo);
  if (objType<>NIL)
  and (objType.AsInstance<>NIL) then
  result:=objType.AsInstance.ClassType;
end;

procedure TQTXObject.CloneProperties(aSource,aTarget:TQTXObject;
          Recursive:Boolean=False);
var
  numProps, I : Integer;
  props: PPropList;
  PropInfo: PPropInfo;
  src:  TObject;
  dst:  TObject;
Begin
  numProps := GetPropList(aSource, props );
  Try
    For I := 0 To numProps - 1 Do Begin
      PropInfo := props^[I];
      Case PropInfo^.PropType^.Kind Of
        tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
          SetOrdProp(aTarget,propinfo,GetOrdProp(aSource,propinfo));
        tkFloat:
          SetFloatProp(aTarget,propinfo,GetFloatProp(aSource,propinfo));
        tkString,
        tkLString,
        tkUString:
          SetStrProp( aTarget, propinfo,GetStrProp( aSource, propinfo));
        tkWString:
          SetWideStrProp(aTarget,propinfo,GetWideStrProp(aSource,propinfo));
        tkMethod:
          SetMethodProp(aTarget,propinfo,GetMethodProp(aSource,propinfo));
        tkInt64:
          SetInt64Prop(aTarget,propinfo,GetInt64Prop(aSource,propinfo));
        tkVariant:
          SetVariantProp(aTarget,propinfo,GetVariantProp(aSource,propinfo));
        tkInterface:
          SetInterfaceProp(aTarget,propinfo,GetInterfaceProp(aSource,propinfo));
        tkClass:
          Begin
            if Recursive then
            Begin
            
              src := GetObjectProp( aSource, propinfo );
              If Assigned( src ) Then
              Begin
                If src Is TComponent Then
                SetObjectProp( aTarget, propinfo, src ) else
                If src Is TPersistent Then
                Begin
                  if src<>self then
                  begin
                    dst := GetObjectProp( aTarget, propinfo, TPersistent);
                    if dst<>self then
                    begin
                      If Assigned( dst ) Then
                      TPersistent( dst ).Assign( TPersistent(src));
                    end;
                  end;
                End;
              End;
            
            end;
          End;
      tkArray,
      tkRecord,
      tkDynArray:
        begin
        end
      end;
    end;
  Finally
    FreeMem( props );
  End;
end;    

function TQTXObject.CloneMemberWise(var aClone):Boolean;
var
  mClass: TClass;
begin
  NativeInt(aClone):=0;
  result:=False;

  mClass:=getType;
  if mClass<>NIl then
  Begin
    TQTXObject(pointer(aClone)):=TQTXObject(mClass.Create);

    (* Do a recursive "deep-copy" of the object properties *)
    try
      cloneProperties(self,TQTXObject(pointer(aClone)),false);
    except
      on e: exception do
      begin
        freeAndNIL(result);
        Raise EQTXObjectCloneFailed.CreateFmt
        ('Failed to clone %s, method %s threw exception %s with message %s',
        [self.ClassType.ClassName,'CloneMemberWise',e.ClassName,e.Message]);
      end;
    end;
    //cloneProperties(self,TQTXObject(pointer(aClone)));
    result:=NativeInt(aClone)<>0;
  end;
end;    

end.

Enjoy!