Delphi and RTTI / Class Helper

In many of my applications I have some data-objects which look something like this:

type
  TMyObject = class
  private
    fInt: integer;
    fDouble: double;
    fBool: boolean;
  public
    property IntegerProp : integer read fInt write fInt;
    property DoubleProp : double read fDouble write fDouble;
    property BoolProp : boolean read fBool write fBool;
  end;

Writing a SaveToFile and LoadFromFile for each is tedious work and if I change the object I have to change the two procedures as well. With Delphis support for RTTI and class helpers we can get rid of the tedious work. I am using a class helper for TObject, so technically its possible to do this with every object.

  TSerialHelper = class helper for TObject
  private
    function isPublicProperty(aProperty : TRttiProperty): boolean;
  public
    function Serialize(aHumanreadable : boolean = true) : string;
    procedure Deserialize(const text : string);
  end;

And here is the implementation:

function TSerialHelper.Serialize(aHumanreadable : boolean = true): string;
var
  context : TRttiContext;
  typ : TRttiType;
  prop : TRttiProperty;
  soJSON : ISuperObject;
  value : TValue;
begin
  context := TRttiContext.Create;
  try
    typ := context.GetType(self.ClassType);
    soJSON := SO; // Get Superobject Interface
    for prop in typ.GetProperties do
    begin
      if isPublicProperty(prop) and prop.IsWritable then
      begin
        value := prop.GetValue(self);
        case value.Kind of
          tkInteger, tkInt64 :
            soJSON.I[prop.Name] := value.AsInteger;
          tkEnumeration:
            if value.IsType<boolean> then
              soJSON.B[prop.Name] := value.AsBoolean;
          tkFloat:
            soJSON.D[prop.Name] := value.AsExtended;
          tkChar, tkString, tkWChar, tkLString, tkWString, tkUString:
            soJSON.S[prop.Name] := value.AsString;
        end;
      end;
    end;
    result := soJSON.AsJSon(aHumanreadable);
  finally
    context.Free;
  end;
end;

procedure TSerialHelper.Deserialize(const text: string);
var
  context : TRttiContext;
  typ : TRttiType;
  prop : TRttiProperty;
  soJSON : ISuperObject;
begin
  context := TRttiContext.Create;
  try
    soJSON := SO(text); // Init the Superobject Interface
    typ := context.GetType(self.ClassType);
    for prop in typ.GetProperties do
    begin
      if isPublicProperty(prop) and prop.IsWritable then
      begin
        case prop.PropertyType.TypeKind of
          tkInteger, tkInt64 :
            prop.SetValue(self, TValue.From<int64>(soJSON.I[prop.Name]));
          tkEnumeration:
            if prop.GetValue(self).IsType<boolean> then
              prop.SetValue(self, TValue.From<boolean>(soJSON.B[prop.Name]));
          tkFloat:
            prop.SetValue(self, TValue.From<double>(soJSON.D[prop.Name]));
          tkChar, tkString, tkWChar, tkLString, tkWString, tkUString:
            prop.SetValue(self, TValue.From<string>(soJSON.S[prop.Name]));
        end;
      end;
    end;
  finally
    context.Free;
  end;
end;

function TSerialHelper.isPublicProperty(aProperty: TRttiProperty): boolean;
begin
  result := aProperty.Visibility in [mvPublic, mvPublished];
end;

It is not finished, since it can't serialize sets, arrays or childobjects, but so far it works for simple objects.

You can download the unit here.
This unit uses the SuperObject by Henri Gourvest

Delphi and TPropertyObserver

In Delphi you can use RTTI (RunTime Type Information) to get information about objects at runtime without knowing about them at compile time. To find out more about RTTI, you should check out these articles by Robert Love.

I used the RTTI to make an observer, that informs me, whenever a specific property gets changed. It is far from being complete, there are a lot of TypeKinds that I didn't implement a compare for. The observer could also be extended to support multiple properties.

uses
  Rtti, Classes;

type
  TProc = reference to procedure;
  TPropertyObserver = class
  private
    fTerminated : boolean;
  public
    constructor Create(aInstance : TObject; aPropertyName : string; aOnChange : TProc);
    procedure Terminate;
  end;

