{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Persistent value storage interfaces and      | }
{ |                implemantions.                               | }
{ |                                                             | }
{ |   Copyright (C) - 2018 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code distributed 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.