started propertystorage enable with -dEnableSessionProps

git-svn-id: trunk@5699 -

.gitattributes

@@ -1146,6 +1146,7 @@ lcl/include/treeview.inc svneol=native#text/pascal
 lcl/include/winapi.inc svneol=native#text/pascal
 lcl/include/winapih.inc svneol=native#text/pascal
 lcl/include/wincontrol.inc svneol=native#text/pascal
+lcl/inipropstorage.pas svneol=native#text/pascal
 lcl/interfacebase.pp svneol=native#text/pascal
 lcl/interfaces/gnome/gnomeint.pp svneol=native#text/pascal
 lcl/interfaces/gnome/gnomelclintf.inc svneol=native#text/pascal
@@ -1374,6 +1375,7 @@ lcl/nonwin32/messages.pp svneol=native#text/pascal
 lcl/pairsplitter.pas svneol=native#text/pascal
 lcl/postscriptprinter.pas svneol=native#text/pascal
 lcl/printers.pas svneol=native#text/pascal
+lcl/propertystorage.pas svneol=native#text/pascal
 lcl/spin.pp svneol=native#text/pascal
 lcl/stdactns.pas svneol=native#text/pascal
 lcl/stdctrls.pp svneol=native#text/pascal
@@ -1411,6 +1413,7 @@ lcl/widgetset/wsproc.pp svneol=native#text/pascal
 lcl/widgetset/wsspin.pp svneol=native#text/pascal
 lcl/widgetset/wsstdctrls.pp svneol=native#text/pascal
 lcl/widgetset/wstoolwin.pp svneol=native#text/pascal
+lcl/xmlpropstorage.pas svneol=native#text/pascal
 /localize.sh -text svneol=native#application/x-sh
 packager/addfiletoapackagedlg.pas svneol=native#text/pascal
 packager/addtopackagedlg.pas svneol=native#text/pascal

lcl/alllclunits.pp

@@ -37,13 +37,18 @@ uses
   // base types and base functions
   LCLProc, LCLType, GraphMath, VCLGlobals, FileCtrl, LMessages,
   // the interface base
-  InterfaceBase, {$IFNDEF DisableFPImage}IntfGraphics,{$ENDIF}
+  InterfaceBase,
+  {$IFNDEF DisableFPImage}IntfGraphics,{$ENDIF}
   // components and functions
   StdActns, Buttons, Extctrls, Calendar, Clipbrd, Forms, LCLIntf, Spin,
   Comctrls, Graphics, StdCtrls, Arrow, Controls, ImgList, Menus, Toolwin,
   Dialogs, Messages, Clistbox, ActnList, Grids, MaskEdit,
   Printers, PostScriptPrinter, CheckLst, PairSplitter, ExtDlgs,
   DBCtrls, DBGrids, EditBtn, ExtGraphics,
+  {$IFDEF EnableSessionProps}
+  // Remember: add units to Makefile.fpc when they became default
+  PropertyStorage, IniPropStorage, XMLPropStorage,
+  {$ENDIF}
   // widgetset skeleton
   WSActnList, WSArrow, WSButtons, WSCalendar,
   WSCheckLst, WSCListBox, WSComCtrls, WSControls,
