lazarus/components/lazutils/lazconfigstorage.pas

1159 lines
34 KiB
ObjectPascal

{
*****************************************************************************
This file is part of LazUtils.
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Author: Mattias Gaertner
Abstract:
This unit defines various base classes for loading and saving of configs.
}
unit LazConfigStorage;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo, AVL_Tree,
// LazUtils
LazLoggerBase, AvgLvlTree, LazStringUtils;
type
{ TConfigStorage }
TConfigStorage = class
private
FPathStack: TStrings;
FCurrentBasePath: string;
protected
function GetFullPathValue(const APath, ADefault: String): String; virtual; abstract;
function GetFullPathValue(const APath: String; ADefault: Integer): Integer; virtual; abstract;
function GetFullPathValue(const APath: String; ADefault: Boolean): Boolean; virtual; abstract;
procedure SetFullPathValue(const APath, AValue: String); virtual; abstract;
procedure SetDeleteFullPathValue(const APath, AValue, DefValue: String); virtual; abstract;
procedure SetFullPathValue(const APath: String; AValue: Integer); virtual; abstract;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Integer); virtual; abstract;
procedure SetFullPathValue(const APath: String; AValue: Boolean); virtual; abstract;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Boolean); virtual; abstract;
procedure DeleteFullPath(const APath: string); virtual; abstract;
procedure DeleteFullPathValue(const APath: string); virtual; abstract;
protected
procedure WriteProperty(Path: String; Instance: TPersistent;
PropInfo: Pointer; DefInstance: TPersistent = nil;
OnlyProperty: String= '');
procedure ReadProperty(Path: String; Instance: TPersistent;
PropInfo: Pointer; DefInstance: TPersistent = nil;
OnlyProperty: String= '');
public
constructor Create(const {%H-}Filename: string; {%H-}LoadFromDisk: Boolean); virtual;
destructor Destroy; override;
procedure Clear; virtual; abstract;
function GetValue(const APath, ADefault: String): String;
function GetValue(const APath: String; ADefault: Integer): Integer;
function GetValue(const APath: String; ADefault: Boolean): Boolean;
procedure GetValue(const APath: String; out ARect: TRect;
const ADefault: TRect);
procedure GetValue(const APath: String; out APoint: TPoint;
const ADefault: TPoint);
procedure GetValue(const APath: String; const List: TStrings);
procedure SetValue(const APath, AValue: String);
procedure SetDeleteValue(const APath, AValue, DefValue: String);
procedure SetValue(const APath: String; AValue: Integer);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer);
procedure SetValue(const APath: String; AValue: Boolean);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
procedure SetValue(const APath: String; const AValue: TRect);
procedure SetDeleteValue(const APath: String; const AValue, DefValue: TRect);
procedure SetValue(const APath: String; const AValue: TPoint);
procedure SetDeleteValue(const APath: String; const AValue, DefValue: TPoint);
procedure SetValue(const APath: String; const AValue: TStrings);
procedure DeletePath(const APath: string);
procedure DeleteValue(const APath: string);
property CurrentBasePath: string read FCurrentBasePath;
function ExtendPath(const APath: string): string;
procedure AppendBasePath(const Path: string);
procedure UndoAppendBasePath;
procedure WriteToDisk; virtual; abstract;
function GetFilename: string; virtual; abstract;
procedure WriteObject(Path: String; Obj: TPersistent;
DefObject: TPersistent= nil; OnlyProperty: String= '');
procedure ReadObject(Path: String; Obj: TPersistent;
DefObject: TPersistent= nil; OnlyProperty: String= '');
end;
TConfigStorageClass = class of TConfigStorage;
{ TConfigMemStorageNode }
TConfigMemStorageNode = class
public
Name: string;
Value: string;
Parent: TConfigMemStorageNode;
Children: TAvlTree; // tree of TConfigMemStorageNode
procedure ClearChilds;
constructor Create(AParent: TConfigMemStorageNode; const AName: string);
destructor Destroy; override;
end;
TConfigMemStorageModification = (cmsmSet, cmsmGet, cmsmDelete, cmsmDeleteValue);
const
ConfigMemStorageFormatVersion = 2; // change this when format changes
type
{ TConfigMemStorage }
TConfigMemStorage = class(TConfigStorage)
private
procedure CreateRoot;
procedure CreateChilds(Node: TConfigMemStorageNode);
procedure Modify(const APath: string; Mode: TConfigMemStorageModification;
var AValue: string);
protected
procedure DeleteFullPath(const APath: string); override;
procedure DeleteFullPathValue(const APath: string); override;
function GetFullPathValue(const APath, ADefault: String): String; override;
function GetFullPathValue(const APath: String; ADefault: Boolean): Boolean;
override;
function GetFullPathValue(const APath: String; ADefault: Integer): Integer;
override;
procedure SetDeleteFullPathValue(const APath, AValue, DefValue: String);
override;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue:
Boolean); override;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue:
Integer); override;
procedure SetFullPathValue(const APath, AValue: String); override;
procedure SetFullPathValue(const APath: String; AValue: Boolean); override;
procedure SetFullPathValue(const APath: String; AValue: Integer); override;
public
Root: TConfigMemStorageNode;
function GetFilename: string; override;
procedure WriteToDisk; override;
destructor Destroy; override;
procedure Clear; override;
procedure SaveToConfig(Config: TConfigStorage; const APath: string);
procedure LoadFromConfig(Config: TConfigStorage; const APath: string);
procedure WriteDebugReport;
end;
procedure LoadStringToStringTree(Config: TConfigStorage; const Path: string;
Tree: TStringToStringTree);
procedure SaveStringToStringTree(Config: TConfigStorage; const Path: string;
Tree: TStringToStringTree);
// store date locale independent, thread safe
const DateAsCfgStrFormat='YYYYMMDD';
const DateTimeAsCfgStrFormat='YYYY/MM/DD HH:NN:SS';
function DateToCfgStr(const Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): string;
function CfgStrToDate(const s: string; out Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): boolean;
function CompareConfigMemStorageNames(p1, p2: PChar): integer;
function CompareConfigMemStorageNodes(Node1, Node2: Pointer): integer;
function ComparePCharWithConfigMemStorageNode(aPChar, ANode: Pointer): integer;
implementation
procedure LoadStringToStringTree(Config: TConfigStorage; const Path: string;
Tree: TStringToStringTree);
var
Cnt: LongInt;
SubPath: String;
CurName: String;
CurValue: String;
i: Integer;
begin
Tree.Clear;
Cnt:=Config.GetValue(Path+'Count',0);
for i:=0 to Cnt-1 do begin
SubPath:=Path+'Item'+IntToStr(i)+'/';
CurName:=Config.GetValue(SubPath+'Name','');
CurValue:=Config.GetValue(SubPath+'Value','');
Tree.Values[CurName]:=CurValue;
end;
end;
procedure SaveStringToStringTree(Config: TConfigStorage; const Path: string;
Tree: TStringToStringTree);
var
Node: TAvlTreeNode;
Item: PStringToStringItem;
i: Integer;
SubPath: String;
begin
Config.SetDeleteValue(Path+'Count',Tree.Tree.Count,0);
Node:=Tree.Tree.FindLowest;
i:=0;
while Node<>nil do begin
Item:=PStringToStringItem(Node.Data);
SubPath:=Path+'Item'+IntToStr(i)+'/';
Config.SetDeleteValue(SubPath+'Name',Item^.Name,'');
Config.SetDeleteValue(SubPath+'Value',Item^.Value,'');
Node:=Tree.Tree.FindSuccessor(Node);
inc(i);
end;
end;
function DateToCfgStr(const Date: TDateTime; const aFormat: string): string;
var
NeedDate: Boolean;
NeedTime: Boolean;
Year: word;
Month: word;
Day: word;
Hour: word;
Minute: word;
Second: word;
MilliSecond: word;
p: Integer;
w: Word;
StartP: Integer;
s: String;
l: Integer;
begin
Result:=aFormat;
NeedDate:=false;
NeedTime:=false;
for p:=1 to length(aFormat) do
case aFormat[p] of
'Y','M','D': NeedDate:=true;
'H','N','S','Z': NeedTime:=true;
end;
if NeedDate then
DecodeDate(Date,Year,Month,Day);
if NeedTime then
DecodeTime(Date,Hour,Minute,Second,MilliSecond);
p:=1;
while p<=length(aFormat) do begin
case aFormat[p] of
'Y': w:=Year;
'M': w:=Month;
'D': w:=Day;
'H': w:=Hour;
'N': w:=Minute;
'S': w:=Second;
'Z': w:=MilliSecond;
else
inc(p);
continue;
end;
StartP:=p;
repeat
inc(p);
until (p>length(aFormat)) or (aFormat[p]<>aFormat[p-1]);
l:=p-StartP;
s:=IntToStr(w);
if length(s)<l then
s:=StringOfChar('0',l-length(s))+s
else if length(s)>l then
raise Exception.Create('date format does not fit');
ReplaceSubstring(Result,StartP,l,s);
p:=StartP+length(s);
end;
//debugln('DateToCfgStr "',Result,'"');
end;
function CfgStrToDate(const s: string; out Date: TDateTime;
const aFormat: string): boolean;
procedure AddDecimal(var d: word; c: char); inline;
begin
d:=d*10+ord(c)-ord('0');
end;
var
i: Integer;
Year, Month, Day, Hour, Minute, Second, MilliSecond: word;
begin
//debugln('CfgStrToDate "',s,'"');
if length(s)<>length(aFormat) then begin
Date:=0.0;
exit(false);
end;
try
Year:=0;
Month:=0;
Day:=0;
Hour:=0;
Minute:=0;
Second:=0;
MilliSecond:=0;
for i:=1 to length(aFormat) do begin
case aFormat[i] of
'Y': AddDecimal(Year,s[i]);
'M': AddDecimal(Month,s[i]);
'D': AddDecimal(Day,s[i]);
'H': AddDecimal(Hour,s[i]);
'N': AddDecimal(Minute,s[i]);
'S': AddDecimal(Second,s[i]);
'Z': AddDecimal(MilliSecond,s[i]);
end;
end;
Date:=ComposeDateTime(EncodeDate(Year,Month,Day),EncodeTime(Hour,Minute,Second,MilliSecond));
Result:=true;
except
Result:=false;
end;
end;
function CompareConfigMemStorageNames(p1, p2: PChar): integer;
// compare strings till / or #0
begin
if (p1=nil) then begin
if (p2=nil) or (p2^ in ['/',#0]) then begin
// both empty
Result:=0;
end else begin
// p1 shorter
Result:=-1;
end;
end else begin
if p2=nil then begin
// p2 shorter
Result:=1;
end else begin
Result:=0;
repeat
if p1^ in ['/',#0] then begin
if p2^ in ['/',#0] then begin
// same
exit(0);
end else begin
// p1 shorter
exit(-1);
end;
end else begin
if p2^ in ['/',#0] then begin
// p2 shorter
exit(1);
end else if p1^=p2^ then begin
// continue
end else begin
// differ
exit(ord(p1^)-ord(p2^));
end;
end;
inc(p1);
inc(p2);
until false;
end;
end;
end;
function CompareConfigMemStorageNodes(Node1, Node2: Pointer): integer;
var
CfgNode1: TConfigMemStorageNode absolute Node1;
CfgNode2: TConfigMemStorageNode absolute Node2;
begin
Result:=CompareConfigMemStorageNames(PChar(CfgNode1.Name),PChar(CfgNode2.Name));
end;
function ComparePCharWithConfigMemStorageNode(aPChar, ANode: Pointer): integer;
begin
Result:=CompareConfigMemStorageNames(PChar(aPChar),
PChar(TConfigMemStorageNode(ANode).Name));
end;
{ TConfigStorage }
procedure TConfigStorage.WriteProperty(Path: String; Instance: TPersistent; PropInfo: Pointer;
DefInstance: TPersistent; OnlyProperty: String);
// based on FPC TWriter
// path is already extende
type
tset = set of 0..31;
var
i: Integer;
PropType: PTypeInfo;
Value, DefValue: LongInt;
Ident: String;
IntToIdentFn: TIntToIdent;
SetType: Pointer;
FloatValue, DefFloatValue: Extended;
//WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
//Int64Value, DefInt64Value: Int64;
BoolValue, DefBoolValue: boolean;
begin
// do not stream properties without getter and setter
if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
Assigned(PPropInfo(PropInfo)^.SetProc)) then
exit;
PropType := PPropInfo(PropInfo)^.PropType;
Path := Path + PPropInfo(PropInfo)^.Name;
if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
exit;
case PropType^.Kind of
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
begin
Value := GetOrdProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefValue := GetOrdProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (Value = DefValue) then
DeleteValue(Path)
else begin
case PropType^.Kind of
tkInteger:
begin // Check if this integer has a string identifier
IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident{%H-}) then
SetValue(Path, Ident) // Integer can be written a human-readable identifier
else
SetValue(Path, Value); // Integer has to be written just as number
end;
tkChar:
SetValue(Path, Chr(Value));
tkWChar:
SetValue(Path, Value);
tkSet:
begin
SetType := GetTypeData(PropType)^.CompType;
Ident := '';
for i := 0 to 31 do
if (i in tset(Value)) then begin
if Ident <> '' then Ident := Ident + ',';
Ident := Ident + GetEnumName(PTypeInfo(SetType), i);
end;
SetValue(Path, Ident);
end;
tkEnumeration:
SetValue(Path, GetEnumName(PropType, Value));
end;
end;
end;
tkFloat:
begin
FloatValue := GetFloatProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefFloatValue := GetFloatProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (DefFloatValue = FloatValue) then
DeleteValue(Path)
else
SetValue(Path, FloatToStr(FloatValue));
end;
tkSString, tkLString, tkAString:
begin
StrValue := GetStrProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefStrValue := GetStrProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (DefStrValue = StrValue) then
DeleteValue(Path)
else
SetValue(Path, StrValue);
end;
(* tkWString:
begin
WStrValue := GetWideStrProp(Instance, PropInfo);
if (DefInstance <> nil) then
WDefStrValue := GetWideStrProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (WDefStrValue = WStrValue) then
DeleteValue(Path)
else
SetValue(Path, WStrValue);
end;*)
(* tkInt64, tkQWord:
begin
Int64Value := GetInt64Prop(Instance, PropInfo);
if (DefInstance <> nil) then
DefInt64Value := GetInt64Prop(DefInstance, PropInfo)
if (DefInstance <> nil) and (Int64Value = DefInt64Value) then
DeleteValue(Path, Path)
else
SetValue(StrValue);
end;*)
tkBool:
begin
BoolValue := GetOrdProp(Instance, PropInfo)<>0;
if (DefInstance <> nil) then
DefBoolValue := GetOrdProp(DefInstance, PropInfo)<>0;
if (DefInstance <> nil) and (BoolValue = DefBoolValue) then
DeleteValue(Path)
else
SetValue(Path, BoolValue);
end;
end;
end;
procedure TConfigStorage.ReadProperty(Path: String; Instance: TPersistent; PropInfo: Pointer;
DefInstance: TPersistent; OnlyProperty: String);
type
tset = set of 0..31;
var
i, j: Integer;
PropType: PTypeInfo;
Value, DefValue: LongInt;
Ident, s: String;
IdentToIntFn: TIdentToInt;
SetType: Pointer;
FloatValue, DefFloatValue: Extended;
//WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
//Int64Value, DefInt64Value: Int64;
BoolValue, DefBoolValue: boolean;
begin
// do not stream properties without getter and setter
if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
Assigned(PPropInfo(PropInfo)^.SetProc)) then
exit;
PropType := PPropInfo(PropInfo)^.PropType;
Path := Path + PPropInfo(PropInfo)^.Name;
if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
exit;
if DefInstance = nil then
DefInstance := Instance;
case PropType^.Kind of
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
begin
DefValue := GetOrdProp(DefInstance, PropInfo);
case PropType^.Kind of
tkInteger:
begin // Check if this integer has a string identifier
Ident := GetValue(Path, IntToStr(DefValue));
IdentToIntFn := FindIdentToInt(PPropInfo(PropInfo)^.PropType);
if TryStrToInt(Ident, Value) then
SetOrdProp(Instance, PropInfo, Value)
else if Assigned(IdentToIntFn) and IdentToIntFn(Ident, Value) then
SetOrdProp(Instance, PropInfo, Value)
else
SetOrdProp(Instance, PropInfo, DefValue)
end;
tkChar:
begin
Ident := GetValue(Path, chr(DefValue));
if Length(Ident) > 0 then
SetOrdProp(Instance, PropInfo, ord(Ident[1]))
else
SetOrdProp(Instance, PropInfo, DefValue);
end;
tkWChar:
SetOrdProp(Instance, PropInfo, GetValue(Path, DefValue));
tkSet:
begin
SetType := GetTypeData(PropType)^.CompType;
Ident := GetValue(Path, '-');
If Ident = '-' then
Value := DefValue
else begin
Value := 0;
while length(Ident) > 0 do begin
i := Pos(',', Ident);
if i < 1 then
i := length(Ident) + 1;
s := copy(Ident, 1, i-1);
Ident := copy(Ident, i+1, length(Ident));
j := GetEnumValue(PTypeInfo(SetType), s);
if j <> -1 then
include(tset(Value), j)
else Begin
Value := DefValue;
break;
end;
end;
end;
SetOrdProp(Instance, PropInfo, Value);
end;
tkEnumeration:
begin
Ident := GetValue(Path, '-');
If Ident = '-' then
Value := DefValue
else
Value := GetEnumValue(PropType, Ident);
if Value <> -1 then
SetOrdProp(Instance, PropInfo, Value)
else
SetOrdProp(Instance, PropInfo, DefValue);
end;
end;
end;
tkFloat:
begin
DefFloatValue := GetFloatProp(DefInstance, PropInfo);
Ident := GetValue(Path, FloatToStr(DefFloatValue));
if TryStrToFloat(Ident, FloatValue) then
SetFloatProp(Instance, PropInfo, FloatValue)
else
SetFloatProp(Instance, PropInfo, DefFloatValue)
end;
tkSString, tkLString, tkAString:
begin
DefStrValue := GetStrProp(DefInstance, PropInfo);
StrValue := GetValue(Path, DefStrValue);
SetStrProp(Instance, PropInfo, StrValue)
end;
(* tkWString:
begin
end;*)
(* tkInt64, tkQWord:
begin
end;*)
tkBool:
begin
DefBoolValue := GetOrdProp(DefInstance, PropInfo) <> 0;
BoolValue := GetValue(Path, DefBoolValue);
SetOrdProp(Instance, PropInfo, ord(BoolValue));
end;
end;
end;
constructor TConfigStorage.Create(const Filename: string; LoadFromDisk: Boolean
);
begin
end;
destructor TConfigStorage.Destroy;
begin
FPathStack.Free;
inherited Destroy;
end;
function TConfigStorage.GetValue(const APath, ADefault: String): String;
begin
Result:=GetFullPathValue(ExtendPath(APath),ADefault);
end;
function TConfigStorage.GetValue(const APath: String; ADefault: Integer
): Integer;
begin
Result:=GetFullPathValue(ExtendPath(APath),ADefault);
end;
function TConfigStorage.GetValue(const APath: String; ADefault: Boolean
): Boolean;
begin
Result:=GetFullPathValue(ExtendPath(APath),ADefault);
end;
procedure TConfigStorage.GetValue(const APath: String; out ARect: TRect;
const ADefault: TRect);
begin
ARect.Left:=GetValue(APath+'Left',ADefault.Left);
ARect.Top:=GetValue(APath+'Top',ADefault.Top);
ARect.Right:=GetValue(APath+'Right',ADefault.Right);
ARect.Bottom:=GetValue(APath+'Bottom',ADefault.Bottom);
end;
procedure TConfigStorage.GetValue(const APath: String; out APoint: TPoint;
const ADefault: TPoint);
begin
APoint.X:=GetValue(APath+'X',ADefault.X);
APoint.Y:=GetValue(APath+'Y',ADefault.Y);
end;
procedure TConfigStorage.GetValue(const APath: String; const List: TStrings);
var
NewCount: LongInt;
i: Integer;
NewLine: String;
begin
NewCount:=GetValue(APath+'Count',0);
for i:=0 to NewCount-1 do begin
NewLine:=GetValue(APath+'Item'+IntToStr(i+1)+'/Value','');
if List.Count>i then
List[i]:=NewLine
else
List.Add(NewLine);
end;
while List.Count>NewCount do List.Delete(List.Count-1);
end;
procedure TConfigStorage.SetValue(const APath, AValue: String);
begin
SetFullPathValue(ExtendPath(APath),AValue);
end;
procedure TConfigStorage.SetDeleteValue(const APath, AValue, DefValue: String);
begin
SetDeleteFullPathValue(ExtendPath(APath),AValue,DefValue);
end;
procedure TConfigStorage.SetValue(const APath: String; AValue: Integer);
begin
SetFullPathValue(ExtendPath(APath),AValue);
end;
procedure TConfigStorage.SetDeleteValue(const APath: String; AValue,
DefValue: Integer);
begin
SetDeleteFullPathValue(ExtendPath(APath),AValue,DefValue);
end;
procedure TConfigStorage.SetValue(const APath: String; AValue: Boolean);
begin
SetFullPathValue(ExtendPath(APath),AValue);
end;
procedure TConfigStorage.SetDeleteValue(const APath: String; AValue,
DefValue: Boolean);
begin
SetDeleteFullPathValue(ExtendPath(APath),AValue,DefValue);
end;
procedure TConfigStorage.SetValue(const APath: String; const AValue: TRect);
begin
SetValue(APath+'Left',AValue.Left);
SetValue(APath+'Top',AValue.Top);
SetValue(APath+'Right',AValue.Right);
SetValue(APath+'Bottom',AValue.Bottom);
end;
procedure TConfigStorage.SetDeleteValue(const APath: String; const AValue,
DefValue: TRect);
begin
SetDeleteValue(APath+'Left',AValue.Left,DefValue.Left);
SetDeleteValue(APath+'Top',AValue.Top,DefValue.Top);
SetDeleteValue(APath+'Right',AValue.Right,DefValue.Right);
SetDeleteValue(APath+'Bottom',AValue.Bottom,DefValue.Bottom);
end;
procedure TConfigStorage.SetValue(const APath: String; const AValue: TPoint);
begin
SetValue(APath+'X',AValue.X);
SetValue(APath+'Y',AValue.Y);
end;
procedure TConfigStorage.SetDeleteValue(const APath: String; const AValue,
DefValue: TPoint);
begin
SetDeleteValue(APath+'X',AValue.X,DefValue.X);
SetDeleteValue(APath+'Y',AValue.Y,DefValue.Y);
end;
procedure TConfigStorage.SetValue(const APath: String; const AValue: TStrings);
var
i: Integer;
begin
SetDeleteValue(APath+'Count',AValue.Count,0);
for i:=0 to AValue.Count-1 do
SetDeleteValue(APath+'Item'+IntToStr(i+1)+'/Value',AValue[i],'');
end;
procedure TConfigStorage.DeletePath(const APath: string);
begin
DeleteFullPath(ExtendPath(APath));
end;
procedure TConfigStorage.DeleteValue(const APath: string);
begin
DeleteFullPathValue(ExtendPath(APath));
end;
function TConfigStorage.ExtendPath(const APath: string): string;
begin
Result:=FCurrentBasePath+APath;
end;
procedure TConfigStorage.AppendBasePath(const Path: string);
begin
if FPathStack=nil then FPathStack:=TStringList.Create;
FPathStack.Add(FCurrentBasePath);
FCurrentBasePath:=FCurrentBasePath+Path;
if (FCurrentBasePath<>'')
and (FCurrentBasePath[length(FCurrentBasePath)]<>'/') then
FCurrentBasePath:=FCurrentBasePath+'/';
end;
procedure TConfigStorage.UndoAppendBasePath;
begin
if (FPathStack=nil) or (FPathStack.Count=0) then
raise Exception.Create('TConfigStorage.UndoAppendBasePath');
FCurrentBasePath:=FPathStack[FPathStack.Count-1];
FPathStack.Delete(FPathStack.Count-1);
end;
procedure TConfigStorage.WriteObject(Path: String; Obj: TPersistent; DefObject: TPersistent;
OnlyProperty: String);
var
PropCount,i : integer;
PropList : PPropList;
begin
// Do Not extebd the path, individual SetValue will be called, and Extend it
//Path := ExtendPath(Path);
PropCount:=GetPropList(Obj,PropList);
if PropCount>0 then begin
try
for i := 0 to PropCount-1 do
WriteProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
finally
Freemem(PropList);
end;
end;
end;
procedure TConfigStorage.ReadObject(Path: String; Obj: TPersistent; DefObject: TPersistent;
OnlyProperty: String);
var
PropCount,i : integer;
PropList : PPropList;
begin
// Do Not extebd the path, individual SetValue will be called, and Extend it
//Path := ExtendPath(Path);
PropCount:=GetPropList(Obj,PropList);
if PropCount>0 then begin
try
for i := 0 to PropCount-1 do
ReadProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
finally
Freemem(PropList);
end;
end;
end;
{ TConfigMemStorage }
procedure TConfigMemStorage.CreateRoot;
begin
Root:=TConfigMemStorageNode.Create(nil,'');
end;
procedure TConfigMemStorage.CreateChilds(Node: TConfigMemStorageNode);
begin
Node.Children:=TAvlTree.Create(@CompareConfigMemStorageNodes);
end;
procedure TConfigMemStorage.Modify(const APath: string;
Mode: TConfigMemStorageModification; var AValue: string);
var
Node: TConfigMemStorageNode;
p: PChar;
StartPos: PChar;
ChildNode: TAvlTreeNode;
Child: TConfigMemStorageNode;
NewName: string;
begin
//DebugLn(['TConfigMemStorage.Modify APath="',APath,'" Mode=',ord(Mode),' AValue="',AValue,'"']);
p:=PChar(APath);
if p=nil then begin
if Root<>nil then begin
if Mode in [cmsmDelete,cmsmDeleteValue] then
Root.Value:='';
if Mode=cmsmDelete then
Root.ClearChilds;
end;
end else begin
if Root=nil then begin
if Mode in [cmsmDelete,cmsmDeleteValue] then exit;
CreateRoot;
end;
Node:=Root;
repeat
StartPos:=p;
while (not (p^ in ['/',#0])) do inc(p);
//DebugLn(['TConfigMemStorage.Modify Node="',Node.Name,'" StartPos="',StartPos,'"']);
// child node
if Node.Children=nil then begin
if Mode in [cmsmDelete,cmsmDeleteValue,cmsmGet] then exit;
CreateChilds(Node);
end;
ChildNode:=Node.Children.FindKey(StartPos,@ComparePCharWithConfigMemStorageNode);
if ChildNode=nil then begin
if Mode in [cmsmDelete,cmsmDeleteValue,cmsmGet] then exit;
NewName:='';
SetLength(NewName,p-StartPos);
if NewName<>'' then
System.Move(StartPos^,NewName[1],p-StartPos);
//DebugLn(['TConfigMemStorage.Modify Adding "',NewName,'"']);
Child:=TConfigMemStorageNode.Create(Node,NewName);
Node.Children.Add(Child);
end else
Child:=TConfigMemStorageNode(ChildNode.Data);
Node:=Child;
if p^='/' then begin
// next level
while (p^='/') do inc(p);
end else begin
// end of path
case Mode of
cmsmSet: Node.Value:=AValue;
cmsmGet: AValue:=Node.Value;
cmsmDelete,cmsmDeleteValue:
begin
Node.Value:='';
if Mode=cmsmDelete then
Node.ClearChilds;
while (Node<>nil) and ((Node.Children=nil) or (Node.Children.Count=0))
do begin
Child:=Node;
Node:=Node.Parent;
if Root=Child then Root:=nil;
Child.Free;
end;
end;
end;
exit;
end;
until false;
end;
end;
procedure TConfigMemStorage.DeleteFullPath(const APath: string);
var
V: string;
begin
V:='';
Modify(APath,cmsmDelete,V);
end;
procedure TConfigMemStorage.DeleteFullPathValue(const APath: string);
var
V: string;
begin
V:='';
Modify(APath,cmsmDeleteValue,V);
end;
function TConfigMemStorage.GetFullPathValue(const APath, ADefault: String
): String;
begin
Result:=ADefault;
Modify(APath,cmsmGet,Result);
end;
function TConfigMemStorage.GetFullPathValue(const APath: String; ADefault:
Boolean): Boolean;
var
s: string;
begin
if ADefault then
s := 'True'
else
s := 'False';
s := GetFullPathValue(APath, s);
if CompareText(s,'TRUE')=0 then
Result := True
else if CompareText(s,'FALSE')=0 then
Result := False
else
Result := ADefault;
end;
function TConfigMemStorage.GetFullPathValue(const APath: String; ADefault:
Integer): Integer;
begin
Result := StrToIntDef(GetFullPathValue(APath, IntToStr(ADefault)),ADefault);
end;
procedure TConfigMemStorage.SetDeleteFullPathValue(const APath, AValue, DefValue
: String);
begin
if AValue=DefValue then
DeleteFullPathValue(APath)
else
SetFullPathValue(APath,AValue);
end;
procedure TConfigMemStorage.SetDeleteFullPathValue(const APath: String; AValue,
DefValue: Boolean);
begin
if AValue=DefValue then
DeleteFullPath(APath)
else
SetFullPathValue(APath,AValue);
end;
procedure TConfigMemStorage.SetDeleteFullPathValue(const APath: String; AValue,
DefValue: Integer);
begin
if AValue=DefValue then
DeleteFullPath(APath)
else
SetFullPathValue(APath,AValue);
end;
procedure TConfigMemStorage.SetFullPathValue(const APath, AValue: String);
var
V: String;
begin
V:=AValue;
Modify(APath,cmsmSet,V);
end;
procedure TConfigMemStorage.SetFullPathValue(const APath: String; AValue:
Boolean);
begin
if AValue then
SetFullPathValue(APath, 'True')
else
SetFullPathValue(APath, 'False');
end;
procedure TConfigMemStorage.SetFullPathValue(const APath: String; AValue:
Integer);
begin
SetFullPathValue(APath,IntToStr(AValue));
end;
function TConfigMemStorage.GetFilename: string;
begin
Result:='';
end;
procedure TConfigMemStorage.WriteToDisk;
begin
raise Exception.Create('TConfigMemStorage.WriteToDisk invalid operation');
end;
destructor TConfigMemStorage.Destroy;
begin
FreeAndNil(Root);
inherited Destroy;
end;
procedure TConfigMemStorage.Clear;
begin
FreeAndNil(Root);
end;
procedure TConfigMemStorage.SaveToConfig(Config: TConfigStorage;
const APath: string);
procedure Save(Node: TConfigMemStorageNode; SubPath: string);
var
ChildNode: TAvlTreeNode;
Child: TConfigMemStorageNode;
Names: String;
begin
if Node=nil then exit;
if (Node<>Root) then
SubPath:=SubPath+'_'+Node.Name+'/';
Config.SetDeleteValue(SubPath+'Value',Node.Value,'');
Names:='';
if Node.Children<>nil then begin
ChildNode:=Node.Children.FindLowest;
while ChildNode<>nil do begin
Child:=TConfigMemStorageNode(ChildNode.Data);
if Names<>'' then Names:=Names+'/';
Names:=Names+Child.Name;
Save(Child,SubPath);
ChildNode:=Node.Children.FindSuccessor(ChildNode);
end;
end;
Config.SetDeleteValue(SubPath+'Items',Names,'');
end;
begin
Save(Root,APath);
if (Root<>nil) and ((Root.Value<>'') or (Root.Children<>nil)) then
Config.SetValue(APath+'Version',ConfigMemStorageFormatVersion);
end;
procedure TConfigMemStorage.LoadFromConfig(Config: TConfigStorage;
const APath: string);
var
StorageVersion: LongInt;
procedure Load(Node: TConfigMemStorageNode; SubPath: string);
var
ChildNames: string;
ChildName: string;
p: PChar;
StartPos: PChar;
Child: TConfigMemStorageNode;
begin
if Node=nil then exit;
if (Node<>Root) then
SubPath:=SubPath+'_'+Node.Name+'/';
Node.Value:=Config.GetValue(SubPath+'Value','');
if StorageVersion<2 then
ChildNames:=Config.GetValue(SubPath+'Childs','')
else
ChildNames:=Config.GetValue(SubPath+'Items','');
//DebugLn(['Load SubPath="',SubPath,'" Value="',Node.Value,'" ChildNames="',ChildNames,'"']);
if ChildNames<>'' then begin
p:=PChar(ChildNames);
repeat
StartPos:=p;
while not (p^ in ['/',#0]) do inc(p);
ChildName:='';
SetLength(ChildName,p-StartPos);
if ChildName<>'' then
System.Move(StartPos^,ChildName[1],p-StartPos);
Child:=TConfigMemStorageNode.Create(Node,ChildName);
if Node.Children=nil then
CreateChilds(Node);
Node.Children.Add(Child);
Load(Child,SubPath);
if p^=#0 then break;
inc(p);
until false;
end;
end;
begin
//DebugLn(['TConfigMemStorage.LoadFromConfig ']);
Clear;
if Root=nil then
CreateRoot;
StorageVersion:=Config.GetValue(APath+'Version',0);
//debugln(['TConfigMemStorage.LoadFromConfig ',APath,' Version=',StorageVersion]);
Load(Root,APath);
end;
procedure TConfigMemStorage.WriteDebugReport;
procedure w(Node: TConfigMemStorageNode; Prefix: string);
var
AVLNode: TAvlTreeNode;
begin
if Node=nil then exit;
DebugLn(['TConfigMemStorage.WriteDebugReport ',Prefix,'Name="',Node.Name,'" Value="',Node.Value,'"']);
if Node.Children<>nil then begin
AVLNode:=Node.Children.FindLowest;
while AVLNode<>nil do begin
w(TConfigMemStorageNode(AVLNode.Data),Prefix+' ');
AVLNode:=Node.Children.FindSuccessor(AVLNode);
end;
end;
end;
begin
DebugLn(['TConfigMemStorage.WriteDebugReport ']);
w(Root,'');
end;
{ TConfigMemStorageNode }
procedure TConfigMemStorageNode.ClearChilds;
var
OldChilds: TAvlTree;
begin
if Children<>nil then begin
OldChilds:=Children;
Children:=nil;
OldChilds.FreeAndClear;
OldChilds.Free;
end;
end;
constructor TConfigMemStorageNode.Create(AParent: TConfigMemStorageNode;
const AName: string);
begin
Parent:=AParent;
Name:=AName;
end;
destructor TConfigMemStorageNode.Destroy;
begin
ClearChilds;
if (Parent<>nil) and (Parent.Children<>nil) then
Parent.Children.Remove(Self);
inherited Destroy;
end;
end.