1
0
mirror of synced 2024-12-22 01:03:07 +01:00

Fixed: VirtualTree columns revert to ParentColor properly in SortColumn

Changed: X2UtConfig implementation
This commit is contained in:
Mark van Renswoude 2005-10-18 09:25:05 +00:00
parent 909f804569
commit f5535247fa
8 changed files with 1228 additions and 441 deletions

View File

@ -9,11 +9,23 @@ type
TSettingsTest = class(TTestCase) TSettingsTest = class(TTestCase)
protected protected
function CreateSource(): IX2ConfigSource; virtual; abstract; function CreateSource(): IX2ConfigSource; virtual; abstract;
published
procedure Read();
procedure Write();
procedure Delete();
procedure Save(); virtual; abstract;
end; end;
TSettingsINITest = class(TSettingsTest) TSettingsINITest = class(TSettingsTest)
protected protected
function CreateSource(): IX2ConfigSource; override; function CreateSource(): IX2ConfigSource; override;
published
procedure Save(); override;
procedure StringRange();
procedure IntegerRange();
private
procedure FloatRange();
end; end;
TSettingsRegistryTest = class(TSettingsTest) TSettingsRegistryTest = class(TSettingsTest)
@ -37,13 +49,112 @@ type
end; end;
implementation implementation
uses
Classes,
SysUtils,
madExcept,
X2UtConfigIni,
X2UtConfigRanges;
{ TSettingsINITest } { TSettingsINITest }
function TSettingsINITest.CreateSource(): IX2ConfigSource; function TSettingsINITest.CreateSource(): IX2ConfigSource;
var
ssData: TStringStream;
begin
ssData := TStringStream.Create('[ReadTest]'#13#10 +
'SomeKey=SomeValue');
try
Result := TX2IniConfigSource.Create(ssData);
finally
FreeAndNil(ssData);
end;
end;
procedure TSettingsINITest.Save;
var
ssData: TStringStream;
begin
ssData := TStringStream.Create('');
try
with CreateSource() do
begin
with Configs('SaveTest') do
begin
Write('String', 'Test');
Write('Integer', 5);
Write('Float', 3.5);
Write('Boolean', True);
end;
Save(ssData);
end;
ssData.Seek(0, soFromBeginning);
with (TX2IniConfigSource.Create(ssData) as IX2ConfigSource) do
begin
CheckTrue(Exists('ReadTest'), 'ReadTest not found');
CheckTrue(Exists('SaveTest'), 'SaveTest not found');
with Configs('ReadTest') do
CheckTrue(Exists('SomeKey'), 'ReadTest.SomeKey not found');
with Configs('SaveTest') do
begin
CheckTrue(Exists('String'), 'SaveTest.String not found');
CheckTrue(Exists('Integer'), 'SaveTest.Integer not found');
CheckTrue(Exists('Float'), 'SaveTest.Float not found');
CheckTrue(Exists('Boolean'), 'SaveTest.Boolean not found');
end;
end;
finally
FreeAndNil(ssData);
end;
end;
procedure TSettingsINITest.StringRange;
begin
with CreateSource() do
begin
Register('RangeTest', 'String').Attach(TX2ConfigStringLengthRange.Create(5, 5, '0', spLeft));
with Configs('RangeTest') do
begin
Write('String', '1');
CheckEquals('00001', Read('String'));
Write('String', '1234567890');
CheckEquals('12345', Read('String'));
end;
end;
end;
procedure TSettingsINITest.IntegerRange;
begin
with CreateSource() do
begin
Register('RangeTest', 'Integer').Attach(TX2ConfigIntegerRange.Create(5, 10, 8));
with Configs('RangeTest') do
begin
Write('String', '1');
CheckEquals('00001', Read('String'));
Write('String', '1234567890');
CheckEquals('12345', Read('String'));
end;
end;
end;
procedure TSettingsINITest.FloatRange;
begin begin
end; end;
{ TSettingsRegistryTest } { TSettingsRegistryTest }
function TSettingsRegistryTest.CreateSource(): IX2ConfigSource; function TSettingsRegistryTest.CreateSource(): IX2ConfigSource;
begin begin
@ -69,11 +180,55 @@ begin
end; end;
{ TSettingsTest }
procedure TSettingsTest.Read;
begin
with CreateSource() do
CheckEquals('SomeValue', Configs('ReadTest').Read('SomeKey'));
end;
procedure TSettingsTest.Write;
begin
with CreateSource() do
begin
with Configs('WriteTest') do
begin
Write('NewKey', 255);
CheckEquals(255, Read('NewKey'));
end;
with Configs('ReadTest') do
begin
Write('SomeKey', 'NewValue');
CheckEquals('NewValue', Read('SomeKey'));
end;
end;
end;
procedure TSettingsTest.Delete;
begin
with CreateSource() do
begin
with Configs('DeleteTest') do
begin
Write('SomeKey', 'SomeValue');
Delete('SomeKey');
CheckFalse(Exists('SomeKey'));
end;
Delete('DeleteTest');
CheckFalse(Exists('DeleteTest'));
end;
end;
initialization initialization
RegisterTest('Settings', TSettingsINITest.Suite); RegisterTest('Settings', TSettingsINITest.Suite);
{
RegisterTest('Settings', TSettingsRegistryTest.Suite); RegisterTest('Settings', TSettingsRegistryTest.Suite);
RegisterTest('Settings', TSettingsXMLTest.Suite); RegisterTest('Settings', TSettingsXMLTest.Suite);
RegisterTest('Settings', TSettingsNiniXMLTest.Suite); RegisterTest('Settings', TSettingsNiniXMLTest.Suite);
RegisterTest('Settings', TSettingsCmdLineTest.Suite); RegisterTest('Settings', TSettingsCmdLineTest.Suite);
}
end. end.

View File

@ -25,6 +25,7 @@
-$YD -$YD
-$Z1 -$Z1
-cg -cg
-vn
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+ -H+
-W+ -W+

View File

