[JVCL-Checkins] CVS: dev/JVCL3/run JvAppRegistryStore.pas,NONE,1.1 JvAppStore.pas,NONE,1.1

[Marcel B. <jed...@us...>]

Update of /cvsroot/jvcl/dev/JVCL3/run
In directory sc8-pr-cvs1:/tmp/cvs-serv20064/dev/JVCL3/run

Added Files:
	JvAppRegistryStore.pas JvAppStore.pas 
Log Message:
Starting units for generic storage backend.

--- NEW FILE: JvAppRegistryStore.pas ---
{ Insert famous MPL header here... }

unit JvAppRegistryStore;

interface

uses
  Classes, Windows,
  JvGenStore;

type
  TJvAppRegistryStore = class(TJvCustomAppStore)
  private
    FRegHKEY: HKEY;
  protected
    function GetApplicationRoot: string;
    procedure SetApplicationRoot(Value: string);
    { Split the specified path into an absolute path and a value name (the last item in the path
      string). Just a helper for all the storage methods. }
    procedure SplitKeyPath(const Path: string; out Key, ValueName: string);
  public
    constructor Create(AOwner: TComponent); override;
    function ValueStored(const Path: string): Boolean; override;
    procedure DeleteValue(const Path: string); override;
    function ReadInteger(const Path: string; Default: Integer = 0): Integer; override;
    procedure WriteInteger(const Path: string; Value: Integer); override;
    function ReadFloat(const Path: string; Default: Extended = 0): Extended; override;
    procedure WriteFloat(const Path: string; Value: Extended); override;
    function ReadString(const Path: string; Default: string = ''): string; override;
    procedure WriteString(const Path: string; Value: string); override;
    function ReadBinary(const Path: string; var Buf; BufSize: Integer): Integer; override;
    procedure WriteBinary(const Path: string; const Buf; BufSize: Integer); override;
  published
    { Application specific root. Determines in which of the main registry keys (Local Machine,
      Current User, etc) the data will be stored. Optionally a sub key may be added to this key
      (eg. 'HKEY_LOCAL_MACHINE\Software\Project JEDI'). The sub key is internally stored in the
      AppRoot property.}
    property ApplicationRoot: string read GetApplicationRoot write SetApplicationRoot;
  end;

implementation

uses
  SysUtils,
  JclRegistry, JclResources, JclStrings;

const
  HKEY_Names: array[HKEY_CLASSES_ROOT .. HKEY_DYN_DATA] of string = (
    'HKEY_CLASSES_ROOT',
    'HKEY_CURRENT_USER',
    'HKEY_LOCAL_MACHINE',
    'HKEY_USERS',
    'HKEY_PERFORMANCE_DATA',
    'HKEY_CURRENT_CONFIG',
    'HKEY_DYN_DATA'
  );

//===TJvAppRegistryStore=================================================================================

function TJvAppRegistryStore.GetApplicationRoot: string;
begin
  Result := HKEY_Names[FRegHKEY];
  if GetAppRoot <> '' then
    Result := Result + '\' + GetAppRoot;
end;

procedure TJvAppRegistryStore.SetApplicationRoot(Value: string);
var
  SL: TStrings;
  I: DWORD;
