utils/uutlSettings.pas

unit uutlSettings;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit stellt ein Framework zur Verfügung mit dessen Hilfe Einstellungs-Blöcke
                in ein MCF File geladen und geschreieben werden können }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  uutlMCF, uutlGenerics, uutlMessageThread;

type
  TutlSettingsBlock = class
    constructor Create; virtual;

    procedure LoadDefaults; virtual; abstract;
    procedure LoadFromConfig(const aMcf: TutlMCFSection); virtual; abstract;
    procedure SaveToConfig(const aMcf: TutlMCFSection); virtual; abstract;
  end;
  TutlSettingsBlockClass = class of TutlSettingsBlock;

  TutlSettingsUpdateOp = (opInstanceChanged, opDataChanged);
  TutlSettingsUpdateEvent = procedure (const aUpdateOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock) of object;
  TutlSettingsUpdateEventCntr = packed record
    Callback: TutlSettingsUpdateEvent;
    ThreadID: TThreadID;
  end;
  TutlSettingsUpdateEventCntrEqComp = class(TInterfacedObject, specialize IutlEqualityComparer<TutlSettingsUpdateEventCntr>)
  public
    function EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
  end;

  TutlSettings = class
  private type
    TutlSettingsUpdateEventList = specialize TutlCustomList<TutlSettingsUpdateEventCntr>;
    TBlockData = class
      Instance, OldInstance: TutlSettingsBlock;
      Events: TutlSettingsUpdateEventList;
      procedure CallEvents(const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock);
      constructor Create;
      destructor Destroy; override;
    end;

    TBlockList = specialize TutlMap<String, TBlockData>;
  private
    fBlocks: TBlockList;
    fRaiseChangedEventOnLoad: Boolean;
    procedure CopyInstance(O, N: TutlSettingsBlock);
  public
    property RaiseChangedEventOnLoad: Boolean read fRaiseChangedEventOnLoad write fRaiseChangedEventOnLoad;

    function RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass; const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock;
    procedure UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent);
    procedure UnregisterBlockCallbacks(const aObj: TObject);

    function Block(const aName: String; out aBlock): boolean;
    procedure Changed(const aBlock: TutlSettingsBlock);

    procedure LoadFromConfig(const aMcf: TutlMCFSection);
    procedure SaveToConfig(const aMcf: TutlMCFSection);

    procedure LoadFromFile(const aFile: string);
    procedure SaveToFile(const aFile: string);

    constructor Create;
    destructor Destroy; override;
  end;

operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean; inline;

var
  utlSettings: TutlSettings;

implementation

uses
  uutlExceptions, Forms{$IFDEF USE_VFS}, uvfsManager{$ENDIF}, uutlMessages, syncobjs;

const
  SETTINGS_MSG_WAIT_TIME = 1000; //ms

type
  TSettingsBlockChangedMsg = class(TutlSyncCallbackMsg)
  private
    fCallback: TutlSettingsUpdateEvent;
    fOperation: TutlSettingsUpdateOp;
    fOld: TutlSettingsBlock;
    fNew: TutlSettingsBlock;
  public
    procedure ExecuteCallback; override;
    constructor Create(const aCallback: TutlSettingsUpdateEvent; const aOp: TutlSettingsUpdateOp;
      const aOld, aNew: TutlSettingsBlock);
  end;

operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
begin
  result :=
    (i1.Callback = i2.Callback) and
    (i2.ThreadID = i2.ThreadID);
end;

function TutlSettingsUpdateEventCntrEqComp.EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
begin
  result := (i1 = i2);
end;

{ TSettingsBlockChangedMsg }

procedure TSettingsBlockChangedMsg.ExecuteCallback;
begin
  fCallback(fOperation, fOld, fNew);
end;

constructor TSettingsBlockChangedMsg.Create(const aCallback: TutlSettingsUpdateEvent;
  const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock);
begin
  inherited Create;
  fCallback  := aCallback;
  fOperation := aOp;
  fOld       := aOld;
  fNew       := aNew;
end;

{ TutlSettings.TBlockData }

procedure TutlSettings.TBlockData.CallEvents(const aOp: TutlSettingsUpdateOp;
  const aOld, aNew: TutlSettingsBlock);
