Delphi for dot net unit
I had a rather long discussion with several members of Delphi developer (Facebook) the other day, mostly in response to be becoming a full-time C# developer (and Delphi developer of-course, that’s not gonna change).
Although we started with debating C# and differences between native object-pascal versus the “curly languages” in general, I ended up saying something that clearly bugged a few, namely: We can actually implement the dot net framework as an alternative to the VCL, written in Delphi itself. There is no technical limitation against it, and it may even benefit object pascal in general – as younger developers are more familiar with dot net than they are the VCL or VJL.
As you probably guess that spawned some interesting comments (nothing bad, important to underline that) – most of the comments along the lines of the task being pointless, technically difficult or just plain impractical.
My reply to this is that you are all wrong (he said with a smile).
First of all, it is not more impractical to use clone of the most evolved, modern run-time-library (framework) than it is to use the VCL. Delphi is in reality suffering great injustice due to the in-grown identification of product, language and RTL as one and the same. In fact, many people are completely spellbound by the concept of object pascal being “Delphi”, that they cannot for their life imagine object pascal with a new RTL.
This is something I have had first-hand experience with, since I wrote the RTL for Smart Mobile Studio and was the first to experience the wave of feedback from both happy and unhappy users. Dont get me wrong, I absolutely love the VCL; It’s component model and class hiearcy has stood the test of time. It scales well, it’s agile – and all the other words we use to describe a living product.
Technical difficulties
Secondly, it is no more a technical challenge to implement the .net framework and use that instead of the VCL – than it would be to write the VCL to begin with. The factor which matters in this case, as it is with software development in general, is time.
But this statement does have some merit, since it’s only recently that object pascal (both Delphi and FPC) have evolved it’s RTTI functionality. This was a requirement to bring generics and “C++ and C#” type RTTI access and management to Delphi. And as always the FPC group followed suit – which we should be thankful for.
The only technical challenges that requires a fair bit of research and testing can be isolated in 3 groups:
- Fundamental differences in serialization
- Object life-time differences
- Native code lacks the ability to emit reflection and alter itself at runtime
Why do it at all?
And last but not least, to the question of why; The answer is that the dot net framework has quickly become the dominant framework. People like to believe that C++ is in the lead here, or even JavaScript which tops the code evolution charts, but that is not the case. The dot net framework is used by millions of programmers every single day, both young and old alike. No other framework has the same level of exposure; Microsoft has successfully installed their framework onto every Windows PC on the planet – and with their recently announced “open source” initiative — the dot net framework will become and important part of Unix, Linux and OS X.
Being able to offer customers a framework they already know – but with a twist: namely that it compiles to native code, fast, relentless and which is emitted as a single executable — is more effective than presenting something utterly alien to young programmers. The same can be done with ordinary .net or mono apps through the executable image tool – which generates a single .exe with no dependencies of your C# code.
Porting over important libraries from C# becomes substantially easier if at least a subset of the dot net framework can be mapped to C# in 1:1 fashion.
C# lacks many of the features which makes object pascal so attractive; A native dot net “clone” RTL, which would replace the VCL completely, would benefit from many of the already existing VCL classes — and also from the language features unique to object pascal.
Proof of concept
To make a long story short; I have implemented a handful of the fundamental dot net classes. I have only spent an afternoon on this, so dont expect miracles, but at least it implements the basic .net serialization engine (the .net framework actually has 3 engines for serialization, few people are aware of that).
And to be frank, it’s already so much more easier to use than vanilla VCL. Now dont start a flame-war because of that statement. I love the VCL and use it every single day — but one of the more time-consuming tasks I can think of, is to write persistent code (if your components expose fields of a non-standard datatype).
A second nail in the proverbial coffin is that Delphi’s persistence is exclusively binary. A lot of frameworks have alternatives for this, like mORMot, Remobjects and TMS’s Aurelius (which I really love, since it’s purely attribute based), but vanilla object pascal as delivered by Embarcadero still ships with TPersistent which havent evolved since it’s inception ages ago.
C# and other .net languages have built in serialization out of the box. It’s a very simple form of serialization, but due to it’s decoupled nature – where property identifier is separated from property data (so you can emit XML text to a binary medium) it’s very effective.
It’s also fully automatic, unless you explicitly turn it off. So under C# you can write a “normal” class as such:
/* Bog standard class. We inherit from ISerializable, and we also tag the class with the "Serializable" attribute */ [Serializable()] public class TMyClass: ISerializable { public int Value { get; set; } public string Name { get; set; } }
The above is identical to this object-pascal code. The VCL rule for persistence is that only published properties are automatically persisted by the VCL, and the property must be a non-complex type (e.g “standard datatypes like integer, string, double and so on). The problem is that you will only be able to load and in Delphi’s custom binary format, which makes it so much harder to work with high-end, industry standard, enterprise level solutions.
In the world of enterprise computing, methods typically take serialized objects as parameters. So instead of shipping in a ton of parameters – you ship in one string which contains an object exposing whatever properties you need.
Delphi does have such a system, buried deep with it’s RPC (remote procedure call) units — but the binary data cannot be made any better. It’s just base-64 encoded.
TMyClass = Class(TPersistent) private FValue:Integer; FName: String; Published Property Value:Integer read FValue write FValue; Property Name:String read FName write FName; End;
As you see from the C# code example, C# has adopted anonymous field declarations. Meaning that you dont define a property field (the actual field to hold a property’s value) by name. It remains anonymous and you simply access the exposed property name. This is a great time saver and it makes sense when you think about it. Smart Pascal implements this, so as of writing SMS is the only object-pascal compiler which allows you to write near identical pascal which maps directly to C#. It also does this without importing weird C++ syntax (let’s face it, generics sticks out like a sore thumb in Delphi). So Smart Pascal is in some ways closer to C# than BCPL; BCPL being the language pascal inherited many ideas from back in the 70’s.
Now when you want to serialize your object, which simply means that you are able to save all published properties automatically to XML, JSON, binary or whatever emitter is available, under C# you would just write:
void saveObjToStream(TMyClass mObject) { /* Use an XML serializer */ XmlSerializer ser = new XmlSerializer(typeof(TMyClass)); /* Setup target buffer */ MemoryStream mBuffer = new MemoryStream(); /* Setup our stream-writer */ TextWriter mWriter = new StreamWriter(mBuffer); /* Save object instance as XML to our memory stream */ ser.Serialize(mWriter, mObject); }
Reasonably straight forward; easy and effective. Delphi’s old TPersistent may be faster due to it’s binary format, but Delphi is suffering because of the binary-only technology which VCL represents. It would be easy to fix this for Embarcadero, but I guess they are focusing more on FMX these days.
Right, with the core .net “object” class implemented (see code below) we are now able to do something very similar:
procedure saveToStream(mObject:TMyClass) var mSerializer: TMSXMLSerializer; mBuffer: TMemoryStream; mWriter: TMSTextWriter; Begin mSerializer:=TMSXMLSerializer; end;
This is very different from how Delphi has traditionally dealt with serialization. TPersistent dispatches the job of writing data onto the component itself. This is very effective when dealing with large trees of objects and sub-objects (although stack hungry for very large structures). But be that as it may, Delphi’s TWriter and TReader is a binary affair from beginning to end. Which means Delphi serialization (as Embarcadero shipts it) cant play ball with the big-boys who exclusively use XML (even for parameters in DLL’s or ORMS).
Manual serialization
While the .net framework has the simple “automatic” serialization technique i demonstrated above, which is suitable for web services, databases and remote procedure calls — the .net framework actually has 3 different persistent serialization engines.
The second version is more hands-on and functions pretty much like Delphi’s TPersistent does. With one exception and that is a proxy object is used to register properties manually; This is where the TMSSerializationInfo class comes in.
When manually using this variation you simply derive a new class from TMSObject and implement the ISerializable interface. The system will then call on the GetObjectData() when needed to obtain a property dictionary, then that dictionary is used to either stream out RTTI information (the properties defined in the dictionary) or write properties to an instance.
Well, enough blabber from me — he is the “work in progress” code so you can see for yourself. I will probably finish it laster at some point, I am working on Smart Mobile Code at the moment.
unit qtx.system; interface uses System.Sysutils, System.Classes, System.rtti, System.TypInfo, System.Generics.Collections; type EQTXObject = Class(Exception); (* Exception classes *) EQTXObjectAlreadyRetained = Class(EQTXObject); EQTXObjectNotRetained = Class(EQTXObject); EQTXObjectRetained = Class(EQTXObject); EQTXObjectCloneFailed = Class(EQTXObject); EQTXObjectRTTIQueryFailed = Class(EQTXObject); (* Forward declarations *) TQTXObject = Class; TQTXPersistent = Class; TQTXSerializationInfo = Class; //TQTXObjectPropertyInfo = Class; //TQTXObjectPropertyInfoList = Class; TCharArray = packed array of char; TByteArray = packed array of byte; 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; TQTXObjectPropertyInfoList = Class; TQTXObjectPropertyInfo = Class(TObject) private FName: String; FDataType: TTypeKind; FParent: TQTXObjectPropertyInfoList; public Property PropertyName:String read FName write FName; property PropertyType:TTypeKind read FDataType write FDataType; function asString:String; constructor Create(Parent:TQTXObjectPropertyInfoList);virtual; end; TQTXObjectPropertyInfoList = class(TObjectList<TQTXObjectPropertyInfo>) private FInstance: TQTXObject; public Property Instance:TQTXObject read FInstance; function ToString:String;override; constructor Create(Instance:TQTXObject);reintroduce;virtual; end; (* IRTTIProvider = interface ['{6C3113DE-BAFD-46D1-9596-C1397991F02F}'] function queryPropertyInfo(var aList:TQTXObjectPropertyInfoList):Boolean; function getPropertyValue(aName:String;var data;buffLen:Integer):Boolean; end; *) ISomeThing = Interface function queryPropertyInfo(var aList:TQTXObjectPropertyInfoList):Boolean; function getPropertyValue(aName:String;var Data:PByte;buffLen:Integer):Boolean; end; TQTXObject = Class(TPersistent,IRetainedObject) strict private FRefCount: Integer; FRetained: Boolean; public function queryPropertyInfo(var list:TQTXObjectPropertyInfoList):Boolean; function getPropertyValue(aName:String; var data:Pointer; var buffLen:Integer):Boolean; strict protected procedure CloneProperties(aSource,aTarget:TQTXObject; Recursive:Boolean=False); class function ElfHash(const aData;aLength:Integer):LongWord;overload; class function ElfHash(const aText:String):LongWord;overload; 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; TQTXWriter = Class(TQTXObject) private FStream: TStream; strict protected procedure WriteBinary(const data;dataLen:Integer); public procedure Write(value:Boolean);overload;virtual; procedure Write(value:byte);overload;virtual; procedure Write(value:TByteArray);overload;virtual; procedure Write(value:char);overload;virtual; procedure Write(value:TCharArray);overload;virtual; procedure Write(value:String);overload;virtual; procedure Write(value:Integer);overload;virtual; procedure Write(value:word);overload;virtual; procedure Write(Value:Longword);overload;virtual; procedure Write(Value:double);overload;virtual; Procedure Write(Value:Int64);overload;virtual; constructor Create(target:TStream);virtual; destructor Destroy;Override; end; TQTXTextWriter = Class(TQTXWriter) strict protected Procedure WriteText(value:String); public procedure Write(value:Boolean);override; procedure Write(value:byte);override; procedure Write(value:TByteArray);override; procedure Write(value:char);override; procedure Write(value:TCharArray);override; procedure Write(value:String);override; procedure Write(value:Integer);override; procedure Write(value:word);override; procedure Write(Value:Longword);override; procedure Write(Value:double);override; Procedure Write(Value:Int64);override; end; TQTXReader = class(TQTXObject) end; TQTXTextReader = Class(TQTXReader) End; TQTXSerializer = Class(TQTXObject) public procedure Serialize(writer:TQTXWriter;const instance:TQTXObject);virtual;abstract; procedure DeSerialize(reader:TQTXReader;const instance:TQTXObject);virtual;abstract; end; TQTXXMLSerializer = Class(TQTXSerializer) public procedure Serialize(writer:TQTXWriter;const instance:TQTXObject);override; procedure DeSerialize(reader:TQTXReader;const instance:TQTXObject);override; end; TQTXBinarySerializer = Class(TQTXSerializer) End; TQTXPersistent = Class(TQTXObject,ICloneable,ISerializable) strict protected (* ICloneable *) function Clone:TQTXObject; strict protected (* ISerializable *) function GetObjectData:TQTXSerializationInfo;virtual; end; implementation class function TQTXObject.ElfHash(const aData;aLength:Integer):LongWord; var i: Integer; x: Cardinal; FSrc: PByte; Begin Result:=0; If aLength>0 then Begin FSrc:=@aData; for i:=1 to aLength do begin Result := (Result shl 4) + FSrc^; x := Result and $F0000000; if (x <> 0) then Result := Result xor (x shr 24); Result := Result and (not x); inc(FSrc); end; end; end; class function TQTXObject.ElfHash(const aText:String):LongWord; var FAddr: Pointer; FLen: Integer; Begin Result:=0; FLen:=Length(aText); If FLen>0 then Begin FAddr:=@aText[1]; Result:=ElfHash(FAddr^,FLen * Sizeof(Char)); end; end; //############################################################################# // TQTXObjectPropertyInfo //############################################################################# constructor TQTXObjectPropertyInfo.Create(Parent:TQTXObjectPropertyInfoList); begin inherited Create; FParent:=Parent; end; function TQTXObjectPropertyInfo.asString:String; var mStr: String; mInt: Integer; mInt64: Int64; mSize: Integer; mPTR: Pointer; mEnum: longword; mVar: Variant; begin setLength(result,0); if FParent<>NIL then begin if FParent.Instance<>NIL then Begin case FDataType of tkString, tkLString, tkUString: Begin mSize:=0; repeat inc(mSize,1024); setLength(mStr,mSize); fillchar(mStr[1],mSize,#0); mPTR:=pointer(@mStr[1]); until FParent.Instance.getPropertyValue(FName,mPTR,mSize); result:=QuotedStr(strPas(PChar(mPTR))); setLength(mStr,0); end; tkInteger: Begin mPTR:=@mInt; mSize:=SizeOf(Integer); FParent.Instance.getPropertyValue(FName,mPTR,mSize); result:=IntToStr(mInt); end; tkInt64: Begin mPTR:=@mInt64; mSize:=SizeOf(Int64); FParent.Instance.getPropertyValue(FName,mPTR,mSize); result:=IntToStr(mInt64); end; tkEnumeration: Begin mPTR:=@mEnum; mSize:=SizeOf(Longword); FParent.Instance.getPropertyValue(FName,mPTR,mSize); if mSize=SizeOf(Boolean) then result:=boolToStr(PBoolean(mPTR)^,true) else Begin result:='[Enumeration]'; end; end; tkVariant: Begin mPTR:=@mVar; mSize:=SizeOf(Variant); FParent.Instance.getPropertyValue(FName,mPTR,mSize); result:=string(mVar); end; end; end; end; end; //############################################################################# // TQTXObjectPropertyInfoList //############################################################################# constructor TQTXObjectPropertyInfoList.Create(Instance:TQTXObject); Begin inherited Create(True); FInstance:=Instance; end; function TQTXObjectPropertyInfoList.ToString:String; var x: Integer; Begin setLength(result,0); for x:=0 to Count-1 do Begin result:=result + Items[x].PropertyName + '=' + items[x].asString; if x<(count-1) then result:=result + #13; end; end; //############################################################################# // TQTXXMLSerializer //############################################################################# procedure TQTXXMLSerializer.Serialize (writer:TQTXWriter;const instance:TQTXObject); Begin if assigned(writer) then begin if assigned(instance) then Begin end; end; end; procedure TQTXXMLSerializer.DeSerialize (reader:TQTXReader;const instance:TQTXObject); Begin end; //############################################################################# // TQTXTextWriter //############################################################################# Procedure TQTXTextWriter.WriteText(value:String); Begin if length(value)>0 then Begin Value:=Value + #13#10; FStream.Write(value[1],length(value) * SizeOf(Char)); end; end; procedure TQTXTextWriter.Write(value:Boolean); Begin WriteText(BoolToStr(value,true)); end; procedure TQTXTextWriter.Write(value:byte); Begin WriteText('$' + IntToHex(Value,2)); end; procedure TQTXTextWriter.Write(value:TByteArray); var x: Integer; Begin if length(value)>0 then for x:=low(value) to high(value) do Write(Value[x]); end; procedure TQTXTextWriter.Write(value:char); Begin FStream.Write(Value,SizeOf(Char)); end; procedure TQTXTextWriter.Write(value:TCharArray); var x: Integer; Begin if length(Value)>0 then for x:=low(Value) to high(Value) do FStream.Write(Value[x],SizeOf(Char)); end; procedure TQTXTextWriter.Write(value:String); Begin WriteText(Value); end; procedure TQTXTextWriter.Write(value:Integer); Begin WriteText(IntToStr(Value)); end; procedure TQTXTextWriter.Write(value:word); Begin WriteText('$' + IntToHex(Value,4)); end; procedure TQTXTextWriter.Write(Value:Longword); Begin WriteText('$' + IntToHex(Value,8)); end; procedure TQTXTextWriter.Write(Value:double); Begin WriteText(FloatToStr(Value)); end; Procedure TQTXTextWriter.Write(Value:Int64); Begin WriteText(IntToStr(value)); end; //############################################################################# // TQTXWriter //############################################################################# constructor TQTXWriter.Create(target:TStream); Begin inherited Create; FStream:=target; end; destructor TQTXWriter.Destroy; Begin inherited; end; procedure TQTXWriter.WriteBinary(const data;dataLen:Integer); Begin FStream.Write(data,dataLen); end; procedure TQTXWriter.Write(value:Boolean); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(value:byte); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(value:TByteArray); Begin if length(value)>0 then WriteBinary(value,length(value)); end; procedure TQTXWriter.Write(value:char); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(value:TCharArray); Begin if length(value)>0 then WriteBinary(Value,SizeOf(Char) * Length(Value)); end; procedure TQTXWriter.Write(value:String); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(value:Integer); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(value:word); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(Value:Longword); Begin WriteBinary(Value,sizeOf(Value)); end; procedure TQTXWriter.Write(Value:double); Begin WriteBinary(Value,sizeOf(Value)); end; Procedure TQTXWriter.Write(Value:Int64); Begin WriteBinary(Value,sizeOf(Value)); end; //############################################################################# // 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:=TQTXObject.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; function TQTXObject.getPropertyValue(aName:String; var Data:Pointer; var buffLen:Integer):Boolean; var numProps, I : Integer; props: PPropList; PropInfo: PPropInfo; mInfo: TQTXObjectPropertyInfo; mText: String; mLen: Integer; Begin result:=False; if (Data<>NIL) and (BuffLen>0) then Begin numProps := GetPropList(self, props); try if numProps>0 then begin for i:=0 to numProps-1 do begin PropInfo := props^[I]; if sameText(String(PropInfo^.Name),aName) then Begin case propInfo^.PropType^.Kind of tkInteger: Begin if BuffLen>=SizeOf(Integer) then Begin Integer(data):=GetOrdProp(self,propinfo); BuffLen:=SizeOf(Integer); end; break; end; tkChar: begin if BuffLen>=SizeOf(char) then Begin PChar(data)^:=Char ( GetOrdProp(self,propinfo) ); BuffLen:=SizeOf(Char); end; break; end; tkEnumeration, tkSet, tkWChar: Begin if PropInfo^.PropType^ = TypeInfo(boolean) then Begin if BuffLen>=SizeOf(Boolean) then begin PBoolean(Data)^:=Boolean(GetOrdProp(self,propinfo)); BuffLen:=SizeOf(Boolean); break; end; end; if BuffLen>=SizeOf(longword) then Begin PLongword(data)^:=GetOrdProp(self,propinfo); BuffLen:=SizeOf(Longword); end; break; end; tkFloat: Begin if BuffLen>=SizeOf(Double) then Begin PDouble(data)^:=GetOrdProp(self,propinfo); BuffLen:=SizeOf(Double); end; break; end; tkString, tkLString, tkUString: begin mText:=GetStrProp(self,propinfo); mLen:=length(mText) * SizeOf(Char); if BuffLen>=mLen then Begin move(mText[1],data^,mLen); BuffLen:=mLen; end; break; end; tkInt64: Begin if BuffLen>=SizeOf(Char) * Length(mText) then Begin PInt64(data)^:=GetInt64Prop(self,propinfo); BuffLen:=SizeOf(Int64); end; break; end; tkVariant: begin if BuffLen>=SizeOf(variant) then Begin PVariant(Data)^:=getVariantProp(self,PropInfo); BuffLen:=SizeOf(Variant); end; break; end; (* tkInterface: begin break; end; tkMethod: Begin break; end; *) end; end; end; result:=(BuffLen>0); end; finally FreeMem(props); end; end; end; function TQTXObject.queryPropertyInfo (var list:TQTXObjectPropertyInfoList):Boolean; var numProps, I : Integer; props: PPropList; PropInfo: PPropInfo; mInfo: TQTXObjectPropertyInfo; Begin list:=NIL; result:=False; numProps := GetPropList(self, props); try if numProps>0 then begin list:=TQTXObjectPropertyInfoList.Create(self); for i:=0 to numProps-1 do begin PropInfo := props^[i]; if not (PropInfo^.PropType^.Kind in [tkClass,tkArray,tkRecord,tkDynArray]) then Begin mInfo:=TQTXObjectPropertyInfo.Create(list); mInfo.PropertyName:=propInfo^.Name; mInfo.PropertyType:=PropInfo^.PropType^.Kind; list.Add(mInfo); end; end; if list.Count<1 then freeAndNIL(list); result:=list<>NIL; end; finally FreeMem(props); end; 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.
Is that some special IDE plugin you are using that makes keywords start with upper or lowercase randomly? :p
No it’s free, its called dyslexia 🙂
Are you implementing from scratch or binding to existing .Net assemblies?
Implementing from scratch in object pascal. But it’s just an experiment for fun, nothing i will put to much time into. But it’s a fun exercise to see what object pascal can do with a different body to run with