One Man’s Use for RTTI and Attributes in Delphi XE

This post was published to JSBlog at 2:01:44 PM 1/1/2011

One Man’s Use for RTTI and Attributes in Delphi XE

 

 

I started the code and classes for a Facebook native client. I’m writing the client in Delphi XE Pro, which I love. One of the things I wanted to do with this app is abstract away the database persistence as a built-in part of the object hierarchy. Thanks to RTTI and Attributes this has been quite doable. I use NexusDB for the database backend, so I wrote a routine that creates a TnxDataDictionary for any object, by looking at the attributes of the object’s properties or defaulting to a given column definition based on the property’s type. I also wrote code to save and retreive objects into and out of the NexusDB database. So the first thing was to set up my custom attributes class, and a non-DB-specific set of data type constants (this is so that it will be easy if I ever need to swap out NexusDB for another database):

 

const

jsAutoInc = integer(nxtAutoInc); jsString = integer(nxtWideString); jsInteger = integer(nxtInt32);

jsInt64 = integer(nxtInt64); jsDateTime = integer(nxtDatetime); jsBoolean = integer(nxtBoolean); jsBlob = integer(nxtBlob);

jsDouble = integer(nxtDouble); jsSingle = integer(nxtSingle); jsSmallInt = integer(nxtInt16); jsSet = integer(nxtWord32);

type

TjsnDataAttribute = class(TCustomAttribute)

private

FDataName: string;

FDataSize: Integer;

FDataType: Integer;

FIndexed: boolean;

FRequired: Boolean;

public

constructor Create(ADataName: string; ADataType: integer; ADataSize:

Integer = 0; AIndexed: Boolean = false; ARequired: boolean = false);

property DataName: string read FDataName write FDataName;

property DataSize: Integer read FDataSize write FDataSize;

property DataType: Integer read FDataType write FDataType;

property Indexed: boolean read FIndexed write FIndexed;

property Required: Boolean read FRequired write FRequired;

end;

 

 

Then I can create my persistent objects as descendents of a common TFacebookObject class that knows how to populate itself from JSON strings, using attributes to specify the database settings for each property to be persisted to/from the database. Here’s an example:

 

TFacebookObject = class(TInterfacedObject, IFacebookObject)
...
  public
    [TjsnDataAttribute('ID_', jsString, 256, true)]
    property ID_: string read GetID_ write SetID_;
    [TjsnDataAttribute('ID_CRC', jsInt64, 20, true)]
    property ID_CRC: LongInt read GetID_CRC write SetID_CRC;
    [TjsnDataAttribute('JSON', jsBlob)]
    property JSON: string read GetJSON write SetJSON;
    property NeedFullDownload_: Boolean read GetNeedFullDownload_ write
        SetNeedFullDownload_;
  end;

This associates a TjsnDataAttribute with the ID_, ID_CRC and JSON properties so that the ID_ property gets saved to the database as a string field of length 256 that is indexed, the ID_CRC gets saved as an indexed Int64 field, and thde JSON field gets saved to a blob field. Incidentally, the NeedFullDownload_ property is also persisted, but uses a default data type declaration for boolean fields. I’ve got logic in the persistence code to persist all public properties that end in an underscore. This is so I can add public properties later that don’t get persisted (I simply don’t end them in an underline).  I use this attribute information in three different places in my code: one to create the database table needed to store the object, one to read the object out of the database and another to save the object to the database.

 

Let’s look at the database table generation first, since that has to occur first in time. My existing application infrastructure automatically updates the embedded NexusDB database whenever I change it in the code. I have an integer constant that represents the database version, so whenever I increment that constant in my code, the application will look at the current database in use and update it according to the changes. It scans through all the existing tables and does a “restructure” using a new data dictionary which  is compared with the existing data dictionary. If a table was unchanged, it doesn’t get restructured. If it was non-existent or different, that table is restructured using the new data dictionary. I had a lot of newsreader code and tables that were grandfathered into this project and the data dictionaries for those tables were generated manually by code that looked liked this:

 