var
  current: TThreadID;
  cntr: TutlSettingsUpdateEventCntr;
  msg: TSettingsBlockChangedMsg;
begin
  current := GetCurrentThreadId;
  for cntr in Events do begin
    if (cntr.ThreadID <> current) then begin
      msg := TSettingsBlockChangedMsg.Create(cntr.Callback, aOp, aOld, aNew);
      if utlSendMessage(cntr.ThreadID, msg, SETTINGS_MSG_WAIT_TIME) = wrSignaled then
        msg.Free;
    end else
      cntr.Callback(aOp, aOld, aNew);
  end;
end;

constructor TutlSettings.TBlockData.Create;
begin
  inherited;
  Events:= TutlSettingsUpdateEventList.Create(TutlSettingsUpdateEventCntrEqComp.Create);
end;

destructor TutlSettings.TBlockData.Destroy;
begin
  FreeAndNil(Events);
  FreeAndNil(Instance);
  FreeAndNil(OldInstance);
  inherited Destroy;
end;

{ TutlSettingsBlock }

constructor TutlSettingsBlock.Create;
begin
  inherited;
  LoadDefaults;
end;

{ TutlSettings }

function TutlSettings.RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass;
  const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock;
var
  i: integer;
  bd: TBlockData;
  cntr: TutlSettingsUpdateEventCntr;
begin
  Result:= nil;

  if aName = '' then
    raise EInvalidOperation.Create('Empty Settings section name.');

  i:= fBlocks.IndexOf(aName);
  if i>=0 then begin
    bd:= fBlocks.ValueAt[i];
    // gleicher name, instance ist gleiche oder spezifischere klasse
    if bd.Instance is aClass then begin
      if Assigned(aOnUpdateEvent) then begin
        cntr.Callback := aOnUpdateEvent;
        cntr.ThreadID := GetCurrentThreadId;
        bd.Events.Add(cntr);
      end;
      Exit(bd.Instance)
    end else
    // gleicher name, neue klasse ist spezifischer
    if aClass.InheritsFrom(bd.Instance.ClassType) then begin
      Result:= aClass.Create;
      CopyInstance(bd.Instance, Result);
      bd.CallEvents(opInstanceChanged, bd.Instance, Result);
      bd.Instance.Free;
      bd.OldInstance.Free;
      bd.Instance:= aClass.Create;
      bd.OldInstance:= aClass.Create;
      if Assigned(aOnUpdateEvent) then begin
        cntr.Callback := aOnUpdateEvent;
        cntr.ThreadID := GetCurrentThreadId;
        bd.Events.Add(cntr);
      end;
      Exit;
    end
    // gleicher name, aber komplett andere klasse
    else
      raise EInvalidOperation.CreateFmt('Duplicate Settings entry: %s', [aName]);
  end;

  for bd in fBlocks do
    // verwandte klasse aber anderer name (wäre es der gleiche wäre das schon oben abgefangen)
    if (bd.Instance is aClass) or (aClass.InheritsFrom(bd.Instance.ClassType)) then
      raise EInvalidOperation.CreateFmt('Reused Settings class: %s', [aClass.ClassName]);

  // neuer name, neue klasse
  bd:= TBlockData.Create;
  bd.Instance:= aClass.Create;
  bd.OldInstance:= aClass.Create;
  if Assigned(aOnUpdateEvent) then begin
    cntr.Callback := aOnUpdateEvent;
    cntr.ThreadID := GetCurrentThreadId;
    bd.Events.Add(cntr);
  end;

  fBlocks.Add(aName, bd);
  Result:= bd.Instance;
end;

procedure TutlSettings.UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent);
var
  i: integer;
  bd: TBlockData;
begin
  i:= fBlocks.IndexOf(aName);
  if i >= 0 then begin
    bd := fBlocks.ValueAt[i];
    for i := bd.Events.Count-1 downto 0 do
      if (bd.Events.Items[i].Callback = aOnUpdateEvent) then
        bd.Events.Delete(i);
  end;
end;

procedure TutlSettings.UnregisterBlockCallbacks(const aObj: TObject);
var
  bd: TBlockData;
  i: integer;