@ -83,7 +83,7 @@ UnsafeCast=0
MapFile=0 MapFile=0
OutputObjs=0 OutputObjs=0
ConsoleApp=1 ConsoleApp=1
DebugInfo=0 DebugInfo=1
RemoteSymbols=0 RemoteSymbols=0
MinStackSize=16384 MinStackSize=16384
MaxStackSize=1048576 MaxStackSize=1048576

View File

@ -9,6 +9,11 @@
:: X2UtXMLConfigSource is capable of recognizing, reading and writing :: X2UtXMLConfigSource is capable of recognizing, reading and writing
:: Nini-compatible XML files. :: Nini-compatible XML files.
:: ::
:: To accomodate for tree structures, configuration names may contain a
:: dot (.) to separate the sections. While they are used as-is in flat
:: sources (INI), they are used for subkeys in tree source (Registry, XML).
:: The SectionSeparator variable is available for this purpose.
::
:: Last changed: $Date$ :: Last changed: $Date$
:: Revision: $Rev$ :: Revision: $Rev$
:: Author: $Author$ :: Author: $Author$
@ -19,187 +24,120 @@ interface
uses uses
Classes, Classes,
X2UtHashes, X2UtHashes;
X2UtHashesVariants;
type type
// Forward declarations // Forward declarations
IX2Config = interface; IX2ConfigSource = interface;
IX2ConfigSource = interface; IX2Config = interface;
IX2ConfigDefinition = interface;
IX2ConfigDefinitionObserver = interface;
{ {
:$ Callback for Iterate method. :$ Callback method for config iteration
} }
TX2ConfigIterateMethod = procedure(Sender: IX2ConfigSource; TX2ConfigIterateConfigs = procedure(Sender: IX2ConfigSource;
Config: IX2Config; const Name: String;
var Abort: Boolean) of object; const Data: Pointer) of object;
{ {
:$ Interface for configurations. :$ Callback method for value iteration
:: Implementations are highly recommended to descend from, or simply use,
:: TX2BaseConfig.
} }
IX2Config = interface TX2ConfigIterateValues = procedure(Sender: IX2Config;
['{25DF95C1-CE09-44A7-816B-A33B8D0D78DC}'] const Name: String;
function GetName(): String; const Data: Pointer) of object;
function ReadBool(const AName: String; const ADefault: Boolean = False): Boolean; {
function ReadFloat(const AName: String; const ADefault: Double = 0): Double; :$ Determines which values should be cleared.
function ReadInteger(const AName: String; const ADefault: Integer = 0): Integer;
function ReadString(const AName: String; const ADefault: String = ''): String;
procedure WriteBool(const AName: String; AValue: Boolean); :: caAll clears all values
procedure WriteFloat(const AName: String; AValue: Double); :: caDefined clears only values which have been defined using
procedure WriteInteger(const AName: String; AValue: Integer); :: IX2ConfigSource.Register
procedure WriteString(const AName, AValue: String); :: caUndefined clears only values which have not been defined using
:: IX2ConfigSource.Register
procedure Clear(); }
procedure Delete(const AName: String); TX2ConfigClearAction = (caAll, caDefined, caUndefined);
function Exists(const AName: String): Boolean;
procedure Save();
property Name: String read GetName;
end;
{ {
:$ Interface for configuration sources. :$ Interface for configuration sources.
:: For subsections, seperate each section name with a dot (.)
::
:: Implementations are highly recommended to descend from
:: TX2BaseConfigSource.
} }
IX2ConfigSource = interface IX2ConfigSource = interface
['{1FF5282B-122F-47D7-95E8-3DB60A8CF765}'] ['{1FF5282B-122F-47D7-95E8-3DB60A8CF765}']
function GetAutoSave(): Boolean; function GetAutoSave(): Boolean;
procedure SetAutoSave(Value: Boolean); procedure SetAutoSave(Value: Boolean);
procedure Reload();
procedure Save(); overload;
procedure Save(const AStream: TStream); overload;
function Configs(const AName: String): IX2Config; function Configs(const AName: String): IX2Config;
function Add(const AName: String): IX2Config;
function Exists(const AName: String): Boolean; function Exists(const AName: String): Boolean;
procedure Delete(const AName: String); procedure Delete(const AName: String);
procedure Clear(); procedure Clear(const AAction: TX2ConfigClearAction);
procedure Save(); procedure Iterate(const ACallback: TX2ConfigIterateConfigs;
const AData: Pointer);
procedure List(const AName: String; const ADest: TStrings; function Register(const AConfig, AName: String): IX2ConfigDefinition; overload;
const ARecurse: Boolean = False); function Register(const AConfig, AName: String;
procedure Iterate(const AName: String; const ADefault: Variant): IX2ConfigDefinition; overload;
const ACallback: TX2ConfigIterateMethod; function Definitions(const AConfig, AName: String): IX2ConfigDefinition;
const AData: Pointer;
const ARecurse: Boolean = False); overload;
property AutoSave: Boolean read GetAutoSave write SetAutoSave; property AutoSave: Boolean read GetAutoSave write SetAutoSave;
end; end;
// Forward declarations
TX2BaseConfig = class;
TX2BaseConfigSource = class;
{ {
:$ Hash for configuration objects. :$ Interface for configurations.
} }
TX2ConfigHash = class(TX2SOHash) IX2Config = interface
protected ['{25DF95C1-CE09-44A7-816B-A33B8D0D78DC}']
function GetCurrentValue(): TX2BaseConfig; function GetName(): String;
function GetValue(Key: String): TX2BaseConfig; function GetSource(): IX2ConfigSource;
procedure SetValue(Key: String; const Value: TX2BaseConfig);
public function Exists(const AName: String): Boolean;
property CurrentValue: TX2BaseConfig read GetCurrentValue; function Read(const AName: String): Variant; overload;
property Values[Key: String]: TX2BaseConfig read GetValue write SetValue; default; function Read(const AName: String; const ADefault: Variant): Variant; overload;
procedure Write(const AName: String; const AValue: Variant);
procedure Delete(const AName: String);
procedure Clear(const AAction: TX2ConfigClearAction);
procedure Iterate(const ACallback: TX2ConfigIterateValues;
const AData: Pointer);
property Name: String read GetName;
property Source: IX2ConfigSource read GetSource;
end; end;
{ {
:$ Default implementation for configurations. :$ Interface for configuration value definitions.
} }
TX2BaseConfig = class(TInterfacedObject, IX2Config) IX2ConfigDefinition = interface
private ['{00C67656-24FB-4CBE-81DC-B064A5550820}']
FConfigItems: TX2ConfigHash; function GetDefault(): Variant;
FName: String; function GetConfig(): String;
FSource: IX2ConfigSource;
FValues: TX2SVHash;
protected
procedure WriteValue(const AName: String; const AValue: Variant);
property Source: IX2ConfigSource read FSource;
property Values: TX2SVHash read FValues;
property ConfigItems: TX2ConfigHash read FConfigItems;
public
constructor Create(const AConfig: String; const ASource: IX2ConfigSource);
destructor Destroy(); override;
// IX2Config
function GetName(): String; function GetName(): String;
procedure SetDefault(Value: Variant);
function ReadBool(const AName: String; const ADefault: Boolean = False): Boolean; procedure Attach(const AObserver: IX2ConfigDefinitionObserver);
function ReadFloat(const AName: String; const ADefault: Double = 0): Double; procedure Detach(const AObserver: IX2ConfigDefinitionObserver);
function ReadInteger(const AName: String; const ADefault: Integer = 0): Integer;
function ReadString(const AName: String; const ADefault: String = ''): String;
procedure WriteBool(const AName: String; AValue: Boolean); procedure Read(var AValue: Variant);
procedure WriteFloat(const AName: String; AValue: Double); procedure Write(var AValue: Variant);
procedure WriteInteger(const AName: String; AValue: Integer);
procedure WriteString(const AName, AValue: String);
procedure Clear();
procedure Delete(const AName: String);
function Exists(const AName: String): Boolean;
procedure Save(); virtual;
property Default: Variant read GetDefault write SetDefault;
property Config: String read GetConfig;
property Name: String read GetName; property Name: String read GetName;
end; end;
{ {
:$ Default implementation for configuration sources. :$ Interface for configuration value definition observers.
} }
TX2BaseConfigSource = class(TInterfacedObject, IX2ConfigSource) IX2ConfigDefinitionObserver = interface
private ['{EE20E59D-6642-42D7-A520-6A4F1C5FD3EA}']
FAutoSave: Boolean; procedure Read(const AConfig, AName: String; var AValue: Variant);
FConfigItems: TX2ConfigHash; procedure Write(const AConfig, AName: String; var AValue: Variant);
protected
function GetConfig(const AName: String;
const AAllowCreate: Boolean = True): TX2BaseConfig; virtual;
function CreateConfig(const AName: String): TX2BaseConfig; virtual; abstract;
function GetItems(const AName: String): TX2ConfigHash; virtual;
property ConfigItems: TX2ConfigHash read FConfigItems;
public
constructor Create();
destructor Destroy(); override;
// IX2ConfigSource
function GetAutoSave(): Boolean;
procedure SetAutoSave(Value: Boolean);
function Configs(const AName: String): IX2Config; virtual;
function Add(const AName: String): IX2Config; virtual;
function Exists(const AName: String): Boolean; virtual;
procedure Delete(const AName: String); virtual;
procedure Clear(); virtual;
procedure Save(); virtual;
procedure List(const AName: String; const ADest: TStrings;
const ARecurse: Boolean = False); virtual;
procedure Iterate(const AName: String;
const ACallback: TX2ConfigIterateMethod;
const AData: Pointer = nil;
const ARecurse: Boolean = False); overload; virtual;
end;
{
:$ Default implementation for stream-based configuration sources.
}
TX2StreamConfigSource = class(TX2BaseConfigSource)
public
constructor Create(const AStream: TStream); overload; virtual; abstract;
constructor Create(const AFileName: String); overload; virtual;
end; end;
@ -208,294 +146,4 @@ var
implementation implementation
uses
SysUtils,
Variants,
X2UtStrings;
{========================================
TX2ConfigHash
========================================}
function TX2ConfigHash.GetCurrentValue(): TX2BaseConfig;
begin
Result := TX2BaseConfig(inherited GetCurrentValue());
end;
function TX2ConfigHash.GetValue(Key: String): TX2BaseConfig;
begin
Result := TX2BaseConfig(inherited GetValue(Key));
end;
procedure TX2ConfigHash.SetValue(Key: String; const Value: TX2BaseConfig);
begin
inherited SetValue(Key, Value);
end;
{==================== TX2BaseConfigSource
IX2ConfigSource
========================================}
constructor TX2BaseConfigSource.Create();
begin
inherited;
FConfigItems := TX2ConfigHash.Create(True);
end;
destructor TX2BaseConfigSource.Destroy();
begin
FreeAndNil(FConfigItems);
inherited;
end;
function TX2BaseConfigSource.GetAutoSave(): Boolean;
begin
Result := FAutoSave;
end;
procedure TX2BaseConfigSource.SetAutoSave(Value: Boolean);
begin
FAutoSave := Value;
end;
function TX2BaseConfigSource.GetConfig(const AName: String;
const AAllowCreate: Boolean): TX2BaseConfig;
var
aSections: TSplitArray;
iSection: Integer;
pItems: TX2ConfigHash;
sSection: String;
begin
Result := nil;
// Separate subsections
Split(AName, SectionSeparator, aSections);
for iSection := Low(aSections) to High(aSections) do
begin
sSection := Trim(aSections[iSection]);
if Length(sSection) = 0 then
continue;
if Assigned(Result) then
pItems := Result.ConfigItems
else
pItems := FConfigItems;
Result := pItems[sSection];
if not Assigned(Result) then
if AAllowCreate then
begin
Result := CreateConfig(sSection);
pItems[sSection] := Result;
end else
break;
end;
end;
function TX2BaseConfigSource.GetItems(const AName: String): TX2ConfigHash;
var
pConfig: TX2BaseConfig;
begin
Result := nil;
if Length(Trim(AName)) > 0 then
begin
pConfig := GetConfig(AName, False);
if Assigned(pConfig) then
Result := pConfig.ConfigItems;
end else
Result := FConfigItems;
end;
function TX2BaseConfigSource.Configs(const AName: String): IX2Config;
begin
Result := GetConfig(AName, True);
end;
function TX2BaseConfigSource.Add(const AName: String): IX2Config;
begin
end;
function TX2BaseConfigSource.Exists(const AName: String): Boolean;
begin
end;
procedure TX2BaseConfigSource.Delete(const AName: String);
begin
end;
procedure TX2BaseConfigSource.Clear();
begin
end;
procedure TX2BaseConfigSource.Save();
begin
end;
procedure TX2BaseConfigSource.List(const AName: String; const ADest: TStrings;
const ARecurse: Boolean);
begin
end;
procedure TX2BaseConfigSource.Iterate(const AName: String;
const ACallback: TX2ConfigIterateMethod;
const AData: Pointer;
const ARecurse: Boolean);
var
bAbort: Boolean;
pItems: TX2ConfigHash;
begin
pItems := GetItems(AName);
if not Assigned(pItems) then
exit;
bAbort := False;
pItems.First();
while pItems.Next() do
begin
ACallback(Self, pItems.CurrentValue, bAbort);
if bAbort then
break;
if ARecurse then
Iterate(AName + SectionSeparator + pItems.CurrentValue.Name, ACallback,
AData, ARecurse);
end;
end;
{================== TX2StreamConfigSource
Initialization
========================================}
constructor TX2StreamConfigSource.Create(const AFileName: String);
var
fsData: TFileStream;
begin
fsData := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
try
Create(fsData);
finally
FreeAndNil(fsData);
end;
end;
{========================== TX2BaseConfig
IX2Config
========================================}
constructor TX2BaseConfig.Create(const AConfig: String;
const ASource: IX2ConfigSource);
begin
inherited Create();
FSource := ASource;
FName := AConfig;
FConfigItems := TX2ConfigHash.Create(True);
end;
destructor TX2BaseConfig.Destroy();
begin
FreeAndNil(FConfigItems);
inherited;
end;
function TX2BaseConfig.GetName(): String;
begin
Result := FName;
end;
function TX2BaseConfig.ReadBool(const AName: String;
const ADefault: Boolean): Boolean;
begin
Result := ADefault;
if Values.Exists(AName) then
Result := VarAsType(Values[AName], vtBoolean);
end;
function TX2BaseConfig.ReadFloat(const AName: String;
const ADefault: Double): Double;
begin
Result := ADefault;
if Values.Exists(AName) then
Result := VarAsType(Values[AName], vtExtended);
end;
function TX2BaseConfig.ReadInteger(const AName: String;
const ADefault: Integer): Integer;
begin
Result := ADefault;
if Values.Exists(AName) then
Result := VarAsType(Values[AName], vtInteger);
end;
function TX2BaseConfig.ReadString(const AName, ADefault: String): String;
begin
Result := ADefault;
if Values.Exists(AName) then
Result := VarAsType(Values[AName], vtString);
end;
procedure TX2BaseConfig.WriteValue(const AName: String; const AValue: Variant);
begin
Values[AName] := AValue;
if Source.AutoSave then
Save();
end;
procedure TX2BaseConfig.WriteBool(const AName: String; AValue: Boolean);
begin
WriteValue(AName, AValue);
end;
procedure TX2BaseConfig.WriteFloat(const AName: String; AValue: Double);
begin
WriteValue(AName, AValue);
end;
procedure TX2BaseConfig.WriteInteger(const AName: String; AValue: Integer);
begin
WriteValue(AName, AValue);
end;
procedure TX2BaseConfig.WriteString(const AName, AValue: String);
begin
WriteValue(AName, AValue);
end;
procedure TX2BaseConfig.Clear();
begin
Values.Clear();
end;
procedure TX2BaseConfig.Delete(const AName: String);
begin
Values.Delete(AName);
end;
function TX2BaseConfig.Exists(const AName: String): Boolean;
begin
Result := Values.Exists(AName);
end;
procedure TX2BaseConfig.Save();
begin
Source.Save();
end;
end. end.