implementation

uses
  SysUtils, TypInfo;

{ TPropertyObserver }

constructor TPropertyObserver.Create(aInstance: TObject; aPropertyName: string; aOnChange : TProc);
begin
  TThread.CreateAnonymousThread(procedure
  var
    ctx : TRttiContext;
    t : TRttiType;
    oldValue, curValue : TValue;
    b : boolean;
    p : TRttiProperty;
  begin
    ctx := TRttiContext.Create;
    try
      t := ctx.GetType(aInstance.ClassType);
      p := t.GetProperty(aPropertyName);
      oldValue := p.GetValue(aInstance);
      while not fTerminated do
      begin
        curValue := p.GetValue(aInstance);
        b := false;
        case curValue.Kind of
          tkInt64,
          tkEnumeration,
          tkInteger: b := oldValue.AsOrdinal = curValue.AsOrdinal;
          tkWChar,
          tkLString,
          tkWString,
          tkString,
          tkUString,
          tkChar: b := oldValue.AsString = curValue.AsString;
          tkFloat: b := oldValue.AsExtended = curValue.AsExtended;
          // Some of these should get a compare, too
          tkUnknown: ;
          tkSet: ;
          tkClass: ;
          tkMethod: ;
          tkVariant: ;
          tkArray: ;
          tkRecord: ;
          tkInterface: ;
          tkDynArray: ;
          tkClassRef: ;
          tkPointer: ;
          tkProcedure: ;
        end;
        if not b then
        begin
          aOnChange;
          oldValue := curValue;
        end;
        sleep(10);
      end;
      finally
      ctx.Free;
    end;
  end).Start;
end;

procedure TPropertyObserver.Terminate;
begin
  fTerminated := true;
end;

And how it is used:

procedure TForm1.FormCreate(Sender: TObject);
begin
  fObserver := TPropertyObserver.Create(self,'Left',procedure
  begin
    TThread.Synchronize(TThread.CurrentThread,procedure // Changing the VCL has to be done in the main thread
    begin
      edit1.Text := IntToStr(self.Left);
    end);
  end);
end;

Download is available here.

Delphi and TAppSettings

Delphi has had Inifle-Support for as long as I can remember. Inifiles are great for storing Application- and Usersettings, but I found myself doing the same things in each Application I wrote. Retrieve an appropiate directory for storing the actual file, creating and freeing the TInifile-Object.
I wanted something that I can just add to my project to store and retrieve simple values in a TInifile-like manner. Here is the result: TAppSettings. It relies on the aforementioned JSON-Library "Delphi Web Utils".

type
  TAppSettings = class
  protected
    fFilename : string;
    fSaveOnFree: boolean;
    fSettings : TJSONObject;
    function createOrGetSection(aSection : string) : TJSONObject;
  public
    constructor Create(aFilename : string);
    destructor Destroy; override;
    procedure Save;

    function getInteger(aSection, aKey : string; aDefault : integer) : integer;
    function getString(aSection, aKey : string; aDefault : string) : string;
    function getFloat(aSection, aKey : string; aDefault : double ) : double;
    function getBool(aSection, aKey : string; aDefault : boolean) : boolean;

    procedure setValue(aSection, aKey : string; aValue : integer); overload;
    procedure setValue(aSection, aKey : string; aValue : string); overload;
    procedure setValue(aSection, aKey : string; aValue : double); overload;
    procedure setValue(aSection, aKey : string; aValue : boolean); overload;

    property SaveOnFree : boolean read fSaveOnFree write fSaveOnFree;
    procedure OpenPathInExplorer;
  end;

As an example the getter and setter for integer:

function TAppSettings.getInteger(aSection, aKey: string;
  aDefault: integer): integer;
var
  section : TJSONObject;
begin
  result := aDefault;
  section := fSettings.optJSONObject(aSection);
  if section <> nil then result := section.optInt(aKey);
end;

function TAppSettings.createOrGetSection(aSection: string): TJSONObject;
begin
  result := fSettings.optJSONObject(aSection);
  if result = nil then
  begin
    result := TJSONObject.create;
    fSettings.put(aSection,result);
  end;
