July 27, 2013

Using RTTI to convert record to/from string


Delphi RTTI can be easily used to convert a record (Or a class by the way) to a string representation without taking care of how the record is changed during software maintenance.

RTTI has a set of methods to handle metadata collected by the compiler at compile time. For example, you can iterate thru all fields of a record to find out his name, data type and get or set his value. I used those methods as a simple way to marshal record values between two different processes communicating using sockets.

To simplify my original problem without removing features, I designed a very simple sample program demonstrating the RTTI usage. This simple program simply adds two methods “ToString” and “FromString” to a record. Instead of hardcoding each field in the conversion, I used RTTI to iterate all fields.

Basically, to use RTTI with records, you need the following data types: TRttiContext, TRttiRecordType and TRttiField.

Assuming we handle a record type name “THdr”, the simplest code looks like this:

    AContext := TRttiContext.Create;
    try
        ARecord := AContext.GetType(TypeInfo(THdr)).AsRecord;
        for AField in ARecord.GetFields do begin
            AFldName := AField.Name;
        end;
    finally
        AContext.Free;
    end;



As you can see, we have to create a TRttiContext instance. We then use his method “GetType” to get an instance of TRttiRecord related to the record we are handling. Finally we can iterate thru all fields using a for..in construct. Each field has a corresponding TRttiField instance which can be used to get field name, set or get his value and so on.

My sample code use a loop similar to the above twice: one for converting all fields to a string and one for extracting values from a string and assigning the values to the corresponding fields.

To achieve the goal, I used two support functions: “ParamByNameAsString” and “EscapeQuotes”. They are required to be able to store any fieldname=”fieldvalue” pair into a simple string. There is a simple escape mechanism so that the value can contain embedded double quote.

Here is the full source code:

unit RttiTestForm;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics,
    Controls, Forms, Dialogs, Rtti, TypInfo, Vcl.StdCtrls;

type
    THdr = record
        Name       : String;
        Phrase     : String;
        ActionDate : TDateTime;
        procedure FromString(const FromValue: String);
        function  ToString : String;
    end;

    TForm1 = class(TForm)
        Memo1: TMemo;
        Button1: TButton;
        procedure Button1Click(Sender: TObject);
    end;

var
    Form1: TForm1;

implementation

{$R *.dfm}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// This will take an inut string having the format:
//  name1=value1;name2=value2;...
// Value may also be placed between double quotes if it contain spaces.
// Double quotes inside the value is escaped with a backslash
// Backslashes are double. See EscapeQuotes below.
function ParamByNameAsString(
    const Params     : String;
    const ParamName  : String;
    var   Status     : Boolean;
    const DefValue   : String) : String;
var
    I, J  : Integer;
    Ch    : Char;
begin
    Status := FALSE;
    I := 1;
    while I <= Length(Params) do begin
        J := I;
        while (I <= Length(Params)) and (Params[I] <> '=')  do
            Inc(I);
        if I > Length(Params) then begin
            Result := DefValue;
            Exit;                  // Not found
        end;
        if SameText(ParamName, Trim(Copy(Params, J, I - J))) then begin
            // Found parameter name, extract value
            Inc(I); // Skip '='
            if (I <= Length(Params)) and (Params[I] = '"') then begin
                // Value is between double quotes
                // Embedded double quotes and backslashes are prefixed
                // by backslash
                Status := TRUE;
                Result := '';
                Inc(I);        // Skip starting delimiter
                while I <= Length(Params) do begin
                    Ch := Params[I];
                    if Ch = '\' then begin
                        Inc(I);          // Skip escape character
                        if I > Length(Params) then
                            break;
                        Ch := Params[I];
                    end
                    else if Ch = '"' then
                        break;
                    Result := Result + Ch;
                    Inc(I);
                end;
            end
            else begin
                // Value is up to semicolon or end of string
                J := I;
                while (I <= Length(Params)) and (Params[I] <> ';') do
                    Inc(I);
                Result := Copy(Params, J, I - J);
                Status := TRUE;
            end;
            Exit;
        end;
        // Not good parameter name, skip to next
        Inc(I); // Skip '='
        if (I <= Length(Params)) and (Params[I] = '"') then begin
            Inc(I);        // Skip starting delimiter
            while I <= Length(Params) do begin
                Ch := Params[I];
                if Ch = '\' then begin
                    Inc(I);          // Skip escape character
                    if I > Length(Params) then
                        break;
                end
                else if Ch = '"' then
                    break;
                Inc(I);
            end;
            Inc(I);        // Skip ending delimiter
        end;
        // Param ends with ';'
        while (I <= Length(Params)) and (Params[I] <> ';')  do
            Inc(I);
        Inc(I);  // Skip semicolon
    end;
    Result := DefValue;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function EscapeQuotes(const S: String) : String;