763
X2UtConfigBase.pas Normal file
View File

@ -0,0 +1,763 @@
{
:: X2UtConfigBase provides the base implementation for various
:: configuration sources.
::
:: Last changed: $Date$
:: Revision: $Rev$
:: Author: $Author$
}
unit X2UtConfigBase;
interface
uses
Classes,
X2UtConfig,
X2UtHashes;
type
// Forward declarations
TX2BaseConfigSource = class;
TX2BaseConfig = class;
TX2ConfigValueHash = class;
TX2ConfigHash = class;
TX2ConfigDefinitionHash = class;
TX2StreamConfigSource = class;
TX2ConfigState = (csClean, csCreate, csUpdate, csDelete);
{
:$ Default implementation for configuration sources.
}
TX2BaseConfigSource = class(TInterfacedObject, IX2ConfigSource)
private
FAutoSave: Boolean;
FConfigItems: TX2ConfigHash;
FDefinitions: TX2ConfigDefinitionHash;
protected
function GetConfig(const AName: String;
const AAllowCreate: Boolean = True): TX2BaseConfig; virtual;
procedure LoadConfigs(); virtual; abstract;
function CreateConfig(const AName: String): TX2BaseConfig; virtual; abstract;
property ConfigItems: TX2ConfigHash read FConfigItems;
public
constructor Create();
destructor Destroy(); override;
// IX2ConfigSource
function GetAutoSave(): Boolean;
procedure SetAutoSave(Value: Boolean);
procedure Reload(); virtual;
procedure Save(); overload; virtual; abstract;
procedure Save(const AStream: TStream); overload; virtual; abstract;
function Configs(const AName: String): IX2Config; virtual;
function Exists(const AName: String): Boolean; virtual;
procedure Delete(const AName: String); virtual;
procedure Clear(const AAction: TX2ConfigClearAction); virtual;
procedure Iterate(const ACallback: TX2ConfigIterateConfigs;
const AData: Pointer);
function Register(const AConfig, AName: String): IX2ConfigDefinition; overload;
function Register(const AConfig, AName: String;
const ADefault: Variant): IX2ConfigDefinition; overload;
function Definitions(const AConfig, AName: String): IX2ConfigDefinition;
property AutoSave: Boolean read GetAutoSave write SetAutoSave;
end;
{
:$ Default implementation for configurations.
}
TX2BaseConfig = class(TObject, IInterface, IX2Config)
private
FName: String;
FSource: TX2BaseConfigSource;
FState: TX2ConfigState;
FValues: TX2ConfigValueHash;
protected
// IInterface
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef(): Integer; stdcall;
function _Release(): Integer; stdcall;
function InternalRead(const AName: String; const ADefault: Variant;
const AUseDefinition: Boolean): Variant; virtual;
procedure InternalWrite(const AName: String; const AValue: Variant;
const AUpdateState: Boolean = True); virtual;
property Values: TX2ConfigValueHash read FValues;
public
constructor Create(const AName: String; const ASource: TX2BaseConfigSource); virtual;
destructor Destroy(); override;
// IX2Config
function GetName(): String;
function GetSource(): IX2ConfigSource;
function Exists(const AName: String): Boolean; virtual;
function Read(const AName: String): Variant; overload;
function Read(const AName: String; const ADefault: Variant): Variant; overload;
procedure Write(const AName: String; const AValue: Variant); virtual;
procedure Delete(const AName: String); virtual;
procedure Clear(const AAction: TX2ConfigClearAction); virtual;
procedure Iterate(const ACallback: TX2ConfigIterateValues;
const AData: Pointer);
property Name: String read GetName;
property Source: IX2ConfigSource read GetSource;
property State: TX2ConfigState read FState write FState;
end;
{
:$ Default implementation for value definitions.
}
TX2ConfigDefinition = class(TObject, IInterface, IX2ConfigDefinition)
private
FConfig: String;
FName: String;
FDefault: Variant;
FObservers: TInterfaceList;
protected
// IInterface
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef(): Integer; stdcall;
function _Release(): Integer; stdcall;
// IX2ConfigDefinition
function GetDefault(): Variant;
function GetConfig(): String;
function GetName(): String;
procedure SetDefault(Value: Variant);
procedure Attach(const AObserver: IX2ConfigDefinitionObserver);
procedure Detach(const AObserver: IX2ConfigDefinitionObserver);
procedure Read(var AValue: Variant);
procedure Write(var AValue: Variant);
property Default: Variant read GetDefault write SetDefault;
property Config: String read GetConfig;
property Name: String read GetName;
public
constructor Create(const AConfig, AName: String; const ADefault: Variant);
destructor Destroy(); override;
end;
{
:$ Internal representation of a value.
}
PX2ConfigValue = ^TX2ConfigValue;
TX2ConfigValue = record
Value: Variant;
State: TX2ConfigState;
end;
{
:$ Hash for configuration values.
}
TX2ConfigValueHash = class(TX2SPHash)
protected
function GetCurrentValue(): PX2ConfigValue;
function GetValue(Key: String): PX2ConfigValue;
procedure SetValue(Key: String; const Value: PX2ConfigValue);
public
property CurrentValue: PX2ConfigValue read GetCurrentValue;
property Values[Key: String]: PX2ConfigValue read GetValue write SetValue; default;
end;
{
:$ Hash for configuration objects.
}
TX2ConfigHash = class(TX2SOHash)
protected
function GetCurrentValue(): TX2BaseConfig;
function GetValue(Key: String): TX2BaseConfig;
procedure SetValue(Key: String; const Value: TX2BaseConfig);
public
property CurrentValue: TX2BaseConfig read GetCurrentValue;
property Values[Key: String]: TX2BaseConfig read GetValue write SetValue; default;
end;
{
:$ Hash for value definitions.
}
TX2ConfigDefinitionHash = class(TX2SOHash)
protected
function GetCurrentValue(): TX2ConfigDefinition;
function GetValue(Key: String): TX2ConfigDefinition;
procedure SetValue(Key: String; const Value: TX2ConfigDefinition);
public
property CurrentValue: TX2ConfigDefinition read GetCurrentValue;
property Values[Key: String]: TX2ConfigDefinition read GetValue write SetValue; default;
end;
{
:$ Default implementation for stream-based configuration sources.
}
TX2StreamConfigSource = class(TX2BaseConfigSource)
private
FFileName: String;
protected
procedure LoadConfigs(); override;
procedure LoadFromFile(const AFileName: String); virtual;
procedure LoadFromStream(const AStream: TStream); virtual; abstract;
property FileName: String read FFileName;
public
constructor Create(const AStream: TStream); overload;
constructor Create(const AFileName: String); overload;
procedure Save(); override;
end;
implementation
uses
SysUtils,
Variants;
{========================================
TX2BaseConfigSource
========================================}
constructor TX2BaseConfigSource.Create();
begin
inherited;
FConfigItems := TX2ConfigHash.Create(True);
FDefinitions := TX2ConfigDefinitionHash.Create(True);
LoadConfigs();
end;
destructor TX2BaseConfigSource.Destroy();
begin
FreeAndNil(FDefinitions);
FreeAndNil(FConfigItems);
inherited;
end;
function TX2BaseConfigSource.GetConfig(const AName: String;
const AAllowCreate: Boolean): TX2BaseConfig;
begin
Result := ConfigItems[AName];
if Assigned(Result) then
begin
if Result.State = csDelete then
if AAllowCreate then
Result.State := csClean
else
Result := nil;
end else if AAllowCreate then
begin
Result := CreateConfig(AName);
ConfigItems[AName] := Result;
end;
end;
function TX2BaseConfigSource.GetAutoSave(): Boolean;
begin
Result := FAutoSave;
end;
procedure TX2BaseConfigSource.SetAutoSave(Value: Boolean);
begin
FAutoSave := Value;
end;
procedure TX2BaseConfigSource.Reload();
begin
ConfigItems.Clear();
LoadConfigs();
end;
function TX2BaseConfigSource.Configs(const AName: String): IX2Config;
begin
Result := (GetConfig(AName) as IX2Config);
end;
function TX2BaseConfigSource.Exists(const AName: String): Boolean;
var
pConfig: TX2BaseConfig;
begin
pConfig := ConfigItems[AName];
Result := Assigned(pConfig) and (pConfig.State <> csDelete);
end;
procedure TX2BaseConfigSource.Delete(const AName: String);
var
pConfig: TX2BaseConfig;
begin
pConfig := ConfigItems[AName];
if Assigned(pConfig) then
pConfig.State := csDelete;
end;
procedure TX2BaseConfigSource.Clear(const AAction: TX2ConfigClearAction);
begin
//! Clear
end;
procedure TX2BaseConfigSource.Iterate(const ACallback: TX2ConfigIterateConfigs;
const AData: Pointer);
begin
ConfigItems.First();
while ConfigItems.Next() do
ACallback(Self, ConfigItems.CurrentKey, AData);
end;
function TX2BaseConfigSource.Register(const AConfig,
AName: String): IX2ConfigDefinition;
begin
Result := Register(AConfig, AName, Unassigned);
end;
function TX2BaseConfigSource.Register(const AConfig, AName: String;
const ADefault: Variant): IX2ConfigDefinition;
var
sKey: String;
pDefinition: TX2ConfigDefinition;
begin
sKey := AConfig + #255 + AName;
Result := FDefinitions[sKey];
if not Assigned(Result) then
begin
pDefinition := TX2ConfigDefinition.Create(AConfig, AName, ADefault);
FDefinitions[sKey] := pDefinition;
Result := (pDefinition as IX2ConfigDefinition);
end;
end;
function TX2BaseConfigSource.Definitions(const AConfig,
AName: String): IX2ConfigDefinition;
var
sKey: String;
begin
sKey := AConfig + #255 + AName;
Result := FDefinitions[sKey];
end;
{========================================
TX2BaseConfig
========================================}
constructor TX2BaseConfig.Create(const AName: String;
const ASource: TX2BaseConfigSource);
begin
inherited Create();
FName := AName;
FSource := ASource;
FValues := TX2ConfigValueHash.Create();
FState := csClean;
end;
destructor TX2BaseConfig.Destroy();
var
pValue: PX2ConfigValue;
begin
Values.First();
while Values.Next() do
begin
pValue := Values.CurrentValue;
Finalize(pValue^);
FreeMem(pValue, SizeOf(TX2ConfigValue));
end;
FreeAndNil(FValues);
inherited;
end;
function TX2BaseConfig.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TX2BaseConfig._AddRef(): Integer;
begin
Result := -1;
end;
function TX2BaseConfig._Release(): Integer;
begin
Result := -1;
end;
function TX2BaseConfig.InternalRead(const AName: String;
const ADefault: Variant;
const AUseDefinition: Boolean): Variant;
var
ifDefinition: IX2ConfigDefinition;
pValue: PX2ConfigValue;
begin
Result := Unassigned;
ifDefinition := Source.Definitions(FName, AName);
pValue := Values[AName];
if Assigned(pValue) and (pValue^.State <> csDelete) then
Result := pValue^.Value
else
if AUseDefinition and (Assigned(ifDefinition)) then
Result := ifDefinition.Default
else
Result := ADefault;
// Observers
if Assigned(ifDefinition) then
ifDefinition.Read(Result);
end;
procedure TX2BaseConfig.InternalWrite(const AName: String;
const AValue: Variant;
const AUpdateState: Boolean);
var
bSave: Boolean;
ifDefinition: IX2ConfigDefinition;
pValue: PX2ConfigValue;
vValue: Variant;
begin
// Observers
vValue := AValue;
ifDefinition := Source.Definitions(FName, AName);
if Assigned(ifDefinition) then
ifDefinition.Write(vValue);
bSave := False;
pValue := Values[AName];
if not Assigned(pValue) then
begin
GetMem(pValue, SizeOf(TX2ConfigValue));
Initialize(pValue^);
pValue^.Value := vValue;
if AUpdateState then
pValue^.State := csCreate
else
pValue^.State := csClean;
Values[AName] := pValue;
bSave := True;
end else if AValue <> pValue^.Value then
begin
pValue^.Value := vValue;
bSave := True;
end;
if bSave then
begin
if AUpdateState then
begin
if FState <> csCreate then
FState := csUpdate;
if pValue^.State <> csCreate then
pValue^.State := csUpdate;
end;
if Source.AutoSave then
Source.Save();
end;
end;
function TX2BaseConfig.GetName(): String;
begin
Result := FName;
end;
function TX2BaseConfig.GetSource(): IX2ConfigSource;
begin
Result := (FSource as IX2ConfigSource);
end;
function TX2BaseConfig.Exists(const AName: String): Boolean;
var
pValue: PX2ConfigValue;
begin
pValue := Values[AName];
Result := Assigned(pValue) and (pValue.State <> csDelete);
end;
function TX2BaseConfig.Read(const AName: String): Variant;
begin
Result := InternalRead(AName, Unassigned, True);
end;
function TX2BaseConfig.Read(const AName: String;
const ADefault: Variant): Variant;
begin
Result := InternalRead(AName, ADefault, False);
end;
procedure TX2BaseConfig.Write(const AName: String; const AValue: Variant);
begin
InternalWrite(AName, AValue);
end;
procedure TX2BaseConfig.Clear(const AAction: TX2ConfigClearAction);
begin
//! Clear
end;
procedure TX2BaseConfig.Iterate(const ACallback: TX2ConfigIterateValues;
const AData: Pointer);
begin
Values.First();
while Values.Next() do
ACallback(Self, Values.CurrentKey, AData);
end;
procedure TX2BaseConfig.Delete(const AName: String);
var
pValue: PX2ConfigValue;
begin
pValue := Values[AName];
if Assigned(pValue) then
if pValue^.State = csCreate then
begin
Finalize(pValue^);
FreeMem(pValue, SizeOf(TX2ConfigValue));
Values.Delete(AName);
end else
pValue^.State := csDelete;
end;
{========================================
TX2ConfigHash
========================================}
function TX2ConfigHash.GetCurrentValue(): TX2BaseConfig;
begin
Result := TX2BaseConfig(inherited GetCurrentValue());
end;
function TX2ConfigHash.GetValue(Key: String): TX2BaseConfig;
begin
Result := TX2BaseConfig(inherited GetValue(Key));
end;
procedure TX2ConfigHash.SetValue(Key: String; const Value: TX2BaseConfig);
begin
inherited SetValue(Key, Value);
end;
{========================================
TX2ConfigValueHash
========================================}
function TX2ConfigValueHash.GetCurrentValue(): PX2ConfigValue;
begin
Result := PX2ConfigValue(inherited GetCurrentValue());
end;
function TX2ConfigValueHash.GetValue(Key: String): PX2ConfigValue;
begin
Result := PX2ConfigValue(inherited GetValue(Key));
end;
procedure TX2ConfigValueHash.SetValue(Key: String; const Value: PX2ConfigValue);
begin
inherited SetValue(Key, Value);
end;
{========================================
TX2ConfigDefinitionHash
========================================}
function TX2ConfigDefinitionHash.GetCurrentValue(): TX2ConfigDefinition;
begin
Result := TX2ConfigDefinition(inherited GetCurrentValue());
end;
function TX2ConfigDefinitionHash.GetValue(Key: String): TX2ConfigDefinition;
begin
Result := TX2ConfigDefinition(inherited GetValue(Key));
end;
procedure TX2ConfigDefinitionHash.SetValue(Key: String;
const Value: TX2ConfigDefinition);
begin
inherited SetValue(Key, Value);
end;
{========================================
TX2StreamConfigSource
========================================}
constructor TX2StreamConfigSource.Create(const AFileName: String);
begin
inherited Create();
FFileName := AFileName;
LoadFromFile(AFileName);
end;
constructor TX2StreamConfigSource.Create(const AStream: TStream);
begin
inherited Create();
FFileName := '';
LoadFromStream(AStream);
end;
procedure TX2StreamConfigSource.LoadConfigs();
begin
if Length(FFileName) > 0 then
LoadFromFile(FFileName);
end;
procedure TX2StreamConfigSource.LoadFromFile(const AFileName: String);
var
fsData: TFileStream;
begin
fsData := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
try
LoadFromStream(fsData);
finally
FreeAndNil(fsData);
end;
end;
procedure TX2StreamConfigSource.Save();
var
fsData: TFileStream;
begin
if Length(FFileName) > 0 then
begin
fsData := TFileStream.Create(FFileName, fmCreate or fmShareExclusive);
try
Save(fsData);
finally
FreeAndNil(fsData);
end;
end;
end;
{========================================
TX2ConfigDefinition
========================================}
constructor TX2ConfigDefinition.Create(const AConfig, AName: String;
const ADefault: Variant);
begin
inherited Create();
FConfig := AConfig;
FName := AName;
FDefault := ADefault;
end;
destructor TX2ConfigDefinition.Destroy();
begin
FreeAndNil(FObservers);
inherited;
end;
function TX2ConfigDefinition.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TX2ConfigDefinition._AddRef(): Integer;
begin
Result := -1;
end;
function TX2ConfigDefinition._Release(): Integer;
begin
Result := -1;
end;
procedure TX2ConfigDefinition.Attach(const AObserver: IX2ConfigDefinitionObserver);
begin
if not Assigned(FObservers) then
FObservers := TInterfaceList.Create();
FObservers.Add(AObserver);
end;
procedure TX2ConfigDefinition.Detach(const AObserver: IX2ConfigDefinitionObserver);
begin
if Assigned(FObservers) then
FObservers.Remove(AObserver);
end;
procedure TX2ConfigDefinition.Read(var AValue: Variant);
var
iObserver: Integer;
begin
if Assigned(FObservers) then
for iObserver := 0 to Pred(FObservers.Count) do
(FObservers[iObserver] as IX2ConfigDefinitionObserver).Read(FConfig, FName, AValue);
end;
procedure TX2ConfigDefinition.Write(var AValue: Variant);
var
iObserver: Integer;
begin
if Assigned(FObservers) then
for iObserver := 0 to Pred(FObservers.Count) do
(FObservers[iObserver] as IX2ConfigDefinitionObserver).Write(FConfig, FName, AValue);
end;
function TX2ConfigDefinition.GetDefault(): Variant;
begin
Result := FDefault;
end;
function TX2ConfigDefinition.GetConfig(): String;
begin
Result := FConfig;
end;
function TX2ConfigDefinition.GetName(): String;
begin
Result := FName;
end;
procedure TX2ConfigDefinition.SetDefault(Value: Variant);
begin
FDefault := Value;
end;
end.

