jvappxmlstorage.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvAppXMLStorage.pas, released on 2003-12-06.

The Initial Developer of the Original Code is Olivier Sannier
Portions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier
All Rights Reserved.

Contributor(s):
  Marcel Bestebroer

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvAppXMLStorage.pas,v 1.51 2005/02/27 16:57:57 jfudickar Exp $

unit JvAppXMLStorage;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  {$IFDEF HAS_UNIT_LIBC}
  Libc,
  {$ENDIF HAS_UNIT_LIBC}
  Classes,
  JvAppStorage, JvPropertyStore, JvSimpleXml;

type
  TJvCustomAppXMLStorage = class;
  TJvAppXMLStorageOptions = class(TJvAppStorageOptions)
  private
    FWhiteSpaceReplacement: string;
    FStorage: TJvCustomAppXMLStorage;
    function GetAutoEncodeEntity: Boolean;
    function GetAutoEncodeValue: Boolean;
    procedure SetAutoEncodeEntity(const Value: Boolean);
    procedure SetAutoEncodeValue(const Value: Boolean);
    function GetAutoIndent: Boolean;
    procedure SetAutoIndent(const Value: Boolean);
  protected
    procedure SetWhiteSpaceReplacement(const Value: string);
  public
    constructor Create; override;
  published
    property WhiteSpaceReplacement: string read FWhiteSpaceReplacement write SetWhiteSpaceReplacement;
    property AutoEncodeValue: Boolean read GetAutoEncodeValue write SetAutoEncodeValue;
    property AutoEncodeEntity: Boolean read GetAutoEncodeEntity write SetAutoEncodeEntity;
    property AutoIndent: Boolean read GetAutoIndent write SetAutoIndent;
  end;

  // This is the base class for an in memory XML file storage
  // There is at the moment only one derived class that simply
  // allows to flush into a disk file.
  // But there may be a new descendent that stores into a
  // database field, if anyone is willing to write such
  // a class (nothing much is involved, use the AsString property).
  TJvCustomAppXMLStorage = class(TJvCustomAppMemoryFileStorage)
  private
    function GetStorageOptions : TJvAppXMLStorageOptions;
    procedure SetStorageOptions (Value: TJvAppXMLStorageOptions);
  protected
    FXml: TJvSimpleXML;

    class function GetStorageOptionsClass: TJvAppStorageOptionsClass; override;

    function GetAsString: string; override;
    procedure SetAsString(const Value: string); override;

    function EnsureNoWhiteSpaceInNodeName(NodeName: string): string;

    function DefaultExtension: string; override;

    function GetOnDecodeValue: TJvSimpleXMLEncodeEvent;
    function GetOnEncodeValue: TJvSimpleXMLEncodeEvent;
    procedure SetOnDecodeValue(const Value: TJvSimpleXMLEncodeEvent);
    procedure SetOnEncodeValue(const Value: TJvSimpleXMLEncodeEvent);

    function GetRootNodeName: string;
    procedure SetRootNodeName(const Value: string);
    // Returns the last node in path, if it exists.
    // Returns nil in all other cases
    // If StartNode is nil, then FXML.Root is used as a
    // starting point for Path
    function GetNodeFromPath(Path: string; StartNode: TJvSimpleXmlElem = nil): TJvSimpleXmlElem;
    // Reads the \ separated Key string and returns the last created node
    function CreateAndSetNode(Key: string): TJvSimpleXmlElem;
    procedure EnumFolders(const Path: string; const Strings: TStrings;
      const ReportListAsValue: Boolean = True); override;
    procedure EnumValues(const Path: string; const Strings: TStrings;
      const ReportListAsValue: Boolean = True); override;
    function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;
    procedure SplitKeyPath(const Path: string; out Key, ValueName: string); override;
    function PathExistsInt(const Path: string): Boolean; override;
    function ValueStoredInt(const Path: string): Boolean; override;
    procedure DeleteValueInt(const Path: string); override;
    procedure DeleteSubTreeInt(const Path: string); override;
    function DoReadBoolean(const Path: string; Default: Boolean): Boolean; override;
    procedure DoWriteBoolean(const Path: string; Value: Boolean); override;
    function DoReadInteger(const Path: string; Default: Integer): Integer; override;
    procedure DoWriteInteger(const Path: string; Value: Integer); override;
    function DoReadFloat(const Path: string; Default: Extended): Extended; override;
    procedure DoWriteFloat(const Path: string; Value: Extended); override;
    function DoReadString(const Path: string; const Default: string): string; override;
    procedure DoWriteString(const Path: string; const Value: string); override;
    function DoReadBinary(const Path: string; Buf: Pointer; BufSize: Integer): Integer; override;
    procedure DoWriteBinary(const Path: string; Buf: Pointer; BufSize: Integer); override;

    property Xml: TJvSimpleXML read FXml;
    property RootNodeName: string read GetRootNodeName write SetRootNodeName;
    property OnEncodeValue: TJvSimpleXMLEncodeEvent read GetOnEncodeValue write SetOnEncodeValue;
    property OnDecodeValue: TJvSimpleXMLEncodeEvent read GetOnDecodeValue write SetOnDecodeValue;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property StorageOptions: TJvAppXMLStorageOptions read GetStorageOptions write SetStorageOptions;
  end;

  // This class handles the flushing into a disk file
  // and publishes a few properties for them to be
  // used by the user in the IDE
  TJvAppXMLFileStorage = class(TJvCustomAppXMLStorage)
  public
    procedure Flush; override;
    procedure Reload; override;
    property Xml;
    property AsString;
  published
    property AutoFlush;
    property AutoReload;
    property FileName;
    property Location;
    property RootNodeName;
    property SubStorages;
    property OnGetFileName;
    property OnEncodeValue;
    property OnDecodeValue;
  end;

