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.

Advertisements