View File

@ -9,39 +9,99 @@ unit X2UtConfigIni;
interface interface
uses uses
X2UtConfig; Classes,
X2UtConfig,
X2UtConfigBase;
type type
TX2IniConfigSource = class(TX2StreamConfigSource) TX2IniConfigSource = class(TX2StreamConfigSource)
protected protected
function CreateConfig(const AName: String): TX2BaseConfig; override;
procedure LoadFromStream(const AStream: TStream); override;
procedure IniSection(Sender: TObject; Section: String); procedure IniSection(Sender: TObject; Section: String);
procedure IniValue(Sender: TObject; Name, Value: String); procedure SaveValue(Sender: IX2Config; const Name: String;
const Data: Pointer);
public public
constructor Create(const AStream: TStream); override; procedure Save(const AStream: TStream); override;
end;
TX2IniConfig = class(TX2BaseConfig)
protected
procedure IniValue(Sender: TObject; Name, Value: String);
end; end;
implementation implementation
uses uses
Variants,
X2UtIniParser; X2UtIniParser;
{===================== TX2IniConfigSource
Initialization {========================================
TX2IniConfigSource
========================================} ========================================}
constructor TX2IniConfigSource.Create(const AStream: TStream); function TX2IniConfigSource.CreateConfig(const AName: String): TX2BaseConfig;
begin begin
Result := TX2IniConfig.Create(AName, Self);
end;
procedure TX2IniConfigSource.LoadFromStream(const AStream: TStream);
begin
with TX2IniParser.Create() do
try
OnSection := IniSection;
Execute(AStream);
finally
Free();
end;
end;
procedure TX2IniConfigSource.Save(const AStream: TStream);
procedure WriteLine(const ALine: String);
var
sLine: String;
begin
sLine := ALine + #13#10;
AStream.WriteBuffer(PChar(sLine)^, Length(sLine));
end;
begin
ConfigItems.First();
while ConfigItems.Next() do
begin
WriteLine('[' + ConfigItems.CurrentValue.Name + ']');
ConfigItems.CurrentValue.Iterate(SaveValue, Pointer(AStream));
WriteLine('');
end;
end; end;
procedure TX2IniConfigSource.IniSection(Sender: TObject; Section: String); procedure TX2IniConfigSource.IniSection(Sender: TObject; Section: String);
begin begin
// (Sender as TX2IniParser).OnValue := (GetConfig(Section) as TX2IniConfig).IniValue;
end; end;
procedure TX2IniConfigSource.IniValue(Sender: TObject; Name, Value: String);
{========================================
TX2IniConfig
========================================}
procedure TX2IniConfig.IniValue(Sender: TObject; Name, Value: String);
begin begin
// InternalWrite(Name, Value, False);
end;
procedure TX2IniConfigSource.SaveValue(Sender: IX2Config;
const Name: String;
const Data: Pointer);
var
sLine: String;
begin
sLine := Name + '=' + VarAsType(Sender.Read(Name), varString) + #13#10;
TStream(Data).WriteBuffer(PChar(sLine)^, Length(sLine));
end; end;
end. end.