procedure StorePropertyStoreToXmlFile(APropertyStore: TJvCustomPropertyStore;
  const AFileName: string; const AAppStoragePath: string = '');
procedure LoadPropertyStoreFromXmlFile(APropertyStore: TJvCustomPropertyStore;
  const AFileName: string; const AAppStoragePath: string = '');

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvAppXMLStorage.pas,v $';
    Revision: '$Revision: 1.51 $';
    Date: '$Date: 2005/02/27 16:57:57 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysUtils, TypInfo,
  JclStrings,
  JvJCLUtils, JvTypes, JvConsts, JvResources;

const
  cNullDigit = '0';
  cCount = 'Count';
  cEmptyPath = 'EmptyPath';

//=== { TJvAppXMLStorageOptions } ============================================

constructor TJvAppXMLStorageOptions.Create;
begin
  inherited Create;
  FWhiteSpaceReplacement := '';  // to keep the original behaviour
end;

function TJvAppXMLStorageOptions.GetAutoEncodeEntity: Boolean;
begin
  Result := sxoAutoEncodeEntity in FStorage.Xml.Options;
end;

function TJvAppXMLStorageOptions.GetAutoEncodeValue: Boolean;
begin
  Result := sxoAutoEncodeValue in FStorage.Xml.Options;
end;

function TJvAppXMLStorageOptions.GetAutoIndent: Boolean;
begin
  Result := sxoAutoIndent in FStorage.Xml.Options;
end;

procedure TJvAppXMLStorageOptions.SetAutoEncodeEntity(
  const Value: Boolean);
begin
  if Value then
    FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoEncodeEntity]
  else
    FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoEncodeEntity];
end;

procedure TJvAppXMLStorageOptions.SetAutoEncodeValue(const Value: Boolean);
begin
  if Value then
    FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoEncodeValue]
  else
    FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoEncodeValue];
end;

procedure TJvAppXMLStorageOptions.SetAutoIndent(const Value: Boolean);
begin
  if Value then
    FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoIndent]
  else
    FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoIndent];
end;

procedure TJvAppXMLStorageOptions.SetWhiteSpaceReplacement(const Value: string);
begin
  if Value <> FWhiteSpaceReplacement then
    if StrContainsChars(Value, AnsiWhiteSpace, True) then
      raise EJVCLException.CreateRes(@RsEWhiteSpaceReplacementCannotContainSpaces)
    else
      FWhiteSpaceReplacement := Value;
end;

//=== { TJvCustomAppXMLStorage } =============================================

constructor TJvCustomAppXMLStorage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  (StorageOptions as TJvAppXMLStorageOptions).FStorage := Self;
  FXml := TJvSimpleXml.Create(nil);
  FXml.Options := [sxoAutoIndent];
  // (rom) should probably be a resourcestring
  RootNodeName := 'Configuration';
end;

destructor TJvCustomAppXMLStorage.Destroy;
begin
  inherited Destroy;
  // delete after the inherited call, see comment in
  // the base class, TJvCustomMemoryFileAppStorage
  FXml.Free;
end;

class function TJvCustomAppXMLStorage.GetStorageOptionsClass: TJvAppStorageOptionsClass;
begin
  Result := TJvAppXMLStorageOptions;
end;

function TJvCustomAppXMLStorage.EnsureNoWhiteSpaceInNodeName(NodeName: string): string;
var
  J, K: Integer;
  WSRLength: Integer;
  InsertIndex: Integer;
  WhiteSpaceCount: Integer;
  FixedNodeName: string;
  WhiteSpaceReplacement: string;
