{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Persistent value storage interfaces and | } { | implemantions. | } { | | } { | Copyright (C) - 2018 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMPrsStg; interface uses GMStrDef, GMActiveX, GMCollections, GMIntf, GMCommon, GMUnionValue {$IFDEF JEDIAPI},jwaWinType{$ENDIF} ; type TGMPersistentValue = class(TGMRefCountedObj, IGMAskInteger) protected FId: LongInt; FDirPath: TGMString; FValueName: TGMString; FVariantType: Word; FDefaultValue: Variant; function AskInteger(const ValueId: LongInt): LongInt; stdcall; public constructor Create(const AId: LongInt; const ADirPath, AValueName: TGMString; const AVariantType: Word; const ADefaultValue: Variant; const ARefLifeTime: Boolean = False); reintroduce; property Id: LongInt read FId write FId; property DirPath: TGMString read FDirPath write FDirPath; property ValueName: TGMString read FValueName write FValueName; property VariantType: Word read FVariantType write FVariantType; property DefaultValue: Variant read FDefaultValue write FDefaultValue; end; TGMValueStorageImpl = class(TGMAggregatableObj, IGMStringStorage, IGMValueStorage{, IGMBinaryStorage}) protected FReadStringFunc: TGMReadValStrFunc; FWriteStringProc: TGMWriteValStrProc; FStringStorage: IGMStringStorage; public constructor Create(const AOwner: IUnknown; const AReadStringFunc: TGMReadValStrFunc; const AWriteStringProc: TGMWriteValStrProc; const ARefLifeTime: Boolean = False); reintroduce; overload; constructor Create(const AOwner: IUnknown; const AStringStorage: IUnknown; const ARefLifeTime: Boolean = False); reintroduce; overload; function ReadString(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; stdcall; function ReadInteger(const AValueName: TGMString; const ADefaultValue: LongInt = 0): LongInt; stdcall; function ReadInt64(const AValueName: TGMString; const ADefaultValue: Int64 = 0): Int64; stdcall; function ReadBoolean(const AValueName: TGMString; const ADefaultValue: Boolean = False): Boolean; stdcall; function ReadDateTime(const AValueName: TGMString; const ADefaultValue: Double = 0): Double; stdcall; function ReadDouble(const AValueName: TGMString; const ADefaultValue: Double = 0): Double; stdcall; function ReadVariant(const AValueName: TGMString; const ADefaultValue: OleVariant): OleVariant; stdcall; function ReadUnionValue(const ValueName: TGMString; const ADefaultValue: RGMUnionValue): RGMUnionValue; stdcall; procedure WriteString(const AValueName, AValue: TGMString); stdcall; procedure WriteInteger(const AValueName: TGMString; const AValue: LongInt); stdcall; procedure WriteInt64(const AValueName: TGMString; const AValue: Int64); stdcall; procedure WriteBoolean(const AValueName: TGMString; const AValue: Boolean); stdcall; procedure WriteDateTime(const AValueName: TGMString; const AValue: Double); stdcall; procedure WriteDouble(const AValueName: TGMString; const AValue: Double); stdcall; procedure WriteVariant(const AValueName: TGMString; const AValue: OleVariant); stdcall; procedure WriteUnionValue(const ValueName: TGMString; const Value: RGMUnionValue); stdcall; //function ReadBinary(const ValueName: TGMString; out Data; const DataSize: LongInt; const ZeroInit: Boolean = True): LongWord; stdcall; //procedure WriteBinary(const ValueName: TGMString; const Data; const DataSize: LongInt); stdcall; property ReadStringFunc: TGMReadValStrFunc read FReadStringFunc write FReadStringFunc; property WriteStringProc: TGMWriteValStrProc read FWriteStringProc write FWriteStringProc; property StringStorage: IGMStringStorage read FStringStorage write FStringStorage; end; TGMPersistentData = class; TGMStorageBase = class(TGMAggregatableObj, IGMValueStorageDirectory, IGMStringStorage, IGMGetFileName, IGMGetSetFileName) protected FPersistentData: TGMPersistentData; FRootKey: HKEY; FBasePath: TGMString; FCurrentPath: TGMString; FFileName: TGMString; FRootKeyAsString: TGMString; function InternalOpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; virtual; abstract; procedure InternalReadSubDirNames(var ASubDirNames: TGMStringArray); virtual; abstract; procedure InternalReadValueNames(var AValueNames: TGMStringArray); virtual; abstract; function InternalContainsValue(const AValueName: TGMString): Boolean; virtual; abstract; function InternalDeleteValue(const AValueName: TGMString): Boolean; virtual; abstract; function InternalDeleteSubDir(const ADirName: TGMString): Boolean; virtual; abstract; // function InternalDeleteDir(const ADirPath: TGMString): Boolean; virtual; abstract; public constructor Create(const AOwner: IUnknown; const AFileName: TGMString = ''; const ABasePath: TGMString = ''; const ARootKey: HKEY = cDfltStorageRootKey; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; procedure EnterCriticalSection; stdcall; procedure LeaveCriticalSection; stdcall; // function FullPath: TGMString; function UseRootKey: Boolean; virtual; function RootKeyAsString: TGMString; function AddBasePath(const ADirPath: TGMString): TGMString; function ExpandPath(const ADirPath: TGMString): TGMString; function GetRootKey: HKEY; virtual; stdcall; procedure SetRootKey(const AValue: HKEY); virtual; stdcall; function GetBasePath: TGMString; virtual; stdcall; procedure SetBasePath(const AValue: TGMString); virtual; stdcall; function GetFileName: TGMString; virtual; stdcall; procedure SetFileName(const AValue: TGMString); virtual; stdcall; procedure Commit; virtual; stdcall; // IGMValueStorageDirectory function OpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; virtual; stdcall; // function DirExists(const ADirPath: TGMString): Boolean; virtual; stdcall; procedure ReadSubDirNames(var ASubDirNames: TGMStringArray); virtual; stdcall; procedure ReadValueNames(var AValueNames: TGMStringArray); virtual; stdcall; function ContainsValue(const AValueName: TGMString): Boolean; virtual; stdcall; function DeleteValue(const AValueName: TGMString): Boolean; virtual; stdcall; function DeleteDir(const ADirPath: TGMString): Boolean; virtual; stdcall; // IGMStringStorage function ReadString(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; virtual; stdcall; abstract; procedure WriteString(const AValueName, AValue: TGMString); virtual; stdcall; abstract; function CurrentPath: TGMString; virtual; stdcall; property RootKey: HKEY read GetRootKey write SetRootKey; property BasePath: TGMString read GetBasePath write SetBasePath; property FileName: TGMString read GetFileName write SetFileName; end; TGMStorageClass = class of TGMStorageBase; //TGMRegistryStorage = class(TGMStorageBase) // // // // See QueryInterface note in base class! // // // protected // FRootKey: LongWord; // FRegistry: IGMRegKey; // TRegistry; // // publicS // constructor Create(const AOwner: TObject; // const AFileName: TGMString = ''; // const ABasePath: TGMString = ''; // const ARootKey: LongWord = cDfltStorageRootKey; // const ARefLifeTime: Boolean = False); override; // // destructor Destroy; override; // // function GetRootKey: LongWord; override; // procedure SetRootKey(const Value: LongWord); override; // procedure SetBasePath(const Value: TGMString); override; // // function UseRootKey: Boolean; override; // function InternalOpenDir(const DirPath: TGMString; const CreateIfNotExist: Boolean = False): Boolean; override; // function InternalDirExists(const DirPath: TGMString): Boolean; override; // procedure InternalReadSubDirNames(const SubDirNames: IGMStrings); override; // procedure InternalReadValueNames(const ValueNames: IGMStrings); override; // function InternalDeleteValue(const ValueName: TGMString): Boolean; override; // function InternalDeleteDir(const DirPath: TGMString): Boolean; override; // // function ReadString(const ValueName: TGMString; const DefaultValue: TGMString = ''): TGMString; override; stdcall; // procedure WriteString(const ValueName, Value: TGMString); override; stdcall; // // property Registry: IGMRegKey read FRegistry; //end; TGMCompoundDocStorage = class(TGMStorageBase, IGMGetGUID, IGMGetSetGUID) // // See QueryInterface note in base class! // If created with AFileName = '' it will use an in memory storage (created on TGMMemoryLockBytes) // protected FGuid: TGUID; FRootStorage: IStorage; FCurrentStorage: IStorage; FStorageList: IGMIntfArrayCollection; procedure ReadEntryNames(var AEntryNames: TGMStringArray; const AElementType: LongInt); function DeleteEntry(const AEntryName: TGMString): Boolean; procedure CommitAndRelease; function InternalOpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; override; procedure InternalReadSubDirNames(var ASubDirNames: TGMStringArray); override; procedure InternalReadValueNames(var AValueNames: TGMStringArray); override; function InternalContainsValue(const AValueName: TGMString): Boolean; override; function InternalDeleteValue(const AValueName: TGMString): Boolean; override; // function InternalDeleteDir(const ADirPath: TGMString): Boolean; override; function InternalDeleteSubDir(const ADirName: TGMString): Boolean; override; public constructor Create(const ARefLifeTime: Boolean = False); overload; override; constructor Create(const AOwner: IUnknown; const AFileName: TGMString = ''; const ABasePath: TGMString = ''; const ARootKey: HKEY = cDfltStorageRootKey; const ARefLifeTime: Boolean = False); overload; override; destructor Destroy; override; function RootStorage: IStorage; virtual; function GetGUID: TGUID; virtual; stdcall; procedure SetGUID(const AValue: TGUID); virtual; stdcall; procedure SetFileName(const AFileName: TGMString); override; // function DeleteDir(const ADirPath: TGMString): Boolean; override; procedure Commit; override; function StringStorage: IStorage; function ReadString(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; override; stdcall; procedure WriteString(const AValueName, AValue: TGMString); override; stdcall; property CurrentStorage: IStorage read FCurrentStorage; end; TGMIniFileSection = class(TGMNameObj, IGMTreeable) protected FParentSection: TGMIniFileSection; FSubSections: IGMObjArrayCollection; FValues: IGMIntfCollection; public constructor Create(const ARefLifeTime: Boolean = False); overload; override; constructor Create(const AParent: TGMIniFileSection; const AName: TGMString; const ARefLifeTime: Boolean = False); reintroduce; overload; function Parent: IGMTreeable; function FirstChild: IGMTreeable; function NextSibling: IGMTreeable; function PrevSibling: IGMTreeable; function ContainsValue(const AValueName: TGMString): Boolean; property ParentSection: TGMIniFileSection read FParentSection; property Values: IGMIntfCollection read FValues; property SubSections: IGMObjArrayCollection read FSubSections; end; TGMIniFileStorage = class(TGMStorageBase) protected FDataChanged: Boolean; FIniFileLoaded, FIniFileLoading: Boolean; FRootSection: TGMIniFileSection; FCurrentSection: TGMIniFileSection; FCharKind: TGMCharKind; procedure LoadFromStream(const ASrcStream: ISequentialStream; const ACharKind: TGMCharKind); procedure WriteIniToStream(const ADstStream: ISequentialStream; const ACharKind: TGMCharKind); procedure LoadFile; function InternalOpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; override; procedure InternalReadSubDirNames(var ASubDirNames: TGMStringArray); override; procedure InternalReadValueNames(var AValueNames: TGMStringArray); override; function InternalContainsValue(const AValueName: TGMString): Boolean; override; function InternalDeleteSubDir(const ADirName: TGMString): Boolean; override; function InternalDeleteValue(const AValueName: TGMString): Boolean; override; // function InternalDeleteDir(const ADirPath: TGMString): Boolean; override; public constructor Create(const ARefLifeTime: Boolean = False); overload; override; destructor Destroy; override; procedure Commit; override; stdcall; function ReadString(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; override; stdcall; procedure WriteString(const AValueName, AValue: TGMString); override; stdcall; property RootSection: TGMIniFileSection read FRootSection; property CurrentSection: TGMIniFileSection read FCurrentSection; end; IGMPersistentValues = interface(IUnknown) ['{685B7A3E-A75A-43f2-A9AE-7343AB37A3F1}'] procedure ChangeStorage(const NewFileName: TGMString; NewStorageClass: TGMStorageClass = nil; const CopyContents: Boolean = True); procedure DefineValue(const Id: LongInt; const DirPath, ValueName: TGMString; const DefaultValue: OleVariant); function GetDefinedValue(ValueId: LongInt): OleVariant; procedure SetDefinedValue(valueId: LongInt; const Value: OleVariant); property DefinedValues[ValueId: LongInt]: OleVariant read GetDefinedValue write SetDefinedValue; default; end; TGMPersistentData = class(TGMRefCountedObj, IGMStringStorage, IGMValueStorage, IGMValueStorageDirectory, IGMGetFileName, IGMGetSetFileName, IGMPersistentValues, IGMCriticalSection) protected FStorage: TGMStorageBase; FValueStorer: TGMValueStorageImpl; FDefinedValues: TGMObjArrayCollection; FCriticalSection: IGMCriticalSection; //function GetFileName: TGMString; //procedure SetFileName(const Value: TGMString); function GetDefinedValue(ValueId: LongInt): OleVariant; procedure SetDefinedValue(valueId: LongInt; const Value: OleVariant); function FindValue(const AId: LongInt; var Value: TGMPersistentValue): Boolean; procedure ValueNotExists(const ValueId: LongInt); public constructor Create(const AStorageClass: TGMStorageClass; const AFileName: TGMString = ''; const ABasePath: TGMString = ''; const ARootKey: LongWord = cDfltStorageRootKey; const ARefLifeTime: Boolean = False); reintroduce; destructor Destroy; override; //function QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; override; //function IGMStringStorage.ReadString = FStorage.ReadString; procedure ChangeStorage(const ANewFileName: TGMString; ANewStorageClass: TGMStorageClass = nil; const ACopyContents: Boolean = True); procedure DefineValue(const Id: LongInt; const DirPath, ValueName: TGMString; const DefaultValue: OleVariant); property DefinedValueList: TGMObjArrayCollection read FDefinedValues; property DefinedValues[ValueId: LongInt]: OleVariant read GetDefinedValue write SetDefinedValue; default; // Interface implementation delegations property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection; property Storage: TGMStorageBase read FStorage implements IGMValueStorageDirectory, IGMGetFileName, IGMGetSetFileName; property ValueStorer: TGMValueStorageImpl read FValueStorer implements IGMValueStorage, IGMStringStorage; // IGMBinaryStorage; //property AFileName: TGMString read GetFileName write SetFileName; end; implementation uses {$IFDEF DELPHI6}Variants,{$ENDIF} {$IFDEF JEDIAPI}jwaWinError, jwaWinReg{$ENDIF} ; resourcestring RStrInvalidRootKey = 'Invalid Root Key "%d"'; RStrValueAlreadyExists = 'A Value with Id %d already exists'; RStrValueNotInSection = 'No Value with Id %d'; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function PersistentValueIdCompareFunc(const ItemA, ItemB: IUnknown): TGMCompareResult; var IdA, IdB: LongInt; begin IdA := GMCheckAskInteger(ItemA, Ord(ivId), {$I %CurrentRoutine%}); IdB := GMCheckAskInteger(ItemB, Ord(ivId), {$I %CurrentRoutine%}); if IdA < IdB then Result := crALessThanB else if IdA = IdB then Result := crAEqualToB else Result := crAGreaterThanB; end; { ---------------------------- } { ---- TGMPersistentValue ---- } { ---------------------------- } constructor TGMPersistentValue.Create(const AId: LongInt; const ADirPath, AValueName: TGMString; const AVariantType: Word; const ADefaultValue: Variant; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FId := AId; FDirPath := '\' + GMStrip(ADirPath, cDirSep); FValueName := AValueName; FVariantType := AVariantType; FDefaultValue := ADefaultValue; end; function TGMPersistentValue.AskInteger(const ValueId: LongInt): LongInt; begin case ValueId of Ord(ivId): Result := Id; else Result := CInvalidIntValue; end; end; { ----------------------------- } { ---- TGMValueStorageImpl ---- } { ----------------------------- } constructor TGMValueStorageImpl.Create(const AOwner: IUnknown; const AReadStringFunc: TGMReadValStrFunc; const AWriteStringProc: TGMWriteValStrProc; const ARefLifeTime: Boolean); begin inherited Create(AOwner, ARefLifeTime); FReadStringFunc := AReadStringFunc; FWriteStringProc := AWriteStringProc; end; constructor TGMValueStorageImpl.Create(const AOwner: IUnknown; const AStringStorage: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(AOwner, ARefLifeTime); if AStringStorage <> nil then GMCheckQueryInterface(AStringStorage, IGMStringStorage, FStringStorage, 'TGMValueStorageImpl.Create'); end; { ---- TGMString Storage ---- } function TGMValueStorageImpl.ReadString(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; begin if Assigned(FReadStringFunc) then Result := FReadStringFunc(AValueName, ADefaultValue) else if FStringStorage <> nil then Result := FStringStorage.ReadString(AValueName, ADefaultValue) else Result := ADefaultValue; end; procedure TGMValueStorageImpl.WriteString(const AValueName, AValue: TGMString); stdcall; begin if Assigned(FWriteStringProc) then FWriteStringProc(AValueName, AValue) else if FStringStorage <> nil then FStringStorage.WriteString(AValueName, AValue); end; { ---- Value Storage ---- } function TGMValueStorageImpl.ReadInteger(const AValueName: TGMString; const ADefaultValue: LongInt): LongInt; begin try Result := GMStrToInt(ReadString(AValueName, GMIntToStr(ADefaultValue))); except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteInteger(const AValueName: TGMString; const AValue: LongInt); begin WriteString(AValueName, GMIntToStr(AValue)); end; function TGMValueStorageImpl.ReadInt64(const AValueName: TGMString; const ADefaultValue: Int64): Int64; begin try Result := GMStrToInt64(ReadString(AValueName, GMIntToStr(ADefaultValue))); except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteInt64(const AValueName: TGMString; const AValue: Int64); begin WriteString(AValueName, GMIntToStr(AValue)); end; function TGMValueStorageImpl.ReadBoolean(const AValueName: TGMString; const ADefaultValue: Boolean): Boolean; begin try Result := GMStrToBool(ReadString(AValueName, GMBoolToStr(ADefaultValue, '0', '1'))); except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteBoolean(const AValueName: TGMString; const AValue: Boolean); begin WriteString(AValueName, GMBoolToStr(AValue, '0', '1')); end; function TGMValueStorageImpl.ReadDateTime(const AValueName: TGMString; const ADefaultValue: Double): Double; begin try Result := GMFixedDecodeDateTime(ReadString(AValueName, GMFixedEncodeDateTime(ADefaultValue))); except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteDateTime(const AValueName: TGMString; const AValue: Double); begin WriteString(AValueName, GMFixedEncodeDateTime(AValue)); end; function TGMValueStorageImpl.ReadDouble(const AValueName: TGMString; const ADefaultValue: Double): Double; begin try // Result := GMStrToDouble(GMReplaceChars(ReadString(AValueName, GMDoubleToStr(ADefaultValue)), cDecSep, DecimalSeparator)); Result := GMStrToDouble(ReadString(AValueName, GMDoubleToStr(ADefaultValue))); except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteDouble(const AValueName: TGMString; const AValue: Double); begin //WriteString(AValueName, GMReplaceChars(GMDoubleToStr(AValue), DecimalSeparator, cDecSep)); WriteString(AValueName, GMDoubleToStr(AValue)); end; function TGMValueStorageImpl.ReadVariant(const AValueName: TGMString; const ADefaultValue: OleVariant): OleVariant; var valStr: TGMString; chPos: LongInt; vType: LongInt; function _ReadSingle(AValue: TGMString): Single; var code: Integer; begin AValue := GMReplaceChars(AValue, ',', cDecSep); // GMDeleteChars(AValue, ThousandSeparator) Val(AValue, Result, code); if code <> 0 then Result := 0.0; end; function _ReadDouble(AValue: TGMString): Double; var code: Integer; begin AValue := GMReplaceChars(AValue, ',', cDecSep); // GMDeleteChars(AValue, ThousandSeparator) Val(AValue, Result, code); if code <> 0 then Result := 0.0; end; begin try valStr := ReadString(AValueName); chPos := Pos(',', valStr); if chPos > 0 then vType := GMStrToInt(Copy(valStr, 1, chPos-1)) else vType := VarType(ADefaultValue) and varTypeMask; valStr := Copy(valStr, chPos + 1, Length(valStr) - chPos); case vType of varEmpty: Result := Unassigned; varNull: Result := Null; varSingle: Result := _ReadSingle(valStr); varDouble: Result := _ReadDouble(valStr); varDate: Result := GMFixedDecodeDateTime(valStr); else Result := VarAsType(valStr, vType); end; except Result := ADefaultValue; end; end; procedure TGMValueStorageImpl.WriteVariant(const AValueName: TGMString; const AValue: OleVariant); var vType: LongInt; function _VariantValStr(const AVarType: LongInt; const AValueStr: TGMString = ''): TGMString; begin Result := GMFormat('%d,%s', [AVarType, AValueStr]); end; begin vType := VarType(AValue) and varTypeMask; case vType of varEmpty: WriteString(AValueName, _VariantValStr(vType, cStrNone)); varNull: WriteString(AValueName, _VariantValStr(vType, cStrNULL)); varSingle: WriteString(AValueName, _VariantValStr(vType, GMSingleToStr(TVarData(AValue).VSingle))); varDouble: WriteString(AValueName, _VariantValStr(vType, GMDoubleToStr(TVarData(AValue).VDouble))); varDate: WriteString(AValueName, _VariantValStr(vType, GMFixedEncodeDateTime(AValue))); else WriteString(AValueName, _VariantValStr(vType, GMVarToStr(AValue))); end; end; function TGMValueStorageImpl.ReadUnionValue(const ValueName: TGMString; const ADefaultValue: RGMUnionValue): RGMUnionValue; begin raise EGMException.ObjError({$I %CurrentRoutine%}+' not implmented yet', Self, {$I %CurrentRoutine%}); Result := uvtUnassigned; // <- avoid compiler warning end; procedure TGMValueStorageImpl.WriteUnionValue(const ValueName: TGMString; const Value: RGMUnionValue); begin raise EGMException.ObjError({$I %CurrentRoutine%}+' not implmented yet', Self, {$I %CurrentRoutine%}); end; //function TGMValueStorageImpl.ReadBinary(const ValueName: TGMString; out Data; const DataSize: LongInt; const ZeroInit: Boolean = True): LongWord; //var i: LongInt; ValStr: TGMString; // function HexCharValue(const Ch: TGMChar): Byte; // begin // case Ch of // '0' .. '9': Result := Ord(Ch) - Ord('0'); // 'A' .. 'F': Result := Ord(Ch) - Ord('A') + 10; // 'a' .. 'f': Result := Ord(Ch) - Ord('a') + 10; // else Result := 0; // end; // end; // function ByteFromHex(const Value: TGMString): Byte; // begin // Result := HexCharValue(Value[1]) shl 4 + HexCharValue(Value[2]); // end; //begin // if ZeroInit and (DataSize > 0) then FillByte(Data, DataSize, 0); // ValStr := ReadString(ValueName); // if DataSize = 0 then Result := Length(ValStr) div 2 else // begin // Result := Max(0, Min(Length(ValStr) div 2, DataSize)); // for i:=1 to Result do PByte(LongInt(@Data)+i-1)^ := ByteFromHex(Copy(ValStr, i*2-1, 2)); // end; //end; //procedure TGMValueStorageImpl.WriteBinary(const ValueName: TGMString; const Data; const DataSize: LongInt); //var i: LongInt; ValStr: TGMString; //begin // for i:=0 to DataSize-1 do ValStr := ValStr + GMFormat('%.2x', [PByte(LongInt(@Data) + i)^]); // WriteString(ValueName, ValStr); //end; { ------------------------ } { ---- TGMStorageBase ---- } { ------------------------ } constructor TGMStorageBase.Create(const AOwner: IUnknown; const AFileName: TGMString; const ABasePath: TGMString; const ARootKey: HKEY; const ARefLifeTime: Boolean); begin inherited Create(AOwner, ARefLifeTime); if OwnerObj is TGMPersistentData then FPersistentData := TGMPersistentData(OwnerObj); FFileName := AFileName; FBasePath := ABasePath; FRootKey := ARootKey; end; procedure TGMStorageBase.EnterCriticalSection; stdcall; begin if FPersistentData <> nil then FPersistentData.CriticalSection.EnterCriticalSection; end; procedure TGMStorageBase.LeaveCriticalSection; stdcall; begin if FPersistentData <> nil then FPersistentData.CriticalSection.LeaveCriticalSection; end; function TGMStorageBase.RootKeyAsString: TGMString; begin if Length(FRootKeyAsString) <= 0 then case FRootKey of HKEY_CLASSES_ROOT: FRootKeyAsString := 'HKEY_CLASSES_ROOT'; //HKEY_CURRENT_USER: FRootKeyAsString := GMAppendStrippedPath('HKEY_USERS', GMThisUserName); //'HKEY_CURRENT_USER'; HKEY_CURRENT_USER: FRootKeyAsString := 'HKEY_CURRENT_USER (' + GMThisUserSID + ')'; HKEY_LOCAL_MACHINE: FRootKeyAsString := 'HKEY_LOCAL_MACHINE'; HKEY_USERS: FRootKeyAsString := 'HKEY_USERS'; HKEY_CURRENT_CONFIG: FRootKeyAsString := 'HKEY_CURRENT_CONFIG'; HKEY_DYN_DATA: FRootKeyAsString := 'HKEY_DYN_DATA'; else FRootKeyAsString := ''; end; Result := FRootKeyAsString; end; function TGMStorageBase.UseRootKey: Boolean; begin Result := FRootKey <> cDontUseRootKey; end; function TGMStorageBase.AddBasePath(const ADirPath: TGMString): TGMString; begin Result := GMAppendStrippedPath(BasePath, ADirPath); if UseRootKey then Result := GMAppendStrippedPath(RootKeyAsString, Result); end; function TGMStorageBase.ExpandPath(const ADirPath: TGMString): TGMString; begin Result := GMReplaceChars(ADirPath, '/', '\'); if GMIsRelativePath(Result) then Result := GMAppendStrippedPath(CurrentPath, Result) else Result := GMStrip(Result, cDirSep); end; //function TGMStorageBase.FullPath: TGMString; //begin //Result := AddBasePath(CurrentPath); //end; procedure TGMStorageBase.Commit; stdcall; begin // Nothing! end; function TGMStorageBase.GetFileName: TGMString; stdcall; begin EnterCriticalSection; try Result := FFileName; finally LeaveCriticalSection; end; end; procedure TGMStorageBase.SetFileName(const AValue: TGMString); stdcall; begin EnterCriticalSection; try FFileName := AValue; finally LeaveCriticalSection; end; end; function TGMStorageBase.GetBasePath: TGMString; stdcall; begin EnterCriticalSection; try Result := FBasePath; finally LeaveCriticalSection; end; end; procedure TGMStorageBase.SetBasePath(const AValue: TGMString); stdcall; begin EnterCriticalSection; try FBasePath := GMStrip(AValue, cDirSep); finally LeaveCriticalSection; end; end; function TGMStorageBase.GetRootKey: HKEY; stdcall; begin Result := FRootKey; end; procedure TGMStorageBase.SetRootKey(const AValue: HKEY); stdcall; begin EnterCriticalSection; try if AValue <> RootKey then case AValue of cDontUseRootKey, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA: FRootKey := AValue; else raise EGMException.ObjError(GMFormat(RStrInvalidRootKey, [AValue]), Self, {$I %CurrentRoutine%}); end; FRootKeyAsString := ''; finally LeaveCriticalSection; end; end; function TGMStorageBase.CurrentPath: TGMString; stdcall; var prefix: TGMString; begin EnterCriticalSection; try prefix := AddBasePath(''); Result := GMStrip(Copy(FCurrentPath, Length(prefix) + 1, Length(FCurrentPath) - Length(prefix)), cDirSep); finally LeaveCriticalSection; end; end; function TGMStorageBase.OpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean): Boolean; stdcall; var fullPath: TGMString; begin EnterCriticalSection; try fullPath := AddBasePath(ExpandPath(ADirPath)); if GMSameText(fullPath, FCurrentPath) then Result := True else begin Result := InternalOpenDir(fullPath, ACreateIfNotExist); if Result then FCurrentPath := fullPath; end; finally LeaveCriticalSection; end; end; function TGMStorageBase.DeleteDir(const ADirPath: TGMString): Boolean; stdcall; var fullPath, dirPath, dirName: TGMString; begin EnterCriticalSection; try fullPath := AddBasePath(ExpandPath(ADirPath)); dirName := GMLastWord(fullPath, cDirSep); dirPath := Copy(fullPath, 1, Length(fullPath) - Length(dirName) - 1); Result := InternalOpenDir(dirPath, False) and InternalDeleteSubDir(dirName); finally LeaveCriticalSection; end; end; //function TGMStorageBase.DirExists(const ADirPath: TGMString): Boolean; //begin //EnterCriticalSection; //try // Result := InternalOpenDir(AddBasePath(ExpandPath(ADirPath)), False); //finally // LeaveCriticalSection; //end; //end; procedure TGMStorageBase.ReadSubDirNames(var ASubDirNames: TGMStringArray); stdcall; begin EnterCriticalSection; try SetLength(ASubDirNames, 0); InternalReadSubDirNames(ASubDirNames); finally LeaveCriticalSection; end; end; procedure TGMStorageBase.ReadValueNames(var AValueNames: TGMStringArray); stdcall; begin EnterCriticalSection; try SetLength(AValueNames, 0); InternalReadValueNames(AValueNames); finally LeaveCriticalSection; end; end; function TGMStorageBase.ContainsValue(const AValueName: TGMString): Boolean; stdcall; begin EnterCriticalSection; try Result := (AValueName <> '') and InternalContainsValue(AValueName); finally LeaveCriticalSection; end; end; function TGMStorageBase.DeleteValue(const AValueName: TGMString): Boolean; stdcall; begin EnterCriticalSection; try Result := (AValueName <> '') and InternalDeleteValue(AValueName); finally LeaveCriticalSection; end; end; //function TGMStorageBase.ReadString(const ValueName: TGMString; const DefaultValue: TGMString): TGMString; //begin // // Nothing! To be overriden in decendant class. //end; // //procedure TGMStorageBase.WriteString(const ValueName, Value: TGMString); //begin // // Nothing! To be overriden in decendant class. //end; { ---------------------------- } { ---- TGMRegistryStorage ---- } { ---------------------------- } {constructor TGMRegistryStorage.Create(const AOwner: TObject; const AFileName: TGMString = ''; const ABasePath: TGMString = ''; const ARootKey: LongWord = cDfltStorageRootKey; const ARefLifeTime: Boolean = False); begin inherited Create(AOwner, AFileName, ABasePath, ARootKey, ARefLifeTime); FRootKey := ARootKey; //FRegistry := TGMRegKey.CreateKey(ARootKey); //FRegistry := TRegistry.Create; //Registry.RootKey := RootKey; end; destructor TGMRegistryStorage.Destroy; begin GMFreeAndNil(FRegistry); inherited Destroy; end; procedure TGMRegistryStorage.SetBasePath(const Value: TGMString); begin inherited SetBasePath(Value); //Registry.CloseKey; end; function TGMRegistryStorage.GetRootKey: LongWord; begin Result := FRootKey; //Registry.RootKey; end; procedure TGMRegistryStorage.SetRootKey(const Value: LongWord); begin if Value <> RootKey then FRootKey := Value; // Registry.RootKey := Value; end; function TGMRegistryStorage.UseRootKey: Boolean; begin Result := False; end; function TGMRegistryStorage.InternalOpenDir(const DirPath: TGMString; const CreateIfNotExist: Boolean = False): Boolean; begin Result := Registry.OpenKey(DirPath, CreateIfNotExist); end; function TGMRegistryStorage.InternalDirExists(const DirPath: TGMString): Boolean; begin Result := Registry.KeyExists(DirPath); end; procedure TGMRegistryStorage.InternalReadSubDirNames(const SubDirNames: IGMStrings); var i: LongInt; Values: TStrings; begin Values := TStringList.Create; try Registry.GetKeyNames(Values); for i:=0 to Values.Count-1 do SubDirNames.Add(Values[i]); finally Values.Free; end; end; procedure TGMRegistryStorage.InternalReadValueNames(const ValueNames: IGMStrings); var i: LongInt; Values: TStrings; begin Values := TStringList.Create; try Registry.GetValueNames(Values); for i:=0 to Values.Count-1 do ValueNames.Add(Values[i]); finally Values.Free; end; end; function TGMRegistryStorage.InternalDeleteValue(const ValueName: TGMString): Boolean; begin Result := Registry.DeleteValue(ValueName); end; function TGMRegistryStorage.InternalDeleteDir(const DirPath: TGMString): Boolean; begin Result := Registry.DeleteKey(DirPath); end; function TGMRegistryStorage.ReadString(const ValueName: TGMString; const DefaultValue: TGMString = ''): TGMString; begin try Result := Registry.ReadString(ValueName); except Result := DefaultValue end; end; procedure TGMRegistryStorage.WriteString(const ValueName, Value: TGMString); begin Registry.WriteString(ValueName, Value); end;} { ------------------------------- } { ---- TGMCompoundDocStorage ---- } { ------------------------------- } constructor TGMCompoundDocStorage.Create(const ARefLifeTime: Boolean = False); begin inherited Create(ARefLifeTime); FStorageList := TGMIntfArrayCollection.Create; end; constructor TGMCompoundDocStorage.Create(const AOwner: IUnknown; const AFileName: TGMString; const ABasePath: TGMString; const ARootKey: HKEY; const ARefLifeTime: Boolean); begin inherited Create(AOwner, AFileName, ABasePath, ARootKey, ARefLifeTime); SetFileName(AFileName); end; destructor TGMCompoundDocStorage.Destroy; begin CommitAndRelease; inherited Destroy; end; function TGMCompoundDocStorage.StringStorage: IStorage; begin if FCurrentStorage <> nil then Result := FCurrentStorage else Result := RootStorage; end; procedure TGMCompoundDocStorage.Commit; begin EnterCriticalSection; try if FRootStorage <> nil then GMHrCheckObj(FRootStorage.Commit(STGC_OVERWRITE or STGC_CONSOLIDATE), Self, 'Commit'); finally LeaveCriticalSection; end; end; procedure TGMCompoundDocStorage.CommitAndRelease; begin Commit; if FStorageList <> nil then FStorageList.Clear; FCurrentStorage := nil; FRootStorage := nil; end; procedure TGMCompoundDocStorage.SetFileName(const AFileName: TGMString); begin EnterCriticalSection; try if GMSameText(AFileName, FFileName) then Exit; CommitAndRelease; inherited SetFileName(AFileName); finally LeaveCriticalSection; end; end; function TGMCompoundDocStorage.GetGUID: TGUID; stdcall; begin EnterCriticalSection; try Result := FGuid; finally LeaveCriticalSection; end; end; procedure TGMCompoundDocStorage.SetGUID(const AValue: TGUID); stdcall; begin EnterCriticalSection; try if IsEqualGuid(AValue, FGuid) then Exit; // Use FRootStorage -> don't create Storage here if FRootStorage <> nil then GMHrCheckObj(FRootStorage.SetClass(AValue), Self, {$I %CurrentRoutine%}); FGuid := AValue; finally LeaveCriticalSection; end; end; function TGMCompoundDocStorage.RootStorage: IStorage; begin if FRootStorage = nil then if GMFileExists(FFileName) then GMHrCheckObjParams(StgOpenStorage(PWideChar(UnicodeString(FFileName)), nil, STGM_READWRITE or STGM_SHARE_EXCLUSIVE, nil, 0, FRootStorage), [PGMChar(FFileName)], Self, GMFormat('StgOpenStorage("%s")', [FFileName])) else begin if FFileName <> '' then GMHrCheckObjParams(StgCreateDocfile(PWideChar(UnicodeString(FFileName)), STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, FRootStorage), [PGMChar(FFileName)], Self, GMFormat('StgCreateDocfile("%s")', [FFileName])) else GMHrCheckObj(StgCreateDocfileOnILockBytes(TGMMemoryLockBytes.Create, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, FRootStorage), Self, 'StgCreateDocfileOnILockBytes'); GMHrCheckObj(FRootStorage.SetClass(FGuid), Self, 'SetClass'); end; Result := FRootStorage; end; procedure TGMCompoundDocStorage.ReadEntryNames(var AEntryNames: TGMStringArray; const AElementType: LongInt); var PIEnum: IEnumSTATSTG; Element: TStatStg; begin if CurrentStorage <> nil then begin GMHrCheckObj(CurrentStorage.EnumElements(0, nil, 0, PIEnum), Self, {$I %CurrentRoutine%}); while PIEnum.Next(1, Element, nil) = S_OK do if Element.pwcsName <> nil then begin if Element.dwType = AElementType then GMAddStrToArray(Element.pwcsName, AEntryNames); //AEntryNames.Add(Element.pwcsName); CoTaskMemFree(Element.pwcsName); end; end; end; function TGMCompoundDocStorage.DeleteEntry(const AEntryName: TGMString): Boolean; var hr: HResult; begin Result := False; if CurrentStorage <> nil then begin hr := CurrentStorage.DestroyElement(PWideChar(UnicodeString(AEntryName))); Result := GMHrSucceeded(hr); if hr <> STG_E_FILENOTFOUND then GMHrCheckObjParams(hr, [PGMChar(AEntryName)], Self, {$I %CurrentRoutine%}); end; end; function TGMCompoundDocStorage.InternalOpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean): Boolean; var chPos: PtrInt; dirName: UnicodeString; tmpStorage: IStorage; hr: HResult; gmStrDirName: TGMString; begin if RootStorage = nil then Result := False else begin FStorageList.Clear; FCurrentPath := ''; Result := True; // try FCurrentStorage := RootStorage; chPos := 1; dirName := GMNextWord(chPos, ADirPath, cDirSep); while Result and (Length(dirName) > 0) do begin hr := FCurrentStorage.OpenStorage(PWideChar(dirName), nil, STGM_READWRITE or STGM_SHARE_EXCLUSIVE, nil, 0, tmpStorage); Result := hr = S_OK; if Result then FStorageList.Add(tmpStorage) else if hr <> STG_E_FILENOTFOUND then begin gmStrDirName := dirName; GMHrCheckObjParams(hr, [PGMChar(gmStrDirName)], Self, {$I %CurrentRoutine%}); end; if not Result and ACreateIfNotExist then begin GMHrCheckObj(FCurrentStorage.CreateStorage(PWideChar(dirName), STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, 0, tmpStorage), Self, {$I %CurrentRoutine%}); FStorageList.Add(tmpStorage); Result := True; end; if Result then begin FCurrentStorage := tmpStorage; FCurrentPath := GMAppendStrippedPath(FCurrentPath, dirName); dirName := GMNextWord(chPos, ADirPath, cDirSep); end; end; // except // FCurrentStorage := nil; FStorageList.Clear; FCurrentPath := ''; raise; // end; // The following will be skipped by exceptions // if Result and ASetAsCurrentDir then begin FCurrentStorage := storage; FStorageList := stgList; end; end; end; procedure TGMCompoundDocStorage.InternalReadSubDirNames(var ASubDirNames: TGMStringArray); begin ReadEntryNames(ASubDirNames, STGTY_STORAGE); end; procedure TGMCompoundDocStorage.InternalReadValueNames(var AValueNames: TGMStringArray); begin ReadEntryNames(AValueNames, STGTY_STREAM); end; function TGMCompoundDocStorage.InternalContainsValue(const AValueName: TGMString): Boolean; var stream: IStream; hr: HResult; storage: IStorage; begin storage := StringStorage; Result := (storage <> nil) and (Length(AValueName) > 0); if Result then begin hr := storage.OpenStream(PWideChar({$IFNDEF UNICODE}UnicodeString({$ENDIF}AValueName{$IFNDEF UNICODE}){$ENDIF}), nil, STGM_READ or STGM_SHARE_EXCLUSIVE, 0, stream); Result := GMHrSucceeded(hr); // = S_OK; end; end; function TGMCompoundDocStorage.InternalDeleteValue(const AValueName: TGMString): Boolean; begin Result := DeleteEntry(AValueName); end; function TGMCompoundDocStorage.InternalDeleteSubDir(const ADirName: TGMString): Boolean; begin Result := DeleteEntry(ADirName); end; //function TGMCompoundDocStorage.InternalDeleteDir(const ADirPath: TGMString): Boolean; //var dirPath, dirName: TGMString; //begin //dirName := GMLastWord(ADirPath, cDirSep); //dirPath := Copy(ADirPath, 1, Length(ADirPath) - Length(dirName) - 1); //Result := InternalOpenDir(dirPath, False) and DeleteEntry(dirName); //end; //function TGMCompoundDocStorage.DeleteDir(const ADirPath: TGMString): Boolean; //var dirName, path: TGMString; //begin //EnterCriticalSection; //try // dirName := GMLastWord(ADirPath, cDirSep); // path := Copy(ADirPath, 1, Length(ADirPath) - Length(dirName)); // Result := ((Length(path) <= 0) or OpenDir(path)) and DeleteEntry(dirName); //finally // LeaveCriticalSection; //end; //end; function TGMCompoundDocStorage.ReadString(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; stdcall; var stream: IStream; hr: HResult; storage: IStorage; begin EnterCriticalSection; try try storage := StringStorage; if (storage = nil) or (Length(AValueName) <= 0) then Result := ADefaultValue else begin hr := storage.OpenStream(PWideChar({$IFNDEF UNICODE}UnicodeString({$ENDIF}AValueName{$IFNDEF UNICODE}){$ENDIF}), nil, STGM_READ or STGM_SHARE_EXCLUSIVE, 0, stream); if hr <> S_OK then begin Result := ADefaultValue; Exit; end; SetLength(Result, GMIStreamSize(stream) div SizeOf(TGMChar)); if Length(Result) > 0 then GMSafeIStreamRead(stream, PGMChar(Result), Length(Result) * SizeOf(TGMChar), {$I %CurrentRoutine%}); end; except Result := ADefaultValue; end; finally LeaveCriticalSection; end; end; procedure TGMCompoundDocStorage.WriteString(const AValueName, AValue: TGMString); stdcall; var stream: IStream; storage: IStorage; begin EnterCriticalSection; try storage := StringStorage; Assert(storage <> nil, {$I %CurrentRoutine%} + ': storage <> nil'); if (storage <> nil) and (AValueName <> '') then begin GMHrCheckObj(storage.CreateStream(PWideChar({$IFNDEF UNICODE}UnicodeString({$ENDIF}AValueName{$IFNDEF UNICODE}){$ENDIF}), STGM_WRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, 0, stream), Self, {$I %CurrentRoutine%}); GMSafeIStreamWrite(stream, PGMChar(AValue), Length(AValue) * SizeOf(TGMChar), {$I %CurrentRoutine%}); end; finally LeaveCriticalSection; end; end; { --------------------------- } { ---- TGMIniFileSection ---- } { --------------------------- } constructor TGMIniFileSection.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FSubSections := TGMObjArrayCollection.Create(True, False, True, GMCompareByName, True); FValues := TGMIntfArrayCollection.Create(False, True, GMCompareByNameDigitsAsNumbers, True); end; constructor TGMIniFileSection.Create(const AParent: TGMIniFileSection; const AName: TGMString; const ARefLifeTime: Boolean); begin Create(AName, ARefLifeTime); FParentSection := AParent; if AParent <> nil then AParent.SubSections.Add(Self) end; function TGMIniFileSection.Parent: IGMTreeable; begin Result := ParentSection; end; function TGMIniFileSection.FirstChild: IGMTreeable; begin if not GMGetInterface(FSubSections.First, IGMTreeable, Result) then Result := nil; end; function TGMIniFileSection.NextSibling: IGMTreeable; var idx: PtrInt; begin Result := nil; if ParentSection <> nil then begin idx := ParentSection.SubSections.IndexOf(Self); if (idx <> cInvalidItemIdx) and ParentSection.SubSections.IsValidIndex(idx + 1) then GMGetInterface(ParentSection.SubSections[idx + 1], IGMTreeable, Result); end; end; function TGMIniFileSection.PrevSibling: IGMTreeable; var idx: PtrInt; begin Result := nil; if ParentSection <> nil then begin idx := ParentSection.SubSections.IndexOf(Self); if (idx <> cInvalidItemIdx) and ParentSection.SubSections.IsValidIndex(idx - 1) then GMGetInterface(ParentSection.SubSections[idx - 1], IGMTreeable, Result); end; end; function TGMIniFileSection.ContainsValue(const AValueName: TGMString): Boolean; var searchName: IGMGetName; begin searchName := TGMNameObj.Create(AValueName); Result := GMCollectionContains(Values, searchName); end; { --------------------------- } { ---- TGMIniFileStorage ---- } { --------------------------- } constructor TGMIniFileStorage.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FRootSection := TGMIniFileSection.Create(False); FCharKind := ckUnknown; end; destructor TGMIniFileStorage.Destroy; begin GMFreeAndNil(FRootSection); inherited; end; function TGMIniFileStorage.InternalOpenDir(const ADirPath: TGMString; const ACreateIfNotExist: Boolean): Boolean; var dirName: TGMString; chPos: PtrInt; searchName: IUnknown; foundSection: TGMIniFileSection; begin LoadFile; Result := True; FCurrentSection := RootSection; FCurrentPath := ''; chPos := 1; repeat dirName := GMNextWord(chPos, ADirPath, cDirSep); if Length(dirName) > 0 then begin searchName := TGMNameObj.Create(dirName); if CurrentSection.SubSections.Find(searchName, foundSection) then FCurrentSection := foundSection else if not ACreateIfNotExist then begin Result := False; Break; end else begin FCurrentSection := TGMIniFileSection.Create(FCurrentSection, dirName); FDataChanged := True; end; if Result then FCurrentPath := GMAppendStrippedPath(FCurrentPath, dirName); end; until Length(dirName) <= 0; end; procedure TGMIniFileStorage.LoadFromStream(const ASrcStream: ISequentialStream; const ACharKind: TGMCharKind); var line, name, val: TGMString; pchStart, pchEnd: PGMChar; nameLen: PtrInt; byteBuffer: AnsiString; bufByteCount, byteBufChPos: Integer; lineEnd: EGMLineEndKind; //startTicks: QWord; {$INCLUDE ReadNextLine.inc} begin //startTicks := GetTickCount64; SetLength(byteBuffer, cDfltCopyBufferSize); bufByteCount := 0; byteBufChPos := 1; line := ''; // lineNo := 0; section := nil; FCurrentSection := nil; FCurrentPath := ''; lineEnd := lekUnknown; FIniFileLoading := True; // <- Avoid recursion via InternalOpenDir calling LoadFile again try while ReadNextLine(ASrcStream, ACharKind, line, lineEnd, Self) do begin line := GMResolveEscapeChars(line, Self); // <- dont strip the line! // Inc(lineNo); if Length(line) <= 0 then Continue; case line[1] of '[': begin line := System.Copy(line, 2, Length(line)-2); if not InternalOpenDir(line, True) then raise EGMException.ObjError(GMFormat(RStrCreateDirFailed, [line]), Self, {$I %CurrentRoutine%}); end; ';': ; // <- Nothing, ignore comment lines! else if CurrentSection <> nil then begin pchStart := PGMChar(line); pchEnd := GMStrLScan(pchStart, '=', Length(line)); if pchEnd = nil then begin name := line; val := ''; end else begin nameLen := pchEnd - pchStart; name := Copy(line, 1, nameLen); val := Copy(line, nameLen + 2, Length(line) - nameLen - 1); end; CurrentSection.Values.Add(TGMNameAndStrValueObj.Create(name, val)); end; end; end; finally FIniFileLoading := False; end; //vfGMTrace(GMFormat('Ini file load duration: %d', [GetTickCount64 - startTicks]), {$I %CurrentRoutine%}); end; procedure TGMIniFileStorage.LoadFile; var fileStrm: IStream; begin if not FIniFileLoaded and not FIniFileLoading then begin if GMFileExists(FileName) then begin fileStrm := TGMFileIStream.CreateRead(FileName); FCharKind := GMReadBOMCharKind(fileStrm, ckAnsi); LoadFromStream(fileStrm, FCharKind); end; FIniFileLoaded := True; end; end; procedure TGMIniFileStorage.WriteIniToStream(const ADstStream: ISequentialStream; const ACharKind: TGMCharKind); procedure WriteString(const AStrValue: TGMString); var aStr: AnsiString; wStr: UnicodeString; begin case ACharKind of ckAnsi: begin aStr := AStrValue; GMSafeIStreamWrite(ADstStream, PAnsiChar(aStr), Length(aStr), {$I %CurrentRoutine%}); end; ckUtf8: begin aStr := GMStringToUtf8(AStrValue); GMSafeIStreamWrite(ADstStream, PAnsiChar(aStr), Length(aStr), {$I %CurrentRoutine%}); end; ckUtf16LE: begin wStr := AStrValue; GMSafeIStreamWrite(ADstStream, PWideChar(wStr), Length(wStr) * SizeOf(WideChar), {$I %CurrentRoutine%}); end; end; end; procedure WriteSection(const ASection: TGMIniFileSection; AParentPath: TGMString); var it: IGMIterator; unkVal: IUnknown; getName: IGMGetName; getStrVal: IGMGetStringValue; subSection: TGMIniFileSection; begin if ASection = nil then Exit; AParentPath := GMAppendStrippedPath(AParentPath, ASection.Name); if (Length(AParentPath) > 0) and not ASection.Values.IsEmpty then begin WriteString('['+ GMInsertEscapeChars(AParentPath) +']'+cNewLine); it := ASection.Values.CreateIterator; while it.NextEntry(unkVal) do if GMQueryInterface(unkVal, IGMGetName, getName) and GMQueryInterface(unkVal, IGMGetStringValue, getStrVal) then WriteString(GMInsertEscapeChars(getName.Name + '=' + getStrVal.StringValue) + cNewLine); WriteString(cNewLine); end; it := ASection.SubSections.CreateIterator; while it.NextEntry(subSection) do WriteSection(subSection, AParentPath); end; begin WriteSection(RootSection, ''); end; procedure TGMIniFileStorage.InternalReadSubDirNames(var ASubDirNames: TGMStringArray); var it: IGMIterator; section: TGMIniFileSection; begin if CurrentSection = nil then Exit; it := CurrentSection.SubSections.CreateIterator; while it.NextEntry(section) do GMAddStrToArray(section.Name, ASubDirNames); // GMAddStrToArray(GMGetObjName(section), ASubDirNames); end; procedure TGMIniFileStorage.InternalReadValueNames(var AValueNames: TGMStringArray); var it: IGMIterator; unkVal: IUnknown; begin if CurrentSection = nil then Exit; it := CurrentSection.Values.CreateIterator; while it.NextEntry(unkVal) do GMAddStrToArray(GMGetIntfName(unkVal), AValueNames); end; function TGMIniFileStorage.InternalContainsValue(const AValueName: TGMString): Boolean; begin Result := (CurrentSection <> nil) and CurrentSection.ContainsValue(AValueName); end; function TGMIniFileStorage.InternalDeleteValue(const AValueName: TGMString): Boolean; var searchName: IUnknown; begin if CurrentSection = nil then Result := False else begin searchName := TGMNameObj.Create(AValueName, True); Result := CurrentSection.Values.RemoveByKey(searchName); if Result then FDataChanged := True; end; end; function TGMIniFileStorage.InternalDeleteSubDir(const ADirName: TGMString): Boolean; var searchName: IUnknown; begin if CurrentSection = nil then Result := False else begin searchName := TGMNameObj.Create(ADirName, True); Result := CurrentSection.SubSections.RemoveByKey(searchName); if Result then FDataChanged := True; end; end; function TGMIniFileStorage.ReadString(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; stdcall; var searchName, foundEntry: IUnknown; getVal: IGMGetStringValue; begin EnterCriticalSection; try if CurrentSection = nil then begin Result := ADefaultValue; Exit; end; //LoadFile; <- No! searchName := TGMNameObj.Create(AValueName, True); if CurrentSection.Values.Find(searchName, foundEntry) and GMQueryInterface(foundEntry, IGMGetStringValue, getVal) then Result := getVal.StringValue else Result := ADefaultValue; finally LeaveCriticalSection; end; end; procedure TGMIniFileStorage.WriteString(const AValueName, AValue: TGMString); stdcall; var searchName, foundEntry: IUnknown; strValGetSet: IGMGetSetStringValue; begin EnterCriticalSection; try if CurrentSection = nil then Exit; //LoadFile; <- No! searchName := TGMNameObj.Create(AValueName, True); if CurrentSection.Values.Find(searchName, foundEntry) then begin GMCheckQueryInterface(foundEntry, IGMGetSetStringValue, strValGetSet); if strValGetSet.StringValue <> AValue then begin strValGetSet.StringValue := AValue; FDataChanged := True; end; end else begin foundEntry := TGMNameAndStrValueObj.Create(AValueName, AValue); CurrentSection.Values.Add(foundEntry); FDataChanged := True; end; finally LeaveCriticalSection; end; end; procedure TGMIniFileStorage.Commit; stdcall; var dstStrm: IStream; charKind: TGMCharKind; begin EnterCriticalSection; try inherited; if not FDataChanged or (Length(FileName) <= 0) then Exit; charKind := FCharKind; if charKind = ckUnknown then charKind := ckUtf8; // ckUtf16LE; dstStrm := TGMBufferedIStream.Create(TGMFileIStream.CreateOverwrite(FileName)); GMWriteBOM(dstStrm, charKind); WriteIniToStream(dstStrm, charKind); FDataChanged := False; finally LeaveCriticalSection; end; end; { --------------------------- } { ---- TGMPersistentData ---- } { --------------------------- } constructor TGMPersistentData.Create(const AStorageClass: TGMStorageClass; const AFileName: TGMString; const ABasePath: TGMString; const ARootKey: LongWord; const ARefLifeTime: Boolean); begin Assert(AStorageClass <> nil); inherited Create(ARefLifeTime); FCriticalSection := TGMCriticalSection.Create(True); FDefinedValues := TGMObjArrayCollection.Create(True, False, True, PersistentValueIdCompareFunc, False); // FValueStorer needs a reference to FStorage. Use method pointers instead of // interface reference here because FValueStorer and FStorage are used as // implementing members of TGMPersistentData. Otherwise a cyclic reference // will keep TGMPersistentData forever. FStorage := AStorageClass.Create(Self, AFileName, ABasePath, ARootKey, False); FValueStorer := TGMValueStorageImpl.Create(Self, FStorage.ReadString, FStorage.WriteString, False); end; destructor TGMPersistentData.Destroy; begin GMFreeAndNil(FDefinedValues); GMFreeAndNil(FValueStorer); GMFreeAndNil(FStorage); inherited Destroy; end; //function TGMPersistentData.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; //var PI: PInterfaceEntry; //begin // PI := GetInterfaceEntry(IID); // Result := inherited QueryInterface(IID, Intf); //end; procedure TGMPersistentData.ChangeStorage(const ANewFileName: TGMString; ANewStorageClass: TGMStorageClass; const ACopyContents: Boolean); var oldStorage: TGMStorageBase; // SyncLock: IUnknown; begin //SyncLock := TGMCriticalSectionLock.Create(Self, True); FCriticalSection.EnterCriticalSection; try // Same AFileName makes no sense, even with different storage classes if (ANewFileName <> '') and GMSameText(ANewFileName, Storage.GetFileName) then Exit; oldStorage := Storage; if ANewStorageClass = nil then ANewStorageClass := TGMStorageClass(Storage.ClassType); FStorage := ANewStorageClass.Create(Self, ANewFileName, Storage.GetBasePath, Storage.GetRootKey, False); try ValueStorer.ReadStringFunc := Storage.ReadString; ValueStorer.WriteStringProc := Storage.WriteString; if ACopyContents then GMVsdCopyStorageContents(oldStorage, Storage, '\'); finally GMFreeAndNil(oldStorage); end; finally FCriticalSection.LeaveCriticalSection; end; end; {function TGMPersistentData.GetFileName: TGMString; begin Result := Storage.GetFileName; end; procedure TGMPersistentData.SetFileName(const Value: TGMString); begin Storage.SetFileName(Value); end;} function TGMPersistentData.FindValue(const AId: LongInt; var Value: TGMPersistentValue): Boolean; var PIKey: IUnknown; begin PIKey := TGMPersistentValue.Create(AId, '', '', 0, Null, True); Result := DefinedValueList.Find(PIKey, Value); end; procedure TGMPersistentData.DefineValue(const Id: LongInt; const DirPath, ValueName: TGMString; const DefaultValue: OleVariant); var DefinedValue: TGMPersistentValue; // SyncLock: IUnknown; begin //SyncLock := TGMCriticalSectionLock.Create(Self, True); FCriticalSection.EnterCriticalSection; try if FindValue(Id, DefinedValue) then raise EGMException.ObjError(GMFormat(RStrValueAlreadyExists, [Id]), Self, {$I %CurrentRoutine%}); DefinedValueList.Add(TGMPersistentValue.Create(Id, DirPath, ValueName, VarType(DefaultValue), DefaultValue)); finally FCriticalSection.LeaveCriticalSection; end; end; procedure TGMPersistentData.ValueNotExists(const ValueId: LongInt); begin raise EGMException.ObjError(GMFormat(RStrValueNotInSection, [ValueId]), Self, {$I %CurrentRoutine%}); end; function TGMPersistentData.GetDefinedValue(ValueId: LongInt): OleVariant; var DefinedValue: TGMPersistentValue; savePath: TGMString; // SyncLock: IUnknown; begin //SyncLock := TGMCriticalSectionLock.Create(Self, True); FCriticalSection.EnterCriticalSection; try Result := Null; if not FindValue(ValueId, DefinedValue) then ValueNotExists(ValueId) else begin savePath := Storage.CurrentPath; try if not GMVsdOpenDir(Storage, DefinedValue.DirPath, False) then Result := DefinedValue.DefaultValue else case DefinedValue.VariantType of varByte, varSmallint, varInteger{$IFDEF DELPHI6}, varWord, varLongWord{$ENDIF}: Result := ValueStorer.ReadInteger(DefinedValue.ValueName, DefinedValue.DefaultValue); varSingle, varDouble, varCurrency: Result := ValueStorer.ReadDouble(DefinedValue.ValueName, DefinedValue.DefaultValue); varDate: Result := ValueStorer.ReadDateTime(DefinedValue.ValueName, DefinedValue.DefaultValue); varOleStr, varString: Result := ValueStorer.ReadString(DefinedValue.ValueName, DefinedValue.DefaultValue); varBoolean: Result := ValueStorer.ReadBoolean(DefinedValue.ValueName, DefinedValue.DefaultValue); else Result := ValueStorer.ReadVariant(DefinedValue.ValueName, DefinedValue.DefaultValue); end; finally GMVsdOpenAbsDir(Storage, savePath, False); end; end; finally FCriticalSection.LeaveCriticalSection; end; end; procedure TGMPersistentData.SetDefinedValue(ValueId: LongInt; const Value: OleVariant); var DefinedValue: TGMPersistentValue; savePath: TGMString; // SyncLock: IUnknown; begin //SyncLock := TGMCriticalSectionLock.Create(Self, True); FCriticalSection.EnterCriticalSection; try if not FindValue(ValueId, DefinedValue) then ValueNotExists(ValueId) else begin savePath := Storage.CurrentPath; try if GMVsdOpenDir(Storage, DefinedValue.DirPath, True) then case DefinedValue.VariantType of varByte, varSmallint, varInteger{$IFDEF DELPHI6}, varWord, varLongWord{$ENDIF}: GMStoreInteger(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); varSingle, varDouble, varCurrency: GMStoreDouble(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); varDate: GMStoreDateTime(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); varOleStr, varString: GMStoreString(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); varBoolean: GMStoreBoolean(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); else GMStoreVariant(Self, DefinedValue.ValueName, Value, DefinedValue.DefaultValue); end; finally GMVsdOpenAbsDir(Storage, savePath, False); end; end; finally FCriticalSection.LeaveCriticalSection; end; end; end.