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!