JSON persistence, when a classtype is only known at runtime

One of the cool things about Delphi is that there are usually many different ways of solving a problem.

When I write code I try to make it as simple as I can. There was a time where I would jump in and try to speed things up with assembler, use exit in for/next loops to avoid setting the result more than absolutely necessary and try to squeeze every last drop of performance out of my PC.

But what about those cases where you don’t know, where you have a large inheritance chain involving many classes – all of which can be serialized and have parent/child relationships impossible to predict?

But as you grow a little bit older and perhaps a tiny bit more mature (ahem, at my rate I’ll hit puberty sometime next year) you start to value different things. Maintainability, safety and readability suddenly become an active part of your vocabulary. So you start looking at what’s already in Delphi rather than coding a faster, cooler version of the wheel.

That JSON thing

I must have seen about 100 different serialization schemes for Delphi. Some RTTI walkers, some binary only streaming, and some even hand-write every property, which to me utterly defeats the purpose of RTTI. I mean, what is the point of RTTI if you cannot automate how classes are saved? And perhaps more importantly: how classes are loaded back.

Serialization plain and simple

Most examples online deal with known classes. Meaning that the code expects you to hardcode the target type you want to de-serialize. Again I find this to completely defeat the purpose of both JSON, RTTI and persistence; the whole point of serialization is being able to reduce an instance to a portable, safe, readable format (string); and then re-create that instance without any loss of information from the portable format at will.

Known at runtime

Having to know exactly what class a piece of JSON text is prior to serialization is backwards, at least to my mind. There will naturally be situations where you do know exactly what class will be involved – at it may be fixed and never change (like child objects of a particular type). But what about those cases where you don’t know, where you have a large inheritance chain involving many classes – all of which can be serialized and have parent/child relationships impossible to predict?

In my case, an AST (abstract symbol tree) which is a model of a program. It’s what a parser and compiler generates before transforming it into machine-code, or in my case bytecodes and JavaScript.

As you can guess, an AST structure can contain all manner of combinations and parent/child relationships. Everything is parsed, validated and placed into the AST structure. Every parameter or return datatype is attached to its logical parent.

In short: you can forget about foresight or hardcoding anything! And if JSON is going to be of any use, it has to be able to de-serialize and recognize a class on the spot.

Autoregister

Earlier I posted an example of an attribute that autoregister a class with Delphi’s persistent framework. To explain what it means to register a class is beyond the scope of this post, but it essentially makes a class “known” to Delphi. Making Delphi able to recognize its type and re-create it by name alone. But this system is mainly used for binary storage, not JSON.

But it’s actually exactly what we need to automate JSON serialization.

Getting into it

Since I can’t really post a whole AST with nearly 100 classes here, I will just post this one class that contains the JSON storage mechanism you need. Just inherit from that class (clean it up and rename it first) and each inheritance step will actually take care of itself. It should be easy enough to extract the essence of this code.

You also want the AutoRegister Attribute I posted earlier! Also keep in mind that in this case we de-serialize to the current instance. You simply need to use Getclass() to get the classtype by name, create an instance of it and then de-serialize the JSON into a fresh new instance.

uses
  System.Rtti, System.TypInfo, System.Sysutils,
  System.Classes, System.Generics.Collections, System.Json,
  REST.Json, REST.JSon.Types, REST.JsonReflect, autoregister;

  [TQTXAutoRegister]
  TQTXASTPersistent = class(TInterfacedPersistent)
  protected
    procedure WriteObjectJSon(const Target: TJSONObject); virtual;
    procedure ReadObjectJSon(const Source: TJSONObject); virtual;
  public
    procedure Assign(Source: TPersistent); override;
    function  Stringify: string; virtual;
    procedure Parse(ObjectData: string); virtual;
    class function JSONToObject(const MetaData: string; var obj: TObject): boolean;
  end;

//##########################################################################
// TQTXASTPersistent
//##########################################################################

procedure TQTXASTPersistent.Assign(Source: TPersistent);
begin
  if assigned(source) then
  begin
    if (source is Classtype)
    or (source.InheritsFrom(ClassType)) then
    begin
      Parse( TQTXASTPersistent(Source).Stringify );
    end else
    inherited Assign(Source);
  end else
  inherited Assign(Source);
end;

function TQTXASTPersistent.Stringify: string;
var
  LObj: TJsonObject;
begin
  LObj := TJsonObject.Create;
  try
    WriteObjectJSon(LObj);
  finally
    result := TJSon.Format(LObj);
    LObj.Free;
  end;
end;

procedure TQTXASTPersistent.Parse(ObjectData: string);
var
  LSchema: TJsonObject;
  LObjData: TJsonObject;
  LEntry: TJSonObject;
  LId: string;