begin
  for bd in fBlocks do
    for i:= bd.Events.Count-1 downto 0 do
      if TMethod(bd.Events[i].Callback).Data = Pointer(aObj) then
        bd.Events.Delete(i);
end;

procedure TutlSettings.CopyInstance(O, N: TutlSettingsBlock);
var
  tmp: TutlMCFSection;
begin
  tmp:= TutlMCFSection.Create;
  try
    O.SaveToConfig(tmp);
    N.LoadFromConfig(tmp);
  finally
    FreeAndNil(tmp);
  end;
end;

function TutlSettings.Block(const aName: String; out aBlock): boolean;
var
  i: integer;
  bd: TBlockData;
begin
  i := fBlocks.IndexOf(aName);
  Result := (i >= 0);
  if Result then begin
    bd:= fBlocks.ValueAt[i];
    CopyInstance(bd.Instance, bd.OldInstance);
    TutlSettingsBlock(aBlock):= bd.Instance;
  end;
end;

procedure TutlSettings.Changed(const aBlock: TutlSettingsBlock);
var
  bd: TBlockData;
begin
  for bd in fBlocks do
    if bd.Instance = aBlock then begin
      bd.CallEvents(opDataChanged, bd.OldInstance, bd.Instance);
      exit;
    end;
end;

procedure TutlSettings.LoadFromConfig(const aMcf: TutlMCFSection);
var
  i: Integer;
  b: TBlockData;
begin
  for i := 0 to fBlocks.Count-1 do begin
    b := fBlocks.ValueAt[i];
    b.Instance.LoadFromConfig(aMcf.Section(fBlocks.Keys[i]));
    if fRaiseChangedEventOnLoad then
      Changed(b.Instance);
  end;
end;

procedure TutlSettings.SaveToConfig(const aMcf: TutlMCFSection);
var
  i: integer;
begin
  for i:= 0 to fBlocks.Count-1 do
    fBlocks.ValueAt[i].Instance.SaveToConfig(aMcf.Section(fBlocks.Keys[i]));
end;

{$IFDEF USE_VFS}
procedure TutlSettings.LoadFromFile(const aFile: string);
var
  sh: IStreamHandle;
  mcf: TutlMCFFile;
begin
  if vfsManager.ReadFile(aFile, sh) then begin
    mcf:= TutlMCFFile.Create(sh);
    try
      LoadFromConfig(mcf);
    finally
      FreeAndNil(mcf);
    end;
  end;
end;
{$ELSE}
procedure TutlSettings.LoadFromFile(const aFile: string);
var
  fs: TFileStream;
  mcf: TutlMCFFile;
begin
  fs := TFileStream.Create(aFile, fmOpenRead);
  mcf := TutlMCFFile.Create(nil);
  try
    mcf.LoadFromStream(fs);
    LoadFromConfig(mcf);
  finally
    FreeAndNil(fs);
  end;
end;
{$ENDIF}

{$IFDEF USE_VFS}
procedure TutlSettings.SaveToFile(const aFile: string);
var
  sh: IStreamHandle;
  mcf: TutlMCFFile;
begin
  if vfsManager.CreateFile(aFile, sh) then begin
    mcf:= TutlMCFFile.Create(nil);
    try
      SaveToConfig(mcf);
      mcf.SaveToStream(sh);
    finally
      FreeAndNil(mcf);
    end;
  end;
end;
{$ELSE}
procedure TutlSettings.SaveToFile(const aFile: string);
var
  fs: TFileStream;
  mcf: TutlMCFFile;
begin
  fs := TFileStream.Create(aFile, fmCreate);
  mcf := TutlMCFFile.Create(nil);
  try
    SaveToConfig(mcf);
    mcf.SaveToStream(fs);
  finally
    FreeAndNil(mcf);
    FreeAndNil(fs);
  end;
end;
{$ENDIF}

constructor TutlSettings.Create;
begin
  inherited Create;
  fBlocks:= TBlockList.Create(true);
  fRaiseChangedEventOnLoad := true;
end;

destructor TutlSettings.Destroy;
begin
  FreeAndNil(fBlocks);
  inherited Destroy;
end;

initialization
  utlSettings := TutlSettings.Create;

finalization
  FreeAndNil(utlSettings);

end.