function __Newsgroup( aDatabase: TnxDatabase ): TnxDataDictionary;
begin
  Result := TnxDataDictionary.Create;
  try
    with Result do
    begin
      with FilesDescriptor do
        with FileDescriptor[0] do
          BlockSize := nxbs8K;
      AddRecordDescriptor( TnxBaseRecordDescriptor );
      with FieldsDescriptor do
      begin
        AddField( 'NewsgroupId', '', nxtAutoInc, 10, 0, False );
        AddField( 'Name', '', nxtWideString, 512, 0, False );
        AddField( 'Description', '', nxtBLOB, 0, 0, False );
        AddField( 'LastUpdate', '', nxtDateTime, 0, 0, False );
        AddField( 'MsgLo', '', nxtInt32, 10, 0, False );
        AddField( 'MsgHi', '', nxtInt32, 10, 0, False );
        AddField( 'LastMsgHi', '', nxtInt32, 10, 0, False );
        AddField( 'NNTPServerId', '', nxtInt32, 10, 0, False );
        AddField( 'LastDLMsgHi', '', nxtInt32, 10, 0, False );
        AddField( 'LastDLUpdate', '', nxtDateTime, 0, 0, False );
        AddField( 'DefaultSignatureId', '', nxtInt32, 10, 0, False );
        AddField( 'DefaultAliasId', '', nxtInt32, 10, 0, False );
        AddField( 'MessageControls', '', nxtBLOB, 0, 0, False );
        AddField( 'MessageControlUpdate', '', nxtDateTime, 0, 0, False );
        AddField( 'Name_CRC', '', nxtInt64, 20, 0, False );
        AddField( 'DefaultMessageFilterId', '', nxtInt32, 10, 0, False );
        AddField( 'LastPost', '', nxtDateTime, 0, 0, False );
        AddField( 'New', '', nxtBoolean, 0, 0, False );
        AddField( 'ExpiryDays', '', nxtInt32, 10, 0, False );
        AddField( 'LastPurge', '', nxtDateTime, 0, 0, False );
        AddField( 'Active', '', nxtBoolean, 0, 0, False );
        //AddField( 'Subscribed', '', nxtBoolean, 0, 0, False );
        AddField( 'Filter', '', nxtBLOB, 0, 0, False );
        AddField( 'MessageCache', '', nxtBLOB, 0, 0, False );
        AddField( 'DirtyMessageCache', '', nxtBoolean, 0, 0, False );
      end;
      with EnsureIndicesDescriptor do
      begin
        with AddIndex( 'PK', 0, idNone ), KeyDescriptor as TnxCompKeyDescriptor do
          Add( GetFieldFromName( 'NewsgroupId' ) );
        with AddIndex( 'UK', 0, idNone ), KeyDescriptor as TnxCompKeyDescriptor do
        begin
          Add( GetFieldFromName( 'Name_CRC' ) );
          Add( GetFieldFromName( 'NNTPServerId' ) );
        end;
        with AddIndex( 'XK', 0, idNone ), KeyDescriptor as TnxCompKeyDescriptor do
        begin
          Add( GetFieldFromName( 'NNTPServerId' ) );
          Add( GetFieldFromName( 'Name' ) );
        end;
        DefaultIndex := GetIndexFromName( 'PK' );
      end;
      CheckValid( False );
    end;
  except
    FreeAndNil( Result );
    raise ;
  end;
end;

 

If I needed to change the metadata for a given table, I went into the code and updated it. This worked reasonably well, but it was easy for the metadata to get out of kilter with the code that used the table and such mismatches of course always are run-time errors, not compiler errors. I have a philosophy that errors should be as efficiently noticed as possible while you are developing, so that you have a great incentive to fix them ASAP. Run-time errors are not as efficient to locate and identify as compiler errors, and it is not really very OO to have data definitions in two different places, one of which is so far away from where the data  is actually used. Thus it wasn’t a design with which I was ultimately happy. I didn’t want to spend hundreds of dollars on an ORM, or take my chances with half-finished open-source code, so I rolled my own object model using RTTI and attributes, which have been available in Delphi since the 2010 version.

 

Here is the code that creates a TnxDataDictionary from an object:

 

/// Use TjsnDataAttributes for the object's properties to override the defaults
/// for the field parameters
function CreateDictionaryForObject(AClass: TObject): TnxDataDictionary;
var
  aDict: TnxDataDictionary;
  ctx: TRttiContext;
  LClassName: string;
  LName: string;
  LTableName: string;
  p: TRttiProperty;
  t: TRTTIType;
  a : TCustomAttribute;
  LDataType: integer;
  LFoundAttributes: Boolean;
  LIndexed: Boolean;
  LRequired: Boolean;
  LSize: Int64;