begin
  WhiteSpaceReplacement := TJvAppXMLStorageOptions(StorageOptions).WhiteSpaceReplacement;
  if StrContainsChars(NodeName, AnsiWhiteSpace, False) then
  begin
    WSRLength := Length(WhiteSpaceReplacement);
    case WSRLength of
      0:
        raise EJVCLException.CreateRes(@RsENodeNameCannotContainSpaces);
      1:
        NodeName := StrReplaceChars(NodeName, AnsiWhiteSpace, WhiteSpaceReplacement[1]);
      else
        begin
          WhiteSpaceCount := StrCharsCount(NodeName, AnsiWhiteSpace);
          SetLength(FixedNodeName, Length(NodeName) + WhiteSpaceCount*(WSRLength - 1));
          InsertIndex := 1;
          for J := 1 to Length(NodeName) do
          begin
            if NodeName[J] in AnsiWhiteSpace then
            begin
              // if we have a white space then we replace it with the WSR string
              for K := 1 to WSRLength do
              begin
                FixedNodeName[InsertIndex] := WhiteSpaceReplacement[K];
                Inc(InsertIndex);
              end;
            end
            else
            begin
              // else we simply copy the character
              FixedNodeName[InsertIndex] := NodeName[J];
              Inc(InsertIndex);
            end;
          end;
          NodeName := FixedNodeName;
        end;
    end;
  end;
  Result := NodeName;
end;

procedure TJvCustomAppXMLStorage.SetRootNodeName(const Value: string);
begin
  if Value = '' then
    raise EPropertyError.CreateRes(@RsENodeCannotBeEmpty)
  else
  begin
    Xml.Root.Name := EnsureNoWhiteSpaceInNodeName(Value);
    Root := Value;
  end;
end;

procedure TJvCustomAppXMLStorage.SplitKeyPath(const Path: string; out Key, ValueName: string);
begin
  inherited SplitKeyPath(Path, Key, ValueName);
  ValueName := EnsureNoWhiteSpaceInNodeName(ValueName);
  if Key = '' then
    Key := Path;
end;

function TJvCustomAppXMLStorage.ValueStoredInt(const Path: string): Boolean;
var
  Section: string;
  Key: string;
  Node: TJvSimpleXmlElem;
begin
  ReloadIfNeeded;
  SplitKeyPath(Path, Section, Key);
  Result := False;
  Node := GetNodeFromPath(Section);
  if Assigned(Node) then
    Result := Assigned(Node.Items.ItemNamed[Key]);
end;

procedure TJvCustomAppXMLStorage.DeleteValueInt(const Path: string);
var
  Node: TJvSimpleXmlElem;
  Section: string;
  Key: string;
begin
  if ValueStored(Path) then
  begin
    ReloadIfNeeded;
    SplitKeyPath(Path, Section, Key);
    Node := GetNodeFromPath(Section);
    if Assigned(Node) then
      Node.Items.Delete(Key);
    FlushIfNeeded;
  end;
end;

procedure TJvCustomAppXMLStorage.DeleteSubTreeInt(const Path: string);
var
  TopNode: string;
  Node: TJvSimpleXmlElem;
  Parent: TJvSimpleXmlElem;
  Name: string;
begin
  ReloadIfNeeded;
  TopNode := GetAbsPath(Path);
  if TopNode = '' then
    TopNode := Path;
  Node := GetNodeFromPath(TopNode);
  if Assigned(Node) then
  begin
    Name := Node.Name;
    Parent := Node.Parent;
    if Assigned(Parent) then
      Parent.Items.Delete(Name)
    else
      Node.Clear;
    FlushIfNeeded;
  end;
end;

function TJvCustomAppXMLStorage.DoReadInteger(const Path: string; Default: Integer): Integer;
var
  ParentPath: string;
  ValueName: string;
  Node: TJvSimpleXmlElem;
begin
  ReloadIfNeeded;
  SplitKeyPath(Path, ParentPath, ValueName);

  Node := GetNodeFromPath(ParentPath);

  if Assigned(Node) and Assigned(Node.Items.ItemNamed[ValueName]) then
  begin
    try
      Result := Node.Items.ItemNamed[ValueName].IntValue;
    except
      if StorageOptions.DefaultIfReadConvertError then
        Result := Default
      else
        raise;
    end;
  end
  else
  if StorageOptions.DefaultIfValueNotExists then
    Result := Default
  else
    raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [Path]);
end;

procedure TJvCustomAppXMLStorage.DoWriteInteger(const Path: string; Value: Integer);
var
  ParentPath: string;
  ValueName: string;
  ANode: TJvSimpleXmlElem;
begin
  ReloadIfNeeded;
  SplitKeyPath(Path, ParentPath, ValueName);
  ANode := CreateAndSetNode(ParentPath);
  Xml.Options := Xml.Options + [sxoAutoCreate];
  ANode.Items.ItemNamed[ValueName].IntValue := Value;
  Xml.Options := Xml.Options - [sxoAutoCreate];
  FlushIfNeeded;
end;

function TJvCustomAppXMLStorage.DoReadFloat(const Path: string; Default: Extended): Extended;
var
  ParentPath: string;
  ValueName: string;
  StrValue: string;
  Node: TJvSimpleXmlElem;
begin
  ReloadIfNeeded;
  SplitKeyPath(Path, ParentPath, ValueName);

  Node := GetNodeFromPath(ParentPath);

  if Assigned(Node) and Assigned(Node.Items.ItemNamed[ValueName]) then
  begin
    try