begin
  LId := '';

  // Parse whole schema
  LSchema := TJSonObject( TJSonObject.ParseJSONValue(ObjectData, true) );
  try
    if LSchema.Values[QualifiedClassName] <> nil then
    begin
      // Find storage entry for our class
      LEntry := TJsonObject( LSchema.GetValue(QualifiedClassName) );

      // attempt to get the identifier
      if LEntry.Values['$identifier'] <> nil then
      LId := LEntry.GetValue('$identifier').Value;

      // validate identifier
      if LId.Equals(Classname) then
      begin

        // Grab the data chunk of our entry
        LObjData := TJSonObject( LEntry.GetValue('$data') );

        // Data PTR valid?
        if LObjData <> nil then
        begin

          // Map values into our instance
          try
            ReadObjectJSon(LObjData);
          except
            on e: exception do
            raise EQTXASTJSONError.CreateFmt
            ('Serialization failed, system threw exception %s with message "%s" error',
            [e.ClassName, e.Message]);
          end;

        end else
        raise EQTXASTJSONError.CreateFmt
        ('Serialization failed, unable to find section ["%s\$data"] in JSON document error',
        [QualifiedClassName]);

      end else
      raise EQTXASTJSONError.CreateFmt
      ('Serialization failed, invalid signature, expected %s not %s error',
      [classname, LId]);

    end else
    raise EQTXASTJSONError.CreateFmt
    ('Serialization failed, unable to find section ["%s"] in JSON document error',
    [QualifiedClassName]);
  finally
    LSchema.Free;
  end;
end;

procedure TQTXASTPersistent.WriteObjectJSon(const Target: TJSONObject);
var
  LObj: TJsonObject;
begin
  LObj := TJSonObject.Create;
  LObj.AddPair('$identifier', ClassName);
  LObj.AddPair('$data', TJSon.ObjectToJsonObject(self) );
  Target.AddPair(QualifiedClassName, LObj);
  Target.AddPair('$classname$', ClassName);
end;

procedure TQTXASTPersistent.ReadObjectJSon(const Source: TJSONObject);
begin
  TJSon.JsonToObject(self, Source);
end;

// This function will create any registered class based on name.
// The class must be registered first.
class function TQTXASTPersistent.JSONToObject
      (const MetaData: string; var obj: TObject): boolean;
var
  LSchema: TJsonObject;
  LClassName: string;
  LType: TClass;
  LNameNode: TJSONValue;
  LObj: TQTXASTPersistent;
begin
  result := false;
  obj := nil;

  // Parse whole schema
  LSchema := TJSonObject( TJSonObject.ParseJSONValue(MetaData, true) );
  try
    LNameNode := LSchema.Values['$classname$'];
    if LNameNode <> nil then
    begin
      LClassName := LNameNode.Value;
      LType := GetClass(LClassName);
      if LType <> nil then
      begin
        LObj := TQTXASTPersistent( LType.Create );
        LObj.Parse(MetaData);
        obj := LObj;
        result := true;
      end;
    end;
  finally
    LSchema.Free;
  end;
end;

Autoregister attribute for Delphi

Wouldnt it be nice if Delphi had an attribute that would automatically register your classes? So instead of having to manually call Registerclass() you just decorate the class with an attribute and it’s automatically registered. No messing about with rouge procedure calls in the initialize section, just pretty and neat class declarations as far as the eye can see.

Well, I think that would be a good idea. And after searching for such a class without finding it (which is a bit odd since it’s such an obvious candidate for automation) – I decided to make one.

Now if you are expecting a huge unit with super-duper advanced code, I’m afraid I must disappoint you. This class is about elegance, grace and usefulness. It may be a humble class in the great scheme of things, but as is often the case in life, the simplest things can be of greatest value.

I find it very useful and I hope you find it equally helpful in your projects.

unit AutoRegister;

interface

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

type

// Our fancy shmancy attribute
TAutoRegister = class(TCustomAttribute)
end;

implementation

// This procedure walks through all classtypes and isolates
// those with our TAutoRegister attribute.
// It then locates the actual classtype and registeres it
// with Delphi's persistance layer
procedure ProcessAutoRegisterAttributes;
var
  ctx : TRttiContext;
  typ : TRttiType;
  attr : TCustomAttribute;
  LRealType: TClass;
  LAccess: PTypeData;
begin
  ctx := TRttiContext.Create();
  try
    for typ in ctx.GetTypes() do
    begin
      if typ.TypeKind = tkClass then
      begin
        for attr in typ.GetAttributes() do
        begin
          if attr is TAutoRegister then
          begin
            LAccess := GetTypeData(typ.Handle);
            if LAccess <> nil then
            begin
              LRealType := LAccess^.ClassType;
              if LRealType <> nil then
              begin
                if LRealType.InheritsFrom(TPersistent)
                or LRealType.InheritsFrom(TInterfacedPersistent) then
                begin
                  RegisterClass( TPersistentClass(LRealType) );
                end;
              end;
              break;
            end;
          end;
        end;
      end;
    end;
  finally
    ctx.Free();
  end;
end;

// We want to register all the classes decorated with our little
// attribute when this unit is loaded into memory
Initialization
begin
  ProcessAutoRegisterAttributes;
end;

end.

That’s basically it. Now to use the attribute just save out the unit and include it as you would any other (just add it to the uses-clause where you need it). Then decorate the classes you want registered automatically.

Remember that only classes that inherit from TPersistent (which includes TInterfacedPersistent) can be registered.

uses AutoRegister;

type
  [TAutoRegister]
  TMyClass = class(TPeristent)
  end;

  [TAutoRegister]
  TMyCoolClass = class(TInterfacedPersistent)
  end;

And voila, no more Registerclass() calls at the bottom of your units. Just neat, clean object oriented code -and as a bonus: I find it easier to read as well.

Cheers!