@@ -61,6 +66,9 @@ end.
 { =============================================================================
 
   $Log$
+  Revision 1.15  2004/07/23 22:06:56  mattias
+  started propertystorage enable with -dEnableSessionProps
+
   Revision 1.14  2004/05/16 23:24:41  marc
   + Added WSBitBtn interface
   + Implemented WSBitBtn interface for gtk

lcl/forms.pp

@@ -953,7 +953,7 @@ type
     procedure ValidateRename(AComponent: TComponent;
       const CurName, NewName: string); virtual; abstract;
     function GetShiftState: TShiftState; virtual; abstract;
-    Procedure SelectOnlyThisComponent(AComponent:TComponent); virtual; abstract;
+    Procedure SelectOnlyThisComponent(AComponent: TComponent); virtual; abstract;
     function UniqueName(const BaseName: string): string; virtual; abstract;
   end;
 

lcl/inipropstorage.pas

@@ -0,0 +1,280 @@
+{  $Id$  }
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+unit IniPropStorage;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, IniFiles, PropertyStorage;
+
+Type
+  TIniFileClass = Class of TCustomIniFile;
+  
+  TIniPropStorage = Class(TCustomPropertyStorage)
+  private
+    FCount : Integer;
+    FReadOnly : Boolean;
+    FIniFile: TCustomIniFile;
+    FIniFileName: String;
+    FIniSection: String;
+  Protected
+    Function IniFileClass : TIniFileClass; virtual;
+    procedure StorageNeeded(ReadOnly: Boolean);override;
+    procedure FreeStorage; override;
+    Function GetIniFileName : string; virtual;
+    Function RootSection : String; Override;
+    Property IniFile : TCustomIniFile Read FIniFile;
+  Public
+    function  DoReadString(const Section, Ident, Default: string): string; override;
+    procedure DoWriteString(const Section, Ident, Value: string); override;
+    Procedure DoEraseSections(const ARootSection : String);override;
+  Published
+    Property IniFileName : String Read FIniFileName Write FIniFileName;
+    Property IniSection : String Read FIniSection Write FIniSection;
+  end;
+
+Procedure Register;
+
+
+implementation
+
+
+Procedure Register;
+begin
+  RegisterComponents('Misc',[TIniPropStorage]);
+end;
+
+{ Should move to strutils when 1.9.6 is out. }
+
+function FindPart(const HelpWilds, InputStr: string): Integer;
+
+var
+  I, J: Integer;
+  Diff: Integer;
+
+begin
+  I := Pos('?', HelpWilds);
+  if I = 0 then begin
+    { if no '?' in HelpWilds }
+    Result := Pos(HelpWilds, InputStr);
+    Exit;
+  end;
+  { '?' in HelpWilds }
+  Diff := Length(InputStr) - Length(HelpWilds);
+  if Diff < 0 then begin
+    Result := 0;
+    Exit;
+  end;
+  { now move HelpWilds over InputStr }
+  for I := 0 to Diff do begin
+    for J := 1 to Length(HelpWilds) do begin
+      if (InputStr[I + J] = HelpWilds[J]) or
+        (HelpWilds[J] = '?') then
+      begin
+        if J = Length(HelpWilds) then begin
+          Result := I + 1;
+          Exit;
+        end;
+      end
+      else Break;
+    end;
+  end;
+  Result := 0;
+end;
+
+
+
+function IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean;
+
+ function SearchNext(var Wilds: string): Integer;
+ { looking for next *, returns position and string until position }
+ begin
+   Result := Pos('*', Wilds);
+   if Result > 0 then Wilds := Copy(Wilds, 1, Result - 1);
+ end;
+
+var
+  CWild, CInputWord: Integer; { counter for positions }
+  I, LenHelpWilds: Integer;
+  MaxInputWord, MaxWilds: Integer; { Length of InputStr and Wilds }
+  HelpWilds: string;
+begin
+  if Wilds = InputStr then begin
+    Result := True;
+    Exit;
+  end;
+  repeat { delete '**', because '**' = '*' }
+    I := Pos('**', Wilds);
+    if I > 0 then
+      Wilds := Copy(Wilds, 1, I - 1) + '*' + Copy(Wilds, I + 2, MaxInt);
+  until I = 0;
+  if Wilds = '*' then begin { for fast end, if Wilds only '*' }
+    Result := True;
+    Exit;
+  end;
+  MaxInputWord := Length(InputStr);
+  MaxWilds := Length(Wilds);
+  if IgnoreCase then begin { upcase all letters }
+    InputStr := AnsiUpperCase(InputStr);
+    Wilds := AnsiUpperCase(Wilds);
+  end;
+  if (MaxWilds = 0) or (MaxInputWord = 0) then begin
+    Result := False;
+    Exit;
+  end;
+  CInputWord := 1;
+  CWild := 1;
+  Result := True;
+  repeat
+    if InputStr[CInputWord] = Wilds[CWild] then begin { equal letters }
+      { goto next letter }
+      Inc(CWild);
+      Inc(CInputWord);
+      Continue;
+    end;
+    if Wilds[CWild] = '?' then begin { equal to '?' }
+      { goto next letter }
+      Inc(CWild);
+      Inc(CInputWord);
+      Continue;
+    end;
+    if Wilds[CWild] = '*' then begin { handling of '*' }
+      HelpWilds := Copy(Wilds, CWild + 1, MaxWilds);
+      I := SearchNext(HelpWilds);
+      LenHelpWilds := Length(HelpWilds);
+      if I = 0 then begin
+        { no '*' in the rest, compare the ends }
+        if HelpWilds = '' then Exit; { '*' is the last letter }
+        { check the rest for equal Length and no '?' }
+        for I := 0 to LenHelpWilds - 1 do begin
+          if (HelpWilds[LenHelpWilds - I] <> InputStr[MaxInputWord - I]) and
+            (HelpWilds[LenHelpWilds - I]<> '?') then
+          begin
+            Result := False;
+            Exit;
+          end;
+        end;
+        Exit;
+      end;
+      { handle all to the next '*' }
+      Inc(CWild, 1 + LenHelpWilds);
+      I := FindPart(HelpWilds, Copy(InputStr, CInputWord, MaxInt));
+      if I= 0 then begin
+        Result := False;
+        Exit;
+      end;
+      CInputWord := I + LenHelpWilds;
+      Continue;
+    end;
+    Result := False;
+    Exit;
+  until (CInputWord > MaxInputWord) or (CWild > MaxWilds);
+  { no completed evaluation }
+  if CInputWord <= MaxInputWord then Result := False;
+  if (CWild <= MaxWilds) and (Wilds[MaxWilds] <> '*') then Result := False;
+end;
+
+
+
+{ TIniPropStorage }
+
+function TIniPropStorage.IniFileClass: TIniFileClass;
+begin
+  Result:=TIniFile;
+end;
+
+procedure TIniPropStorage.StorageNeeded(ReadOnly: Boolean);
+begin
+  If (FIniFile=Nil) or (ReadOnly<>FReadOnly) then
+    begin
+    If (FiniFile<>Nil) then
+      begin
+      // Force free.
+      FCount:=0;
+      FreeStorage;
+      end;
+    FReadOnly:=ReadOnly;
+    FInifile:=IniFileClass.Create(GetIniFileName);
+    end;
+  Inc(FCount);
+end;
+
+procedure TIniPropStorage.FreeStorage;
+begin
+  Dec(FCount);
+  If FCount<=0 then
+    begin
+    FCount:=0;
+    FreeAndNil(FIniFile);
+    end;
+end;
+
+function TIniPropStorage.GetIniFileName: string;
+begin
+  If (FIniFileName<>'') then
+    Result:=FIniFileName
+  else
+{$ifdef unix}
+    Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME'))
+            +'.'+ExtractFileName(Application.ExeName);
+
+{$else}
+    Result:=ChangeFileExt(Application.ExeName,'.ini');
+{$endif}
+end;
+
+function TIniPropStorage.RootSection: String;
+begin
+  if (FIniSection='') then
+    Result:=inherited RootSection
+  else
+    Result:=FIniSection;
+end;
+
+function TIniPropStorage.DoReadString(const Section, Ident, Default: string): string;
+begin
+  Result:=FIniFile.ReadString(Section, Ident, Default);
+end;
+
+procedure TIniPropStorage.DoWriteString(const Section, Ident, Value: string);
+begin
+  FIniFile.WriteString(Section, Ident, Value);
+end;
+
+procedure TIniPropStorage.DoEraseSections(const ARootSection: String);
+
+var
+  Lines: TStrings;
+  I: Integer;
+begin
+  Lines := TStringList.Create;
+  try
+    FInifile.ReadSections(Lines);
+    for I := 0 to Lines.Count - 1 do begin
+      if (Lines[I] = IniSection) or
+        (IsWild(Lines[I], IniSection + '.*', False) or
+        IsWild(Lines[I], IniSection + '\*', False)) then
+        FInifile.EraseSection(Lines[I]);
+    end;
+  finally
+    Lines.Free;
+  end;
+end;
+
+end.
+

lcl/propertystorage.pas

@@ -0,0 +1,722 @@
+{  $Id$  }
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+unit PropertyStorage;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, RTTIUtils;
+
+Type
+  TPlacementOperation = (poSave, poRestore);
+  TCustomPropertyStorage = Class;
+  TStoredValue = Class;
+  TStoredValues = Class;
+
+  { TStoredValue }
+
+{$ifdef storevariant}
+  TStoredType = Variant;
+{$else}
+  TStoredType = AnsiString;
+{$endif}
+
+  TStoredValueEvent = procedure(Sender: TStoredValue;
+                                var Value: TStoredType) of object;
+
+  TStoredValue = class(TCollectionItem)
+  private
+    FName: string;
+    FValue: TStoredType;
+    FKeyString: string;
+    FOnSave: TStoredValueEvent;
+    FOnRestore: TStoredValueEvent;
+    function IsValueStored: Boolean;
+    function GetStoredValues: TStoredValues;
+  protected
+    function GetDisplayName: string; override;
+    procedure SetDisplayName(const Value: string); override;
+  public
+    constructor Create(ACollection: TCollection); override;
+    procedure Assign(Source: TPersistent); override;
+    procedure Clear;
+    procedure Save; virtual;
+    procedure Restore; virtual;
+    property StoredValues: TStoredValues read GetStoredValues;
+  published
+    property Name: string read FName write SetDisplayName;
+    property Value: TStoredType read FValue write FValue stored IsValueStored;
+    property KeyString: string read FKeyString write FKeyString;
+    property OnSave: TStoredValueEvent read FOnSave write FOnSave;
+    property OnRestore: TStoredValueEvent read FOnRestore write FOnRestore;
+  end;
+
+
+  { TStoredValues }
+
+  TStoredValues = class(TOwnedCollection)
+  private
+    FStorage: TCustomPropertyStorage;
+    function GetValue(const AName: string): TStoredValue;
+    procedure SetValue(const AName: string; StoredValue: TStoredValue);
+    function GetStoredValue(const AName: string): TStoredType;
+    procedure SetStoredValue(const AName: string; Value: TStoredType);
+    function GetItem(Index: Integer): TStoredValue;
+    procedure SetItem(Index: Integer; StoredValue: TStoredValue);
+  public
+    constructor Create(AOwner: TPersistent);
+    function IndexOf(const AName: string): Integer;
+    procedure SaveValues; virtual;
+    procedure RestoreValues; virtual;
+    property Storage: TCustomPropertyStorage read FStorage write FStorage;
+    property Items[Index: Integer]: TStoredValue read GetItem write SetItem; default;
+    property Values[const Name: string]: TStoredValue read GetValue write SetValue;
+    property StoredValue[const Name: string]: TStoredType read GetStoredValue write SetStoredValue;
+  end;
+
+
+  { TCustomPropertyStorage }
+
+  TPropertyStorageLink = class(TPersistent)
+  private
+    FStorage: TCustomPropertyStorage;
+    FOnSave: TNotifyEvent;
+    FOnLoad: TNotifyEvent;
+    function GetRootSection: string;
+    procedure SetStorage(Value: TCustomPropertyStorage);
+  protected
+    procedure SaveProperties; virtual;
+    procedure LoadProperties; virtual;
+  public
+    destructor Destroy; override;
+    property Storage: TCustomPropertyStorage read FStorage write SetStorage;
+    property RootSection: string read GetRootSection;
+    property OnSave: TNotifyEvent read FOnSave write FOnSave;
+    property OnLoad: TNotifyEvent read FOnLoad write FOnLoad;
+  end;
+
+  TCustomPropertyStorage = Class (TComponent)
+  private
+    FStoredValues: TStoredValues;
+    FActive: Boolean;
+    FLinks: TList;
+    FSaved: Boolean;
+    FRestored: Boolean;
+    FOnSaveProperties: TNotifyEvent;
+    FOnRestoreProperties: TNotifyEvent;
+    procedure AddLink(ALink: TPropertyStorageLink);
+    procedure RemoveLink(ALink: TPropertyStorageLink);
+    procedure NotifyLinks(Operation: TPlacementOperation);
+    procedure SetStoredValues(Value: TStoredValues);
+    function  GetStoredValue(const AName: string): TStoredType;
+    procedure SetStoredValue(const AName: string; Value: TStoredType);
+  protected
+    function GetRoot: TPersistent; virtual;
+    procedure StorageNeeded(ReadOnly: Boolean);Virtual;
+    procedure FreeStorage; Virtual;
+    Function  RootSection : String; Virtual;
+    procedure SaveProperties; virtual;
+    procedure RestoreProperties; virtual;
+    Procedure GetPropertyList(List : TStrings); virtual;
+    function  DoReadInteger(const Section, Ident : String; Default: Integer): Integer; Virtual;
+    function  DoReadString(const Section, Ident, Default: string): string; Virtual; Abstract;
+    procedure DoWriteString(const Section, Ident, Value: string); Virtual; Abstract;
+    procedure DoWriteInteger(const Section, Ident : String; Value: Integer); Virtual;
+    Procedure DoEraseSections(const ARootSection : String);virtual;abstract;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Save; virtual;
+    procedure Restore; virtual;
+    // Public Read/Write methods
+    Function  ReadString(const Ident, Default: string): string;
+    Function  ReadInteger(const Ident: string; Default: Longint): Longint;
+    procedure WriteString(const Ident, Value: string);
+    procedure WriteInteger(const Ident: string; Value: Longint);
+    procedure EraseSections;
+  public
+    property StoredValue[const AName: string]: TStoredType read GetStoredValue write SetStoredValue;
+    property  Root: TPersistent read GetRoot;
+  published
+    property Active: Boolean read FActive write FActive default True;
+    property StoredValues: TStoredValues read FStoredValues write SetStoredValues;
+    property OnSaveProperties : TNotifyEvent read FOnSaveProperties write FOnSaveProperties;
+    property OnRestoreProperties : TNotifyEvent read FOnRestoreProperties  write FOnRestoreProperties;
+  end;
+  
+type
+  TGetStorageProperties = procedure(APersistent: TPersistent; List: TStrings);
+
+var
+  GetStorageProperties: TGetStorageProperties;
+
+implementation
+
+
+ResourceString
+  SDuplicateString = 'Duplicate strings are not allowed';
+  
+function XorEncode(const Key, Source: string): string;
+var
+  I: Integer;
+  C: Byte;
+begin
+  Result := '';
+  for I := 1 to Length(Source) do begin
+    if Length(Key) > 0 then
+      C := Byte(Key[1 + ((I - 1) mod Length(Key))]) xor Byte(Source[I])
+    else
+      C := Byte(Source[I]);
+    Result := Result + AnsiLowerCase(IntToHex(C, 2));
+  end;
+end;
+
+function XorDecode(const Key, Source: string): string;
+var
+  I: Integer;
+  C: Char;
+
+begin
+  Result := '';
+  for I := 0 to Length(Source) div 2 - 1 do begin
+    C := Chr(StrToIntDef('$' + Copy(Source, (I * 2) + 1, 2), Ord(' ')));
+    if Length(Key) > 0 then
+      C := Chr(Byte(Key[1 + (I mod Length(Key))]) xor Byte(C));
+    Result := Result + C;
+  end;
+end;
+
+
+{ TPropertyStorageLink }
+
+destructor TPropertyStorageLink.Destroy;
+begin
+  FOnSave := nil;
+  FOnLoad := nil;
+  SetStorage(nil);
+  inherited Destroy;
+end;
+
+function TPropertyStorageLink.GetRootSection: string;
+begin
+  if Assigned(FStorage) then
+    Result:=FStorage.RootSection
+  else
+    Result:='';
+  if Result<>'' then
+    Result:=Result+'\';
+end;
+
+procedure TPropertyStorageLink.SetStorage(Value: TCustomPropertyStorage);
+begin
+  if FStorage <> Value then
+    begin
+    if FStorage <> nil then
+      FStorage.RemoveLink(Self);
+    if Value <> nil then
+      Value.AddLink(Self);
+    end;
+end;
+
+procedure TPropertyStorageLink.SaveProperties;
+begin
+  if Assigned(FOnSave) then
+    FOnSave(Self);
+end;
+
+procedure TPropertyStorageLink.LoadProperties;
+begin
+  if Assigned(FOnLoad) then
+    FOnLoad(Self);
+end;
+
+{ TStoredValue }
+
+constructor TStoredValue.Create(ACollection: TCollection);
+begin
+  inherited Create(ACollection);
+{$ifdef storevariant}
+  FValue := Unassigned;
+{$else}
+  FValue:='';
+{$endif}
+end;
+
+procedure TStoredValue.Assign(Source: TPersistent);
+begin
+  if (Source is TStoredValue) and (Source <> nil) then
+    begin
+{$ifdef storevariant}
+    if VarIsEmpty(TStoredValue(Source).FValue) then
+      Clear
+    else
+{$endif}
+      Value := TStoredValue(Source).FValue;
+    Name := TStoredValue(Source).Name;
+    KeyString := TStoredValue(Source).KeyString;
+    end;
+end;
+
+function TStoredValue.GetDisplayName: string;
+begin
+  if FName = '' then
+    Result := inherited GetDisplayName
+  else
+    Result := FName;
+end;
+
+procedure TStoredValue.SetDisplayName(const Value: string);
+begin
+  if (Value <> '') and (AnsiCompareText(Value, FName) <> 0)
+  and (Collection is TStoredValues)
+  and (TStoredValues(Collection).IndexOf(Value) >= 0) then
+    raise Exception.Create(SDuplicateString);
+  FName := Value;
+  inherited;
+end;
+
+function TStoredValue.GetStoredValues: TStoredValues;
+begin
+  if Collection is TStoredValues then
+    Result := TStoredValues(Collection)
+  else
+    Result := nil;
+end;
+
+procedure TStoredValue.Clear;
+begin
+{$ifdef storevariant}
+  FValue := Unassigned;
+{$else}
+  FValue := '';
+{$endif}
+end;
+
+function TStoredValue.IsValueStored: Boolean;
+begin
+{$ifdef storevariant}
+  Result := not VarIsEmpty(FValue);
+{$else}
+  Result := (FValue<>'');
+{$endif}
+end;
+
+procedure TStoredValue.Save;
+var
+  SaveValue: TStoredType;
+  SaveStrValue: string;
+begin
+  SaveValue := Value;
+  if Assigned(FOnSave) then
+    FOnSave(Self, SaveValue);
+{$ifdef storevariant}
+  SaveStrValue := VarToStr(SaveValue);
+{$else}
+  SaveStrValue := SaveValue;
+{$endif}
+  if KeyString <> '' then
+    SaveStrValue := XorEncode(KeyString, SaveStrValue);
+  StoredValues.Storage.WriteString(Name, SaveStrValue);
+end;
+
+procedure TStoredValue.Restore;
+var
+  RestoreValue: TStoredType;
+  RestoreStrValue, DefaultStrValue: string;
+begin
+{$ifdef storevariant}
+  DefaultStrValue := VarToStr(Value);
+{$else}
+  DefaultStrValue := Value;
+{$endif}
+  if KeyString <> '' then
+    DefaultStrValue := XorEncode(KeyString, DefaultStrValue);
+  RestoreStrValue := StoredValues.Storage.ReadString(Name, DefaultStrValue);
+  if KeyString <> '' then
+    RestoreStrValue := XorDecode(KeyString, RestoreStrValue);
+  RestoreValue := RestoreStrValue;
+  if Assigned(FOnRestore) then
+    FOnRestore(Self, RestoreValue);
+  Value := RestoreValue;
+end;
+
+{ TStoredValues }
+
+constructor TStoredValues.Create(AOwner: TPersistent);
+begin
+  inherited Create(AOwner, TStoredValue);
+end;
+
+function TStoredValues.IndexOf(const AName: string): Integer;
+begin
+  for Result := 0 to Count - 1 do
+    if AnsiCompareText(Items[Result].Name, AName) = 0 then Exit;
+  Result := -1;
+end;
+
+function TStoredValues.GetItem(Index: Integer): TStoredValue;
+begin
+  Result := TStoredValue(inherited Items[Index]);
+end;
+
+procedure TStoredValues.SetItem(Index: Integer; StoredValue: TStoredValue);
+begin
+  inherited SetItem(Index, TCollectionItem(StoredValue));
+end;
+
+function TStoredValues.GetStoredValue(const AName: string): TStoredType;
+var
+  AStoredValue: TStoredValue;
+begin
+  AStoredValue := GetValue(AName);
+  if AStoredValue = nil then
+{$ifdef storevariant}
+    Result := Null
+{$else}
+    Result := ''
+{$endif}
+  else
+    Result := AStoredValue.Value;
+end;
+
+procedure TStoredValues.SetStoredValue(const AName: string; Value: TStoredType);
+var
+  AStoredValue: TStoredValue;
+begin
+  AStoredValue := GetValue(AName);
+  if AStoredValue = nil then begin
+    AStoredValue := TStoredValue(Add);
+    AStoredValue.Name := AName;
+    AStoredValue.Value := Value;
+  end
+  else AStoredValue.Value := Value;
+end;
+
+function TStoredValues.GetValue(const AName: string): TStoredValue;
+var
+  I: Integer;
+begin
+  I := IndexOf(AName);
+  if I < 0 then
+    Result := nil
+  else
+    Result := Items[I];
+end;
+
+procedure TStoredValues.SetValue(const AName: string; StoredValue: TStoredValue);
+var
+  I: Integer;
+begin
+  I := IndexOf(AName);
+  if I >= 0 then
+    Items[I].Assign(StoredValue);
+end;
+
+procedure TStoredValues.SaveValues;
+var
+  I: Integer;
+begin
+  for I := 0 to Count - 1 do
+    Items[I].Save;
+end;
+
+procedure TStoredValues.RestoreValues;
+var
+  I: Integer;
+begin
+  for I := 0 to Count - 1 do
+    Items[I].Restore;
+end;
+
+{ TCustomPropertyStorage }
+
+constructor TCustomPropertyStorage.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FActive := True;
+  FLinks := TList.Create;
+end;
+
+destructor TCustomPropertyStorage.Destroy;
+begin
+  FreeStorage;
+  while FLinks.Count > 0 do
+    RemoveLink(TPropertyStorageLink(FLinks.Last));
+  FreeAndNil(FLinks);
+  inherited Destroy;
+end;
+
+procedure TCustomPropertyStorage.AddLink(ALink: TPropertyStorageLink);
+begin
+  FLinks.Add(ALink);
+  ALink.FStorage := Self;
+end;
+
+procedure TCustomPropertyStorage.NotifyLinks(Operation: TPlacementOperation);
+var
+  I: Integer;
+begin
+  for I := 0 to FLinks.Count - 1 do
+    with TPropertyStorageLink(FLinks[I]) do
+      case Operation of
+        poSave: SaveProperties;
+        poRestore: LoadProperties;
+      end;
+end;
+
+procedure TCustomPropertyStorage.RemoveLink(ALink: TPropertyStorageLink);
+begin
+  ALink.FStorage := nil;
+  FLinks.Remove(ALink);
+end;
+
+function TCustomPropertyStorage.GetRoot: TPersistent;
+begin
+  Result:=Owner;
+end;
+
+function TCustomPropertyStorage.RootSection : string;
+
+var
+  ARoot: TPersistent;
+  Prepend: String;
+  
+begin
+  Result:='';
+  ARoot:=Root;
+  while ARoot<>nil do begin
+    if (ARoot is TComponent) and (TComponent(ARoot).Name<>'') then
+      Prepend:=TComponent(ARoot).Name
+    else begin
+      Prepend:=ARoot.ClassName;
+      ARoot:=nil;
+    end;
+    if Result<>'' then
+      Result:=Prepend+'.'+Result
+    else
+      Result:=Prepend;
+    if not (ARoot is TComponent) then break;
+    ARoot:=TComponent(ARoot).Owner;
+  end;
+end;
+
+
+procedure TCustomPropertyStorage.Save;
+begin
+  if FRestored or not Active then
+    begin
+    StorageNeeded(False);
+    Try
+      SaveProperties;
+      NotifyLinks(poSave);
+      if Assigned(FOnSaveProperties) then
+        FOnSaveProperties(Self);
+      FSaved := True;
+    Finally
+      FreeStorage;
+    end;
+    end;
+end;
+
+procedure TCustomPropertyStorage.Restore;
+begin
+  if Active then begin
+    FSaved := False;
+    StorageNeeded(True);
+    RestoreProperties;
+    NotifyLinks(poRestore);
+    FRestored:=True;
+    if Assigned(FOnRestoreProperties) then
+      FOnRestoreProperties(Self);
+  end;
+end;
+
+procedure TCustomPropertyStorage.GetPropertyList(List : TStrings);
+
+  procedure AddProperties(const Path: string; P: TPersistent);
+  var
+    OldListCount: LongInt;
+    i: LongInt;
+  begin
+    OldListCount:=List.Count;
+    GetStorageProperties(P,List);
+    for i:=OldListCount to List.Count-1 do
+      List[i]:=Path+List[i];
+  end;
+
+Var
+  O : TPersistent;
+  C : TComponent;
+  I : Integer;
+begin
+  O:=Root;
+  if (O=nil) or (List=nil) or (GetStorageProperties=nil) then exit;
+  AddProperties('',O);
+  if O is TComponent then begin
+    C:=TComponent(O);
+    For i:=0 to C.ComponentCount-1 do
+      AddProperties(C.Name+':',C.Components[i]);
+  end;
+end;
+
+procedure TCustomPropertyStorage.SaveProperties;
+
+Var
+  L : TStringList;
+  
+begin
+  L:=TstringList.Create;
+  Try
+    L.Sorted:=True;
+    GetPropertyList(L);
+    StorageNeeded(False);
+    Try
+      with TPropsStorage.Create do
+        try
+          Section := RootSection;
+          OnWriteString := @DoWriteString;
+          try
+            StoreObjectsProps(Owner,L);
+          except
+            { ignore any exceptions }
+          end;
+        finally
+          Free;
+        end;
+    Finally
+      FreeStorage;
+    end;
+  finally
+    L.Free;
+  end;
+end;
+
+procedure TCustomPropertyStorage.RestoreProperties;
+
+Var
+  L : TStringList;
+
+begin
+  L:=TstringList.Create;
+  Try
+    L.Sorted:=True;
+    GetPropertyList(L);
+    StorageNeeded(True);
+    Try
+      with TPropsStorage.Create do
+        try
+          Section := RootSection;
+          OnReadString := @DoReadString;
+          try
+            LoadObjectsProps(Owner,L);
+          except
+            { ignore any exceptions }
+          end;
+        finally
+          Free;
+        end;
+    Finally
+      FreeStorage;
+    end;
+  finally
+    L.Free;
+  end;
+end;
+
+function TCustomPropertyStorage.DoReadInteger(const Section, Ident: String;
+  Default: Integer): Integer;
+begin
+  Result:=StrToIntDef(DoReadString(Section,Ident,IntToStr(Default)),Default);
+end;
+
+procedure TCustomPropertyStorage.DoWriteInteger(const Section, Ident: String;
+  Value: Integer);
+begin
+  DoWriteString(Section,Ident,IntToStr(Value))
+end;
+
+procedure TCustomPropertyStorage.StorageNeeded(ReadOnly: Boolean);
+begin
+end;
+
+procedure TCustomPropertyStorage.FreeStorage;
+begin
+end;
+
+function TCustomPropertyStorage.ReadString(const Ident, Default: string): string;
+begin
+  Result := DoReadString(RootSection, Ident, Default);
+end;
+
+procedure TCustomPropertyStorage.WriteString(const Ident, Value: string);
+begin
+  DoWriteString(RootSection, Ident, Value);
+end;
+
+function TCustomPropertyStorage.ReadInteger(const Ident: string; Default: Longint): Longint;
+begin
+  StorageNeeded(True);
+  try
+    Result := DoReadInteger(RootSection, Ident, Default);
+  finally
+    FreeStorage;
+  end;
+end;
+
+procedure TCustomPropertyStorage.WriteInteger(const Ident: string; Value: Longint);
+begin
+  StorageNeeded(False);
+  try
+    DoReadInteger(RootSection, Ident, Value);
+  finally
+    FreeStorage;
+  end;
+end;
+
+
+procedure TCustomPropertyStorage.EraseSections;
+
+begin
+  StorageNeeded(False);
+  try
+    DoEraseSections(RootSection);
+  finally
+    FreeStorage;
+  end;
+end;
+
+procedure TCustomPropertyStorage.SetStoredValues(Value: TStoredValues);
+begin
+  FStoredValues.Assign(Value);
+end;
+
+function TCustomPropertyStorage.GetStoredValue(const AName: string): TStoredType;
+begin
+  Result := StoredValues.StoredValue[AName];
+end;
+
+procedure TCustomPropertyStorage.SetStoredValue(const AName: string; Value: TStoredType);
+begin
+  StoredValues.StoredValue[AName] := Value;
+end;
+
+
+initialization
+  GetStorageProperties:=nil;
+end.
+

lcl/xmlpropstorage.pas

@@ -0,0 +1,155 @@
+{  $Id$  }
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+unit XMLPropStorage;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, PropertyStorage, XMLCfg, DOM;
+
+type
+  { TXMLPropStorage }
+
+  TPropStorageXMLConfig = class(TXMLConfig)
+  Public
+    Procedure DeleteSubNodes (const ARootNode : String);
+  end;
+  
+  TXMLPropStorage = class(TCustomPropertyStorage)
+  private
+    FCount : Integer;
+    FFileName: String;
+    FXML: TPropStorageXMLConfig;
+    FRootNode: String;
+    FRootNodePath: String;
+  protected
+    procedure StorageNeeded(ReadOnly: Boolean);override;
+    procedure FreeStorage; override;
+    Function GetXMLFileName : string; virtual;
+    Function RootSection : String; Override;
+    Function FixPath(const APath : String) : String; virtual;
+    Property XMLConfig: TPropStorageXMLConfig Read FXML;
+  Public
+    function  DoReadString(const Section, Ident, Default: string): string; override;
+    procedure DoWriteString(const Section, Ident, Value: string); override;
+    Procedure DoEraseSections(const ARootSection: String);override;
+  Published
+    Property FileName : String Read FFileName Write FFileName;
+    Property RootNodePath : String Read FRootNode Write FRootNodePath;
+  end;
+
+procedure Register;
+
+
+implementation
+
+
+procedure Register;
+begin
+  RegisterComponents('Misc',[TXMLPropStorage]);
+end;
+
+{ TXMLPropStorage }
+
+procedure TXMLPropStorage.StorageNeeded(ReadOnly: Boolean);
+begin
+  If (FXML=Nil) then
+    FXML:=TPropStorageXMLConfig.Create(GetXMLFileName);
+  Inc(FCount);
+end;
+
+procedure TXMLPropStorage.FreeStorage;
+begin
+  Dec(FCount);
+  If (FCount<=0) then
+    begin
+    FCount:=0;
+    FreeAndNil(FXML);
+    end;
+end;
+
+function TXMLPropStorage.GetXMLFileName: string;
+begin
+  if (FFileName<>'') then
+    Result:=FFIleName
+  else
+{$ifdef unix}
+    Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME'))
+            +'.'+ExtractFileName(Application.ExeName);
+
+{$else}
+    Result:=ChangeFileExt(Application.ExeName,'.xml');
+{$endif}
+end;
+
+function TXMLPropStorage.FixPath(const APath : String) : String;
+
+begin
+  Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
+end;
+
+function TXMLPropStorage.RootSection: String;
+begin
+  If (FRootNode<>'') then
+    Result:=FRootNode
+  else
+    Result:=inherited RootSection;
+  Result:=FixPath(Result);
+end;
+
+function TXMLPropStorage.DoReadString(const Section, Ident, Default: string
+  ): string;
+begin
+  Result:=FXML.GetValue(FixPath(Section)+'/'+Ident, Default);
+end;
+
+procedure TXMLPropStorage.DoWriteString(const Section, Ident, Value: string);
+begin
+  FXML.SetValue(FixPath(Section)+'/'+Ident, Value);
+end;
+
+procedure TXMLPropStorage.DoEraseSections(const ARootSection: String);
+begin
+  FXML.DeleteSubNodes(FixPath(ARootSection));
+end;
+
+{ TPropStorageXMLConfig }
+
+procedure TPropStorageXMLConfig.DeleteSubNodes(const ARootNode: String);
+
+var
+  Node, Child: TDOMNode;
+  i: Integer;
+  NodePath: String;
+begin
+  Node := doc.DocumentElement;
+  NodePath := ARootNode;
+  while (Length(NodePath)>0) and (Node<>Nil) do
+    begin
+    i := Pos('/', NodePath);
+    if i = 0 then
+      I:=Length(NodePath)+1;
+    Child := Node.FindNode(Copy(NodePath,1,i - 1));
+    System.Delete(NodePath,1,I);
+    Node := Child;
+    end;
+  If Assigned(Node) then
+    Node.Free;
+end;
+
+end.