begin
  SL := TStringList.Create;
  try
    StrToStrings(Value, '\', SL, False);
    if SL.Count > 0 then
    begin
      I := HKEY_DYN_DATA;
      while (I >= HKEY_CLASSES_ROOT) and not AnsiSameText(HKEY_Names[I], SL[0]) do
        Dec(I);
      if I >= HKEY_CLASSES_ROOT then
      begin
        FRegHKEY := I;
        SL.Delete(0);
        SetAppRoot(StringsToStr(SL, '\', False));
      end
      else
        raise Exception.CreateFmt('''%s'' is not a valid registry location', [SL[0]]);
    end
    else
      raise Exception.Create('You need to specify a location.');
  finally
    SL.Free;
  end;
end;

procedure TJvAppRegistryStore.SplitKeyPath(const Path: string; out Key, ValueName: string);
var
  AbsPath: string;
  IValueName: Integer;
begin
  AbsPath := GetAbsPath(Path);
  IValueName := LastDelimiter('/', AbsPath);
  Key := StrLeft(AbsPath, IValueName - 1);
  ValueName := StrRestOf(AbsPath, IValueName + 1);
end;

function TJvAppRegistryStore.ValueStored(const Path: string): Boolean;
var
  SubKey: string;
  ValueName: string;
  TmpKey: HKEY;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  Result := RegKeyExists(FRegHKEY, SubKey);
  if Result then
  begin
    if RegOpenKey(FRegHKEY, PChar(SubKey), TmpKey) = ERROR_SUCCESS then
    try
      Result := RegQueryValueEx(TmpKey, PChar(ValueName), nil, nil, nil, nil) = ERROR_SUCCESS;
    finally
      RegCloseKey(TmpKey);
    end
    else
      raise EJclRegistryError.CreateResRecFmt(@RsUnableToOpenKeyRead, [SubKey]);
  end;
end;

procedure TJvAppRegistryStore.DeleteValue(const Path: string);
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  RegDeleteEntry(FRegHKEY, SubKey, ValueName);
end;

function TJvAppRegistryStore.ReadInteger(const Path: string; Default: Integer = 0): Integer;
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  Result := RegReadIntegerDef(FRegHKEY, SubKey, ValueName, Default);
end;

procedure TJvAppRegistryStore.WriteInteger(const Path: string; Value: Integer);
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  RegWriteInteger(FRegHKEY, SubKey, ValueName, Value);
end;

function TJvAppRegistryStore.ReadFloat(const Path: string; Default: Extended = 0): Extended;
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  Result := Default;
  RegReadBinary(FRegHKEY, SubKey, ValueName, Result, SizeOf(Result));
end;

procedure TJvAppRegistryStore.WriteFloat(const Path: string; Value: Extended);
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  RegWriteBinary(FRegHKEY, SubKey, ValueName, Value, SizeOf(Value));
end;

function TJvAppRegistryStore.ReadString(const Path: string; Default: string = ''): string;
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  Result := RegReadStringDef(FRegHKEY, SubKey, ValueName, Default);
end;

procedure TJvAppRegistryStore.WriteString(const Path: string; Value: string);
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  RegWriteString(FRegHKEY, SubKey, ValueName, Value);
end;

function TJvAppRegistryStore.ReadBinary(const Path: string; var Buf; BufSize: Integer): Integer;
var
  SubKey: string;
  ValueName: string;
begin
  SplitKeyPath(Path, SubKey, ValueName);
  Result := RegReadBinary(FRegHKEY, SubKey, ValueName, Buf, BufSize);
end;

procedure TJvAppRegistryStore.WriteBinary(const Path: string; const Buf; BufSize: Integer);
var
  SubKey: string;
  ValueName: string;
  TmpBuf: Byte;
begin
  TmpBuf := Byte(Buf);
  SplitKeyPath(Path, SubKey, ValueName);
  RegWriteBinary(FRegHKEY, SubKey, ValueName, TmpBuf, BufSize);
end;

constructor TJvAppRegistryStore.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRegHKEY := HKEY_CURRENT_USER;
end;

end.

--- NEW FILE: JvAppStore.pas ---
{ Insert famous MPL header here... }

unit JvAppStore;

{
  General storage unit - provides with a basic storage backend component to store application
  specific data. Descendants can provide specific backends for registry, INI-files, DB, XML,
  etc. Should be used to provide a common interface for storing data as is done in some of
  the JVCL components (eg. JvFormPlacement/JvFormStorage).

  This was requested in one of the comments of the JVCL 3.0 Survey Results.

  Paths
  =====
  Paths are relative to the current path. Paths are specified using backslashes (\) between
  individual folders and the value. Paths starting with a backslash are always relative to the root
  storage (application specific root, absolute root path).

  Dots (.) are used to reference parent folders with the following rules:
  * a single dot (.) refers to the current folder
  * each additional dot moves up a level in the folder hierarchie, ie. "....\Here" refers to a
    folder three levels up from the current where a sub folder/value name "Here" is searched. Of
    course the normal (OS path) specification can be used as well ("..\..\..\Here" would be the
    same as the first example).

  Multiple backslashes without names between them are ignored ("Root\\Here" is the same as
  "Root\Here").

  This unit is based on the following equation:

    Compilable code + no testing whatsoever = plenty of bugs

  This same equation holds up for the sample implementation for the registry storage in the
  additional unit, but due to the increase in code in that unit, the result will also be higher.
}

interface
                                              
uses
  Classes,
  JvComponent;

type
  TJvCustomAppStore = class;

  TAppStoreListItem = procedure(Sender: TJvCustomAppStore; const Path: string; const Index: Integer) of object;
  TAppStoreListDelete = procedure(Sender: TJvCustomAppStore; const Path: string; const First, Last: Integer) of object;

  TJvCustomAppStore = class(TJvComponent)
  private
    FAppRoot: string;
    FCurRoot: string;
    FStoreSL: TStrings;
  protected
    { Retrieve application specific root. Path is prepended to any path specified and serves as an
      absolute root for any storage method. }
    function GetAppRoot: string; virtual;
    { Set application specific root. Path is prepended to any path specified and serves as an
      absolute root for any storage method. }
    procedure SetAppRoot(Value: string); virtual;
    { Retrieves currently set path (including the AppRoot path). }
    function GetCurrentPath: string;
    { Returns the path as an absolute path (including the AppRoot path). If the given path does not
      start with a backslash (\) the path is appended to the Root path, resolving any references to
      parent folders. }
    function GetAbsPath(Path: string): string;
    { StringList item reader used by ReadStringList in the call to ReadList. }
    procedure ReadSLItem(Sender: TJvCustomAppStore; const Path: string; const Index: Integer);
    { StringList item writer used by WriteStringList in the call to WriteList. }
    procedure WriteSLItem(Sender: TJvCustomAppStore; const Path: string; const Index: Integer);
    { StringList item deleter used by WriteStringList in the call to WriteList. }
    procedure DeleteSLItems(Sender: TJvCustomAppStore; const Path: string; const First, Last: Integer);
    { Current root path for storage. Paths used in other methods are relative to this path. }
    function GetRoot: string; virtual;
    { Specify a new root. Given path is relative to the current path. Se remarks above }
    procedure SetRoot(const Path: string); virtual;

    { Application specific root. Path is prepended to any specified path and serves as an absolute
      root for any reading/writing. Not all implementation will use it. Generally it's used for
      storages not specific to an application (such as the registry). }
    property AppRoot: string read GetAppRoot write SetAppRoot;
    { Root of any values to be read/written. This value is combined with the path given in one of
      the Read*/Write* methods to determine the actual key used. }
    property Root: string read GetRoot write SetRoot;
  public
    { Determines if the specified value is stored }
    function ValueStored(const Path: string): Boolean; virtual; abstract;
    { Deletes the specified value. If the value wasn't stored, nothing will happen. }
    procedure DeleteValue(const Path: string); virtual; abstract;
    { Retrieves the specified Integer value. If the value is not found, the Default will be
      returned. If the value is not an Integer (or can't be converted to an Integer an EConvertError
      exception will be raised. }
    function ReadInteger(const Path: string; Default: Integer = 0): Integer; virtual; abstract;
    { Stores an Integer value. }
    procedure WriteInteger(const Path: string; Value: Integer); virtual; abstract;
    { Retrieves the specified Extended value. If the value is not found, the Default will be
      returned. If the value is not an Extended (or can't be converted to an Extended an
      EConvertError exception will be raised.}
    function ReadFloat(const Path: string; Default: Extended = 0): Extended; virtual; abstract;
    { Stores an Extended value. }
    procedure WriteFloat(const Path: string; Value: Extended); virtual; abstract;
    { Retrieves the specified string value. If the value is not found, the Default will be
      returned. If the value is not a string (or can't be converted to a string an EConvertError
      exception will be raised. }
    function ReadString(const Path: string; Default: string = ''): string; virtual; abstract;
    { Stores an string value. }
    procedure WriteString(const Path: string; Value: string); virtual; abstract;
    { Retrieves the specified TDateTime value. If the value is not found, the Default will be
      returned. If the value is not a TDateTime (or can't be converted to an TDateTime an
      EConvertError exception will be raised. }
    function ReadDateTime(const Path: string; Default: TDateTime = 0): TDateTime; virtual;
    { Stores a TDateTime value. }
    procedure WriteDateTime(const Path: string; Value: TDateTime); virtual;
    { Retrieves the specified value into a buffer. The result holds the number of bytes actually
      retrieved. }
    function ReadBinary(const Path: string; var Buf; BufSize: Integer): Integer; virtual; abstract;
    { Stores a buffer. }
    procedure WriteBinary(const Path: string; const Buf; BufSize: Integer); virtual; abstract;
    { Retrieves the specified list. Caller provides a callback method that will read the individual
      items. ReadList will first determine the number of items to read and calls the specified
      method for each item. }
    function ReadList(const Path: string; const OnReadItem: TAppStoreListItem): Integer; virtual;
    { Stores a list of items. The number of items is stored first. For each item the provided
      item write method is called. Any additional items in the list (from a previous write) will be
      removed by the optionally provided delete method. }
    procedure WriteList(const Path: string; const ItemCount: Integer;
      const OnWriteItem: TAppStoreListItem; const OnDeleteItems: TAppStoreListDelete = nil); virtual;
    { Retrieves a string list. The string list is optionally cleared before reading starts. The
      result value is the number of items read. Uses ReadList with internally provided methods to
      do the actual reading. }
    function ReadStringList(const Path: string; const SL: TStrings;
      const ClearFirst: Boolean = True): Integer; virtual;
    { Stores a string list. Uses WriteList with internally provided methods to do the actual
      storing. }
    procedure WriteStringList(const Path: string; const SL: TStrings); virtual;
  end;

implementation

uses
  SysUtils,
  JclStrings;

procedure UpdateGlobalPath(GlobalPaths, NewPaths: TStrings);
var
  I: Integer;
  J: Integer;
begin
  for I := 0 to NewPaths.Count - 1 do
  begin
    if StrLeft(NewPaths[I], 1) = '.' then
    begin
      J := Length(NewPaths[I]) - 1;
      if J > GlobalPaths.Count then
        J := GlobalPaths.Count;
      While J > 0 do
      begin
        GlobalPaths.Delete(GlobalPaths.Count - 1);
        Dec(J);
      end;
    end
    else
      GlobalPaths.Add(NewPaths[I]);
  end;
end;

function OptimizePaths(Paths: array of string): string;
var
  GlobalPaths: TStrings;
  CurPaths: TStrings;
  Index: Integer;
begin
  if Length(Paths) <> 0 then
  begin
    GlobalPaths := nil;
    CurPaths := nil;
    try
      GlobalPaths := TStringList.Create;
      CurPaths := TStringList.Create;
      Index := High(Paths);
      while (Index > 0) and (StrLeft(Paths[Index], 1) <> '\') do
        Dec(Index);
      repeat
        StrToStrings(Paths[Index], '\', CurPaths, False);
        UpdateGlobalPath(GlobalPaths, CurPaths);
        Inc(Index);
      until Index > High(Paths);
      Result := StringsToStr(GlobalPaths, '\', False);
    finally
      CurPaths.Free;
      GlobalPaths.Free;
    end;
  end
  else
    Result := '';
end;

//===TJvCustomAppStore==============================================================================

function TJvCustomAppStore.GetAppRoot: string;
begin
  Result := FAppRoot;
end;

procedure TJvCustomAppStore.SetAppRoot(Value: string);
begin
  FAppRoot := OptimizePaths([Value]);
end;

function TJvCustomAppStore.GetCurrentPath: string;
begin
  Result := GetAbsPath('');
end;

function TJvCustomAppStore.GetAbsPath(Path: string): string;
begin
  Result := GetAppRoot + '\' + OptimizePaths([GetRoot, Path]);
end;

procedure TJvCustomAppStore.ReadSLItem(Sender: TJvCustomAppStore; const Path: string;
  const Index: Integer);
begin
  Sender.FStoreSL.Add(Sender.ReadString(Path + '\Item' + IntToStr(Index)));
end;

procedure TJvCustomAppStore.WriteSLItem(Sender: TJvCustomAppStore; const Path: string;
  const Index: Integer);
begin
  Sender.WriteString(Path + '\Item' + IntToStr(Index), Sender.FStoreSL[Index]);
end;

procedure TJvCustomAppStore.DeleteSLItems(Sender: TJvCustomAppStore; const Path: string; const First,
  Last: Integer);
var
  I: Integer;
begin
  for I := First to Last do
    Sender.DeleteValue(Path + '\Item' + IntToStr(I));
end;

function TJvCustomAppStore.GetRoot: string;
begin
  Result := FCurRoot;
end;

procedure TJvCustomAppStore.SetRoot(const Path: string);
begin
  FCurRoot := OptimizePaths([Path]);
end;

function TJvCustomAppStore.ReadDateTime(const Path: string; Default: TDateTime): TDateTime;
begin
  Result := ReadFloat(Path, Default);
end;

procedure TJvCustomAppStore.WriteDateTime(const Path: string; Value: TDateTime);
begin
  WriteFloat(Path, Value);
end;

function TJvCustomAppStore.ReadList(const Path: string; const OnReadItem: TAppStoreListItem): Integer;
var
  I: Integer;
begin
  Result := ReadInteger(Path + '\Count');
  for I := 0 to Result - 1 do
    OnReadItem(Self, Path, I);
end;

procedure TJvCustomAppStore.WriteList(const Path: string; const ItemCount: Integer;
  const OnWriteItem: TAppStoreListItem; const OnDeleteItems: TAppStoreListDelete);
var
  PrevListCount: Integer;
  I: Integer;
begin
  PrevListCount := ReadInteger(Path + '\Count');
  WriteInteger(Path + '\Count', ItemCount);
  for I := 0 to ItemCount - 1 do
    OnWriteItem(Self, Path, I);
  if (PrevListCount > ItemCount) and Assigned(OnDeleteItems) then
    OnDeleteItems(Self, Path, ItemCount, PrevListCount - 1);
end;

function TJvCustomAppStore.ReadStringList(const Path: string; const SL: TStrings;
  const ClearFirst: Boolean): Integer;
begin
  if ClearFirst then
    SL.Clear;
  FStoreSL := SL;
  Result := ReadList(Path, ReadSLItem);
end;

procedure TJvCustomAppStore.WriteStringList(const Path: string; const SL: TStrings);
begin
  FStoreSL := SL;
  WriteList(Path, SL.Count, WriteSLItem, DeleteSLItems);
end;

end.