152
X2UtConfigRanges.pas Normal file
View File

@ -0,0 +1,152 @@
{
:: X2UtConfigRanges provides various definition observers to ensure
:: a value is within the specified range. To enforce a range on a defined
:: value, call:
::
:: IX2ConfigSource.Register(...).Attach(<RangeClass>.Create(...))
::
:: Last changed: $Date$
:: Revision: $Rev$
:: Author: $Author$
}
unit X2UtConfigRanges;
interface
uses
X2UtConfig;
type
TX2BaseConfigRange = class(TInterfacedObject, IX2ConfigDefinitionObserver)
protected
// IX2ConfigDefinitionObserver
procedure Read(const AConfig, AName: String; var AValue: Variant); virtual;
procedure Write(const AConfig, AName: String; var AValue: Variant); virtual;
procedure CheckRange(var AValue: Variant); virtual; abstract;
end;
TX2ConfigStringPosition = (spLeft, spRight);
TX2ConfigStringLengthRange = class(TX2BaseConfigRange)
private
FCutOffPosition: TX2ConfigStringPosition;
FFillChar: Char;
FFillPosition: TX2ConfigStringPosition;
FMinLength: Integer;
FMaxLength: Integer;
protected
procedure CheckRange(var AValue: Variant);
public
constructor Create(const AMinLength: Integer = 0;
const AMaxLength: Integer = 0;
const AFillChar: Char = #20;
const AFillPosition: TX2ConfigStringPosition = spRight;
const ACutOffPosition: TX2ConfigStringPosition = spRight);
end;
TX2ConfigIntegerRange = class(TX2BaseConfigRange)
private
FDefault: Integer;
FMax: Integer;
FMin: Integer;
protected
procedure CheckRange(var AValue: Variant);
public
constructor Create(const AMin: Integer = Low(Integer);
const AMax: Integer = High(Integer);
const ADefault: Integer = 0);
end;
implementation
uses
Variants,
X2UtMisc;
{========================================
TX2BaseConfigRange
========================================}
procedure TX2BaseConfigRange.Read(const AConfig, AName: String;
var AValue: Variant);
begin
CheckRange(AValue);
end;
procedure TX2BaseConfigRange.Write(const AConfig, AName: String;
var AValue: Variant);
begin
CheckRange(AValue);
end;
{========================================
TX2ConfigStringRange
========================================}
constructor TX2ConfigStringLengthRange.Create(const AMinLength,
AMaxLength: Integer;
const AFillChar: Char;
const AFillPosition: TX2ConfigStringPosition;
const ACutOffPosition: TX2ConfigStringPosition);
begin
inherited Create();
Assert((AMaxLength = 0) or
(AMaxLength >= AMinLength),
'MaxLength must be 0, equal to or larger than MinLength!');
FMinLength := AMinLength;
FMaxLength := AMaxLength;
FFillChar := AFillChar;
FFillPosition := AFillPosition;
FCutOffPosition := ACutOffPosition;
end;
procedure TX2ConfigStringLengthRange.CheckRange(var AValue: Variant);
var
sFill: String;
sValue: String;
begin
if VarIsType(AValue, varString) then
begin
sValue := AValue;
if Length(sValue) < FMinLength then
begin
sFill := StringOfChar(FFillChar, FMinLength - Length(sValue));
case FFillPosition of
spLeft: sValue := sFill + sValue;
spRight: sValue := sValue + sFill;
end;
end;
if (FMaxLength > 0) and (Length(sValue) > FMaxLength) then
case FCutOffPosition of
spLeft: Delete(sValue, 1, Length(sValue) - FMaxLength);
spRight: SetLength(sValue, FMaxLength);
end;
AValue := sValue;
end else
AValue := StringOfChar(FFillChar, FMinLength);
end;
{========================================
TX2ConfigIntegerRange
========================================}
constructor TX2ConfigIntegerRange.Create(const AMin, AMax, ADefault: Integer);
begin
inherited Create();
FMin := AMin;
FMax := AMax;
FDefault := ADefault;
end;
procedure TX2ConfigIntegerRange.CheckRange(var AValue: Variant);
begin
AValue := InRange(AValue, FMin, FMax, FDefault);
end;
end.

View File

@ -43,7 +43,11 @@ begin
with Columns[SortColumn] do with Columns[SortColumn] do
if Tag <> 0 then if Tag <> 0 then
begin begin
Color := TColor(Tag); if Tag = clNone then
Options := Options + [coParentColor]
else
Color := Tag;
Tag := 0; Tag := 0;
end; end;
@ -58,7 +62,11 @@ begin
if ASortColor <> clNone then if ASortColor <> clNone then
with Columns[SortColumn] do with Columns[SortColumn] do
begin begin
Tag := Color; if coParentColor in Options then
Tag := clNone
else
Tag := Color;
Color := ASortColor; Color := ASortColor;
end; end;
end; end;