begin
  LFoundAttributes := False;
  LRequired := false;
  LIndexed := false;
  LSize := 0;
  LTableName := RightStr( AClass.ClassName, Length(AClass.ClassName)-1 );

  aDict := TnxDataDictionary.Create;
  aDict.AddRecordDescriptor( TnxBaseRecordDescriptor );

  //add primary key
  aDict.FieldsDescriptor.AddField(LTableName+'Id', '', nxtAutoInc, 10, 0, false);
      with aDict.EnsureIndicesDescriptor do
        with AddIndex( 'PK', 0, idNone ), KeyDescriptor as TnxCompKeyDescriptor do
          Add( aDict.GetFieldFromName( LTableName+'Id' ) );

  //ensure fields
  ctx := TRttiContext.Create;
  try
    t := ctx.GetType(AClass.ClassType);
    if t <> nil then
    begin
      for p in t.GetProperties do
      begin
        LName := p.Name;
        LClassName := p.PropertyType.Name;
        //ensure field

        LFoundAttributes := False;

        //get attributes if they exist, use them to set data type and size
        for a in p.GetAttributes do
        begin
          if a is TjsnDataAttribute then
          begin
            LName := (a as TjsnDataAttribute).DataName;
            LSize := (a as TjsnDataAttribute).DataSize;
            LDataType := (a as TjsnDataAttribute).DataType;
            LIndexed := (a as TjsnDataAttribute).Indexed;
            LRequired := (a as TjsnDataAttribute).Required;
            aDict.FieldsDescriptor.AddField( LName, '', TnxFieldType(LDataType), LSize, 0, LRequired );
            if LIndexed then
            begin
              with aDict.EnsureIndicesDescriptor do
                with AddIndex( LName+'_NDX', 0, idAll ), KeyDescriptor as TnxCompKeyDescriptor do
                  Add( aDict.GetFieldFromName( LName ) );
            end;
            LFoundAttributes := true;
          end;
        end;

        if (LName[Length(LName)] = '_') or
          (SameText(LName, 'JSON')) or
          (SameText(LName, 'ID_CRC'))then
        begin
          //if no attributes, then try using RTTI directly...
          {$REGION 'DefaultProcessing'}
          if not LFoundAttributes then
          begin
            if SameText(LClassname, 'TDateTime') then
            begin
              aDict.FieldsDescriptor.AddField( LName, '', nxtDateTime, 0, 0, False );
            end else
            if SameText(LClassname, 'Boolean') then
            begin
              aDict.FieldsDescriptor.AddField( LName, '', nxtBoolean, 0, 0, False );
            end else
            if SameText(Lname, 'JSON') then
            begin
              aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
            end else
            if SameText(Lname, 'ID_') then
            begin
              aDict.FieldsDescriptor.AddField( LName, '', nxtWideString, 512, 0, False );
            end else
            if SameText(Lname, 'ID_CRC') then
            begin
              aDict.FieldsDescriptor.AddField( LName, '', nxtInt64, 20, 0, False );
              with aDict.EnsureIndicesDescriptor do
              with AddIndex( 'UK', 0, idNone ), KeyDescriptor as TnxCompKeyDescriptor do
              begin
                Add( aDict.GetFieldFromName( LName ) );
              end;

            end else
            case p.PropertyType.TypeKind of
              tkInteger: aDict.FieldsDescriptor.AddField( LName, '', nxtInt32, 10, 0, False );
              tkChar: aDict.FieldsDescriptor.AddField( LName, '', nxtChar, 10, 0, False );
              tkEnumeration: aDict.FieldsDescriptor.AddField( LName, '', nxtInt32, 10, 0, False );
              tkFloat: aDict.FieldsDescriptor.AddField( LName, '', nxtDouble, 10, 0, False );
              tkString: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkSet: aDict.FieldsDescriptor.AddField( LName, '', nxtInt32, 10, 0, False );
              tkClass: aDict.FieldsDescriptor.AddField( LName, '', nxtInt64, 20, 0, False );
              tkWChar: aDict.FieldsDescriptor.AddField( LName, '', nxtWideChar, 10, 0, False );
              tkLString: aDict.FieldsDescriptor.AddField( LName, '', nxtNullString, 256, 0, False );
              tkWString: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkVariant: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkInt64: aDict.FieldsDescriptor.AddField( LName, '', nxtInt64, 20, 0, False );
              tkDynArray: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkUString: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkPointer: aDict.FieldsDescriptor.AddField( LName, '', nxtInt32, 10, 0, False );
              tkRecord: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkArray: aDict.FieldsDescriptor.AddField( LName, '', nxtBlob, 10, 0, False );
              tkProcedure, tkMethod, tkClassRef, tkInterface, tkUnknown: begin
                end;
              else

            end;
          end;
          {$ENDREGION}
        end;
      end;
    end;
  finally
    ctx.Free;
  end;
  result := aDict;
end;

 

This code will create a NexusDB table that matches the layout of the TFacebookObject descendent class. I can change the definitions of my object properties and their associated attributes and the next automatic database update at app start up with restructure the existing user’s database to the new layout. If I add a new class, all I need to do to get it persisted in the database is to add the class to my procedure that creates and uses data dictionaries:

 

procedure BuildAndEvolveFacebookTables(aDatabase: TjsnDatabase; const
    aPassword: String; aProgressCallback: TjsnProgressCallback; CancelTask:
    boolean);

  procedure EnsureTable(aObj: TObject);
  begin
    BuildAndEvolveDatabaseTableForObject(AObj, aDatabase, aPassword, aProgressCallback, CancelTask);
    FreeAndNil(aObj);
  end;

