Home > Delphi, Object Pascal > JSON persistence, when a classtype is only known at runtime

JSON persistence, when a classtype is only known at runtime

December 13, 2016 Leave a comment Go to comments

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

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;

Advertisements
  1. No comments yet.
  1. No trackbacks yet.

Leave a Reply

Please log in using one of these methods to post your comment:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: