|
- 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.
|