begin

  EnsureTable(TFacebookAction.Create);
  EnsureTable(TFacebookAlbum.Create);
  EnsureTable(TFacebookApplication.Create);
  ...
end;

(That code is in the FacebookObject unit, not the database generation unit. This way I was able to keep my TFacebookObject implementation classes private to the FacebookObject unit, exposing only interfaces and factory methods to the rest of the world.) Over in the database generation unit, I have the BuildAndEvolveDatabaseTableForObject function thta brings us to the above-quoted CreateDictionaryForObject function:

 

procedure BuildAndEvolveDatabaseTableForObject(AObject: TObject; aDatabase:
    TnxDatabase; const aPassword: String; aProgressCallback:
    TnxcgProgressCallback; CancelTask: Boolean);
var
  aDict: TnxDataDictionary;
  LTableName: string;
begin
  aDict := CreateDictionaryForObject( AObject );
  try
    LTableName := RightStr(AObject.ClassName, Length(AObject.ClassName) - 1);
    BuildAndEvolveTableByDict( aDatabase, LTableName, aPassword, aDict, aProgressCallback, CancelTask );
  finally
    //aDict.Free;
  end;
end;

 

Having thus ensured the database metadata for my object hierarchy, I can then use RTTI and attributes to get the objects into and out of the created or updated tables. TFacebookObject knows how to stream itself into and out of thes tables, and since it uses RTTI and attributes, all of its decendents automatically inherit this capability without having to do anything more themselves. (Attributes of inherited elements are also inherited.) For example, here is how I load an object from a dataset:

 

procedure TFacebookObject.LoadFromDataset(qry: TDataset);
var
  a: TCustomAttribute;
  ctx: TRttiContext;
  I: Integer;
  LBlobStream: TStream;
  LBuffer: TBytes;
  LDataType: Integer;
  LField: TField;
  LFieldName: string;
  LFoundAttributes: Boolean;
  LName: string;
  LValue: TValue;
  p: TRttiProperty;
  t: TRTTIType;
begin
  {$IFDEF DEBUG}
  CodeSite.EnterMethod( Self, 'TFacebookObject.LoadFromDataset' );
  try
  {$ENDIF}
    //iterate through properties, finding matching fields by attributes if they are present...
       ctx := TRttiContext.Create;
        try
          t := ctx.GetType(self.ClassInfo);
          if t <> nil then
          begin
            for p in t.GetProperties do
            begin
              LName := p.Name;
              LFoundAttributes := False;
              for a in p.GetAttributes do
              begin
                if a is TjsnDataAttribute then
                begin
                  LFieldName := tjsnDataAttribute(a).DataName;
                  LDataType := tjsnDataAttribute(a).DataType;
                  LField := qry.FieldByName(LFieldName);
                  if LField <> nil then
                  begin
                    case LDataType of
                    jsAutoInc: LValue := LField.AsInteger;
                    jsString: LValue := LField.AsString;
                    jsInteger: LValue := LField.AsInteger;
                    jsInt64: LValue := LField.AsLargeInt;
                    jsDateTime: LValue := LField.AsDateTime;
                    jsBoolean: LValue := LField.AsBoolean;
                    jsBlob: begin
                      LBlobStream := qry.CreateBlobStream(LField, bmRead);
                      try
                        SetLength(LBuffer, LBlobStream.Size);
                        LBlobStream.ReadBuffer(LBuffer, LBlobStream.Size);
                      finally
                        LBlobStream.Free;
                      end;
                      LValue := TValue.From<TBytes>(LBuffer);
                    end;
                    jsDouble: LValue := LField.AsFloat;
                    jsSingle: LValue := LField.AsSingle;
                    jsSmallInt: LValue := LField.AsInteger;
                    jsSet: LValue := LField.AsInteger;
                    else
                      LValue := TValue.FromVariant( LField.AsVariant );
                    end;
                    LFoundAttributes := true;
                    p.SetValue(self, LValue);
                  end;
                end;
              end;
              if not LFoundAttributes then
              begin
                LFieldname := LName;
                if (RightStr(LFieldName, 1) = '_') or (LFieldName = 'JSON') or (LFieldName = 'ID_CRC') then
                begin
                  LValue := TValue.FromVariant( qry.Fields[I].Value );
                  p.SetValue(self, LValue);
                end;
              end;

            end;
          end;
        finally
          ctx.Free;
        end;
  {$IFDEF DEBUG}
  finally
    CodeSite.ExitMethod( Self, 'TFacebookObject.LoadFromDataset' );
  end;
  {$ENDIF}
end;

Feel free to comment, offer improvements, etc.

 

Advertisement