end;

procedure TAppSettings.setValue(aSection, aKey: string; aValue: integer);
var
  section : TJSONObject;
begin
  section := createOrGetSection(aSection);
  section.put(aKey, aValue);
end;

This alone doesn't help with the initial problem, it just changes the format of the file. The interesting part is at the bottom of the unit.

interface

const
  COMPANY_NAME = 'MyCompany';

[...]

var
  AppSettings, UserSettings : TAppSettings;

[...]

function GetSpecialFolder(Folder: Integer): String;
var
  Path: array[0..MAX_PATH] of char;
begin
  If SHGetSpecialFolderPath(0, @Path, Folder, false)
    then Result:=Path
    else Result:='';
end;

function GetApplicationName : string;
begin
  result := ExtractFilename(ParamStr(0));
  delete(result,length(result)-3,4);
end;

initialization
begin
  ForceDirectories(GetSpecialFolder(CSIDL_COMMON_APPDATA)+'\'+COMPANY_NAME+'\'+GetApplicationName);
  ForceDirectories(GetSpecialFolder(CSIDL_APPDATA)+'\'+COMPANY_NAME+'\'+GetApplicationName);
  AppSettings := TAppSettings.Create(GetSpecialFolder(CSIDL_COMMON_APPDATA)+'\'+COMPANY_NAME+'\'+GetApplicationName+'\settings.json');
  UserSettings := TAppSettings.Create(GetSpecialFolder(CSIDL_APPDATA)+'\'+COMPANY_NAME+'\'+GetApplicationName+'\settings.json');
end;

finalization
begin
  AppSettings.Free;
  UserSettings.Free;
end;

Adding this unit to your project automatically creates two Objects of TAppSettings, one for UserSettings and one for ApplicationSettings. Before I wrote TAppSettings I always had two procedures "LoadIni" and "SaveIni" in my application where I would load and save all my application settings, because that were the only places I could access the settings. Now I just use the settings wherever I need them.

You can download the complete unit here.

Delphi and TTaskList

I was reading about some of the new features in Delphi XE in the new book from Marco Cantu, Delphi XE Handbook. (He also told me about them earlier this year in Frankfurt on the Delphi Developer Days, but I didn't found time to play around with it until now)
The newest Delphi comes with anonymous Threads, which are a very easy way to make your application multithreaded, which is very useful to make some big calculations in the background, while the UI is still responding. However, sometimes you need things to be done in order. Enter TTasklist:

type
  TProc = reference to procedure;
  TTaskList = class
  private
    fTasks : TThreadedQueue<TProc>;
    fTerminated : boolean;
    procedure start;
  public
    constructor Create;
    destructor Destroy; override;
    procedure addTask(aTask : TProc);
    procedure Terminate;
  end;

TTaskList uses a ThreadSafe Queue to store the tasks, which are basically anonymous methods. The constructor creates the queue and starts a new thread which executes one task after another.

constructor TTaskList.Create;
begin
  fTasks := TThreadedQueue<TProc>.Create;
  fTerminated := false;
  start;
end;

procedure TTaskList.addTask(aTask: TProc);
begin
  fTasks.PushItem(aTask);
end;

procedure TTaskList.start;
begin
  TThread.CreateAnonymousThread(
  procedure
  begin
    while not fTerminated do
    begin
      if fTasks.QueueSize > 0 then fTasks.PopItem.Invoke;
    end;
  end
  ).Start;
end;

procedure TTaskList.Terminate;
begin
  fTerminated := true;
end;

destructor TTaskList.Destroy;
begin
  Terminate;
  fTasks.Free;
  inherited;
end;

Download is available here.

Delphi and Geocoding

Google has some powerful APIs. One of them is the Maps API which is capable of geocoding an address to longitude and latitude information.

It is pretty easy to use this functionality from Delphi. All you need is TIdHttp and a JSON library. (I'm using the Delphi Web Utils)

TLocationType = (ltRooftop, ltRangeInterpolated, ltGeometricCenter, ltApproximate);
  TAddress = class
  private
    fAddress : string;
    fLatitude: double;
    fLongitude: double;
    fLocationType: TLocationType;
  public
    constructor Create(aAddress : string; aHttp : TIdHttp = nil);
    property Address : string read fAddress write fAddress;
    property Latitude : double read fLatitude;
    property Longitude : double read fLongitude;
    property LocationType : TLocationType read fLocationType;
    procedure Geocode(aHttp : TIdHttp);
  end;

The Google API returns a JSON structure with a couple of fields. However, I just grab the longitude and latitude information as well as the location_type, to determine the quality of the coordinates.

procedure TAddress.GeoCode(aHttp: TIdHttp);
var
  url : string;
  jo, location, geometry : TJSONObject;
  sc : TStringCase;
begin
  url := TIdURI.URLEncode('http://maps.google.com/maps/api/geocode/json?address='+fAddress+'&sensor=false');
  jo := TJSONObject.create(aHttp.Get(url));
  if jo.getString('status') = 'OK' then
  begin
    geometry := jo.getJSONArray('results').getJSONObject(0).getJSONObject('geometry');
    location := geometry.getJSONObject('location');
    fLongitude := location.getDouble('lng');
    fLatitude := location.getDouble('lat');

    sc := TStringCase.Create;
    try
      sc.addEntry('ROOFTOP',procedure
      begin
        fLocationType := ltRooftop;
      end);
      sc.addEntry('RANGE_INTERPOLATED',procedure
      begin
        fLocationType := ltRangeInterpolated;
      end);
      sc.addEntry('GEOMETRIC_CENTER',procedure
      begin
        fLocationType := ltGeometricCenter;
      end);
      sc.addEntry('APPROXIMATE',procedure
      begin
        fLocationType := ltApproximate;
      end);
    finally
      sc.switch(geometry.getString('location_type'));
    end;
    sc.Free;
  end
  else raise Exception.Create(jo.getString('status'));
  jo.Free;
end;

I used this and TGoMaps to create a simple application which takes a list of addresses, geocodes them and displays them on a GoogleMap.

Source and binary are available here.

TAddress uses TStringCase from the previous post.

Delphi and TStringCase

Delphi's Case <X> of statement works with everything that is Ordinal. integer, char, enumerations, it even works with boolean.

case b of
  true : MakeSomething;
  false : DoNotMakeSomething;
end;

However, it does not work with strings. And I've come across some places where it would be very handy to have a Case <String> of.

Luckily, with Delphi 2010 came anonymous methods and with the combination of a Dictionary we can finally have something that works as a Case <String> of.

type
  TProc = reference to procedure;
  TCase<T> = class
  private
    fDict : TDictionary<T,TProc>;
    fElse: TProc;
  public
    constructor Create;
    destructor Destroy; override;
    procedure addEntry(aKey : T; aProc :TProc);
    procedure addEntries(const aKeys : array of T; aProc : TProc);
    procedure switch(aKey : T);
    property ElseCase : TProc read fElse write fElse;
  end;
  TStringCase = TCase<string>;

TStringCase is the type, that will be used the most, but with the generic TCase, (almost) everything can be used for a Case statement.

The implementation is very simple:

procedure TCase<T>.addEntries(const aKeys: array of T; aProc: TProc);
var
  key : T;
begin
  for key in aKeys do
    addEntry(key,aProc);
end;

procedure TCase<T>.addEntry(aKey: T; aProc: TProc);
begin
  fDict.Add(aKey, aProc);
end;

constructor TCase<T>.Create;
begin
  fDict := TDictionary<T,TProc>.Create;
end;

destructor TCase<T>.Destroy;
begin
  fDict.Free;
  inherited;
end;

procedure TCase<T>.switch(aKey: T);
var
  p : TProc;
begin
  if fDict.TryGetValue(aKey, p) then
    p()
  else
    if assigned(fElse) then fElse();
end;

And this is how it's used:

procedure UseStringCase;
var
  sc : TStringCase;
begin
  sc :=TStringCase.Create;
  try
    // setup the case
    sc.addEntry('STRING1',procedure
    begin
      Label1.Caption := 'First Option';
    end);

    sc.addEntry('STRING1',procedure
    begin
      Label1.Caption := 'Second Option';
    end);

    sc.addEntries(['STRING3','STRING4','STRING5'],procedure
    begin
      Label1.Caption := 'one of three options';
    end);

    sc.ElseProc := procedure
    begin
      Label1.Caption := 'Something else';
    end;

    sc.switch(Edit1.Text); // execute the right procedure
  finally
    sc.Free;
  end;

end;

The usage has some overhead compared to the standard case, but I think it is still prettier than a bunch of if-then-else's.

procedure UseIfThenElse;
var
  s : string;
begin
  s := Edit1.Text;
  if s = 'STRING1' then
  begin
    Label1.Caption := 'First Option';
  end
  else if s = 'STRING2' then
  begin
    Label1.Caption := 'Second Option';
  end
  else if (s = 'STRING3') or (s = 'STRING4') or (s = 'STRING5') then
  begin
    Label1.Caption := 'one of three options';
  end
  else
  begin
    Label1.Caption := 'Something else';
  end;
end;

Download is available here.

Delphi and Barcode scanning

Todays example uses a dll to access a Barcode Scanner. The used Barcode Scanner is the CS1504 (SDK available here).

The CS1504 has a buffer where it stores all scanned barcodes and this buffer can be accessed via a COM-Port. Luckily, the SDK has a dll which takes care of the communication. The only problem is, that the header is written in C/C++. I translated it (in parts) to Delphi, you can grab the file here.

Now we could just use it as is, but it would be much nicer if we had a class to wrap it all up.

We need some object to store the data, which is really simple:

TBarcode = class
  private
    fTimestamp : TDateTime;
    fCode : string;
  public
    constructor Create(aTimestamp : TDateTime; aCode : string);
    property TimeStamp : TDateTime read fTimestamp;
    property Code : string read fCode;
  end;

And now the class that does all the work:

TScanner = class
  private
    fPort : integer;
    fReady : boolean;
    fHasData: boolean;
    function TimestampToDateTime(aTimestamp : Ansistring) : TDateTime;
  public
    constructor Create(aPort : integer);
    destructor Destroy; override;
    function getBarcodes : TList<TBarcode>;
    procedure clearBarcodes;
    property IsReady : boolean read fReady;
    property HasData : boolean read fHasData;
    procedure setDateTime(aDateTime : TDateTime);
    function getDateTime : TDateTime;
  end;

The TScanner class returns a generic TList<TBarcode> with all the Barcodes from the device.

The most important function is of course getBarcodes.

function TScanner.getBarcodes: TList<TBarcode>;
var
  bc : TBarcode;
  i, count, pl : integer;
  buffer : array[0..63] of AnsiChar;
  dt : TDateTime;
  s : string;
begin
  result := TList<TBarcode>.Create;
  begin
    count := csp2ReadData;
    for i := 0 to count -1 do
    begin
      FillChar(buffer,64,#0);
      pl := csp2GetPacket(@buffer,i,63);

      // The Last 4 Bytes hold the timestamp
      dt := TimestampToDateTime(copy(buffer,pl-3,4));

      s := copy(buffer,3,pl-6);
      bc := TBarcode.Create(dt,s);
      result.Add(bc);
    end;
  end;
end;

The implementation is pretty much straight forward, the trickiest part was to convert the 4-byte timestamp from each barcode to TDateTime. They crammed the six values for year, month, day, hour, minute and second into 4 bytes. (seriously, a SD Card that has the size of my fingernail can hold easily 4 GB and they worry about 2 bytes per scanned barcode)

function TScanner.TimestampToDateTime(aTimestamp: Ansistring): TDateTime;
var
  i1,i2,i3,i4,i5,i6 : integer;
  qb : T4Bytes;
  y,m,d,h,n,s : word;
begin
  // CharToByte
  qb.Bytes[3] := Ord(aTimestamp[1]);
  qb.Bytes[2] := Ord(aTimestamp[2]);
  qb.Bytes[1] := Ord(aTimestamp[3]);
  qb.Bytes[0] := Ord(aTimestamp[4]);

  // split up the bits
  i1 := qb.Total and $fc000000; // 6 Bit
  i2 := qb.Total and $03f00000; // 6 Bit
  i3 := qb.Total and $000f8000; // 5 Bit
  i4 := qb.Total and $00007c00; // 5 Bit
  i5 := qb.Total and $000003c0; // 4 Bit
  i6 := qb.Total and $0000003f; // 6 Bit

  // Shift right to align the bits
  s := i1 shr 26;
  n := i2 shr 20;
  h := i3 shr 15;
  d := i4 shr 10;
  m := i5 shr 6;
  y := i6;

  result := EncodeDate(y+2000,m,d) + EncodeTime(h,n,s,0);
end;

This uses T4Bytes which is a packed record.

T4Bytes = packed record
   case Integer of
    0: (Bytes: array[0..3] of Byte);
    1: (Total: Cardinal);
  end;

The bytes are accessible indivudually and as the resulting 4-Byte Cardinal.

Full Sourcecode is available here.

Delphi and Generics

In this first developer-themed post, I am going to describe some basic stuff, before I delve into some real-world applications.

Delphi 2009 brought Generics to the Delphi-World. And since then, they are found in all of my Applications. Especially Generics.Collections are heavily used by me.

Before Generics.Collections I had to implement a TList for each Class I would like to store a variable amount of Objects. (Or I could use Contnrs.TObjectList and cast to TAnimal everytime I need one, but I don't find that very desirable)

interface

uses
  Classes;

type
  TAnimal = class
  private
    fName : string;
  public
    property Name : string read fName write fName;
  end;
  
  TAnimalList = class (TList)
  private
  procedure putAnimal(Index : integer; Value : TAnimal);
  function getAnimal(Index : integer) : TAnimal;
  public  
    property Items [Index : integer] : TAnimal read getAnimal write setAnimal;
  end;
  
implementation

procedure TAnimalList.putAnimal(Index : integer; Value : TAnimal);
begin
  inherited put(Index, Value);
end;

function TAnimalList.getAnimal(Index : integer) : TAnimal;
begin
  result := (TAnimal) inherited get(Index);
end;

And this is just for TAnimal, if there are any other classes, I would have to copy&paste the code for the List and replace the data types.

With Generics.Collections the same thing looks like this:

interface

uses
  Generics.Collections;

type
  TAnimal = class
  private
    fName : string;
  public
    property Name : string read fName write fName;
  end;

  TAnimalList = TList<TAnimal>

And I don't even need the alias "TAnimalList", I could use "TList<TAnimal>" instead.

Also, it is not limited to Classes, it can hold every datatype like integer, double, boolean and even records. In my case it is even better to use TObjectList<TAnimal>, which automatically frees its containing objects if it is freed.

Since all the Generics.Collectionshave an Enumerator the following is possible:

var
  fAnimals : TList<TAnimal>

procedure init;
var
  a : TAnimal;
begin
  for a in fAnimals do
  begin
    a.DoSomething;
  end;
end;

Generics.Collections has more then some simple Lists up its sleeve. There are also TQueue, which uses FIFO and TStack which uses LIFO to store its contents.

TDictionary is a little different, because its taking two type parameters. One for the key, one for the Value.
A case that I often stumble upon is to store (and recieve) some object or value for a specific string. And then I always use a TDictionary<String,TValue>

There's also a TObjectDictionary, which takes care of memory of the keys, the values or even both.

procedure init;
var
  ownsKeys, ownsValues, ownsBoth : TObjectDictionary<TKey, TValue>
begin
  ownsKeys := TObjectDictionary<TKey, TValue>.Create([doKeys]);
  ownsValues := TObjectDictionary<TKey, TValue>.Create([doValues]);
  ownsBoth := TObjectDictionary<TKey, TValue>.Create([doKeys, doValues]);
end;

That's it for today.

Level Up

Time for another Level Up. In this week I became a certified Delphi Developer. There is also the Delphi Master Certification, but since this certification deals a lot with DataSnap, which I have not used very much, I don't think I'll take it anytime soon.

I think this is a good opportunity to blog about some techniques I am using in my every day work. Which may help some fellow Delphi Developers, who can learn a thing or two and also give me feedback to improve my work.

For those interested in these kind of posts, you can grab the feed for the "Developer"-Posts right here