begin
    // Easy but not best performance
    Result := StringReplace(S, '\', '\\', [rfReplaceAll]);
    Result := StringReplace(Result, '"', '\"', [rfReplaceAll]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THdr.FromString(const FromValue: String);
var
    Status    : Boolean;
    Value     : String;
    AValue    : TValue;
    AContext  : TRttiContext;
    ARecord   : TRttiRecordType;
    AField    : TRttiField;
    AFldName  : String;
begin
    if FromValue = '' then
        Exit;

    // We use RTTI to iterate thru all fields of THdr and use each field name
    // to get field value from metadata string and then set value into Hdr.
    AContext := TRttiContext.Create;
    try
        ARecord := AContext.GetType(TypeInfo(THdr)).AsRecord;
        for AField in ARecord.GetFields do begin
            AFldName := AField.Name;
            Value    := ParamByNameAsString(FromValue, AFldName, Status, '0');
            if Status then begin
                try
                    case AField.FieldType.TypeKind of
                    tkFloat:               // Also for TDateTime !
                        begin
                            if Pos('/', Value) >= 1 then
                                AValue := StrToDateTime(Value)
                            else
                                AValue := StrToFloat(Value);
                            AField.SetValue(@Self, AValue);
                        end;
                    tkInteger:
                        begin
                            AValue := StrToInt(Value);
                            AField.SetValue(@Self, AValue);
                        end;
                    tkUString:
                        begin
                            AValue := Value;
                            AField.SetValue(@Self, AValue);
                        end;
                    // You should add other types as well
                    end;
                except
                    // Ignore any exception here. Likely to be caused by
                    // invalid value format
                end;
            end
            else begin
                // Do whatever you need if the string lacks a field
                // For example clear the field, or just do nothing
            end;
        end;
    finally
        AContext.Free;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function THdr.ToString: String;
var
    AContext  : TRttiContext;
    AField    : TRttiField;
    ARecord   : TRttiRecordType;
    AFldName  : String;
    AValue    : TValue;
begin
    Result := '';
    AContext := TRttiContext.Create;
    try
        ARecord := AContext.GetType(TypeInfo(THDR)).AsRecord;
        for AField in ARecord.GetFields do begin
            AFldName := AField.Name;
            AValue := AField.GetValue(@Self);
            Result := Result + AFldName + '="' +
                      EscapeQuotes(AValue.ToString) + '";';
        end;
    finally
        AContext.Free;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.Button1Click(Sender: TObject);
var
    Hdr1 : THdr;
    Hdr2 : THdr;
    Buf  : String;
begin
    Hdr1.Name       := 'Francois Piette';
    Hdr1.Phrase     := 'I said "\Hello\"';
    Hdr1.ActionDate := Now;

    Memo1.Lines.Add(Hdr1.Phrase);
    Buf := Hdr1.ToString;
    Memo1.Lines.Add(Buf);
    Hdr2.FromString(Buf);
    Memo1.Lines.Add(Hdr2.Phrase);
    Memo1.Lines.Add(Hdr2.ToString);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.



Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

No comments: