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.