paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-04 13:37:22 +01:00
Code Issues Packages Projects Releases Wiki Activity

added TXMLConfigStorage

Browse Source 
git-svn-id: trunk@9438 -
This commit is contained in:
mattias 2006-06-15 21:49:57 +00:00
parent c466173ab3
commit a681ab7b71
10 changed files with 454 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
components/custom/README
View File

@ -1,3 +1,6 @@
OBSOLETE - OBSOLETE - OBSOLETE - OBSOLETE - OBSOLETE - OBSOLETE - OBSOLETE
How to add extra components to the lazarus IDE
==============================================

3
components/custom/customidecomps.pas.template
View File

@ -20,7 +20,8 @@
Author: Mattias Gaertner
THIS IS OBSOLETE.
Use this unit to add components to the lazarus IDE.
For example:

2
examples/anchordocking/dockform1unit.lrs
View File

@ -1,3 +1,5 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TMainForm','FORMDATA',[
'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'$'#1#6'Height'#3','#1#3'Top'#3#209#0
+#5'Width'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3'+'

18
examples/anchordocking/dockform1unit.pas
View File

@ -6,7 +6,7 @@ interface
uses
Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics, Dialogs,
XMLCfg, DockForm2Unit, Buttons, Menus, LDockCtrl;
DockForm2Unit, Buttons, Menus, LDockCtrl, XMLPropStorage;
type
@ -42,8 +42,13 @@ begin
end;
procedure TMainForm.SaveLayoutButtonClick(Sender: TObject);
var
Config: TXMLConfigStorage;
begin
DockingManager.SaveToStream();
Config:=TXMLConfigStorage.Create('config.xml',false);
DockingManager.SaveToConfig(Config);
Config.WriteToDisk;
Config.Free;
end;
function TMainForm.CreateNewForm: TCustomForm;
@ -68,9 +73,17 @@ procedure TMainForm.FormCreate(Sender: TObject);
var
Form2: TCustomForm;
Form3: TCustomForm;
Config: TXMLConfigStorage;
begin
if Sender=nil then ;
DockingManager:=TLazDockingManager.Create(Self);
if FileExists('config.xml') then begin
Config:=TXMLConfigStorage.Create('config.xml',true);
DockingManager.LoadFromConfig(Config);
Config.Free;
end;
DockerForm1:=TLazControlDocker.Create(Self);
DockerForm1.Name:='DockerForm1';
DockerForm1.Manager:=DockingManager;
@ -84,7 +97,6 @@ begin
DockingManager.WriteDebugReport;
DockerForm1.GetLayoutFromControl;
DockerForm1.WriteConfigTreeDebugReport;
end;
procedure TMainForm.FormDestroy(Sender: TObject);

6
examples/anchordocking/docking1.lpi
View File

@ -20,10 +20,14 @@
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Unit0>

2
ide/componentpalette.pas
View File

@ -300,6 +300,8 @@ begin
end;
PopupMenu.Items.Add(OpenUnitMenuItem);
PopupMenu.Items.AddSeparator;
FindComponentMenuItem:=TMenuItem.Create(PopupMenu);
with FindComponentMenuItem do begin
Name:='FindComponentMenuItem';

60
lcl/grids.pas
View File

@ -488,10 +488,10 @@ type
ScrollHeight: Integer; // ClientHeight-FixedHeight
VisibleGrid: TRect; // Visible non fixed rectangle of cellcoordinates
MaxClientXY: Tpoint; // VisibleGrid.BottomRight (pixel) coordinates
ValidRows: boolean; // true if there are not fixed columns to show
ValidCols: boolean; // true if there are not fixed rows to show
ValidRows: boolean; // true if there are not fixed columns to show
ValidCols: boolean; // true if there are not fixed rows to show
ValidGrid: boolean; // true if there are not fixed cells to show
AccumWidth: TList; // Accumulated width per column
AccumWidth: TList; // Accumulated width per column
AccumHeight: TList; // Accumulated Height per row
TLColOff,TLRowOff: Integer; // TopLeft Offset in pixels
MaxTopLeft: TPoint; // Max Top left ( cell coorditates)
@ -676,7 +676,8 @@ type
procedure ColRowExchanged(IsColumn: Boolean; index,WithIndex: Integer); dynamic;
procedure ColRowInserted(IsColumn: boolean; index: integer); dynamic;
procedure ColRowMoved(IsColumn: Boolean; FromIndex,ToIndex: Integer); dynamic;
function ColRowToOffset(IsCol,Fisical:Boolean; index: Integer; var Ini,Fin:Integer): Boolean;
function ColRowToOffset(IsCol, Relative: Boolean; Index:Integer;
var StartPos, EndPos: Integer): Boolean;
function ColumnIndexFromGridColumn(Column: Integer): Integer;
function ColumnFromGridColumn(Column: Integer): TGridColumn;
procedure ColumnsChanged(aColumn: TGridColumn);
@ -2417,6 +2418,7 @@ var
RNew: TRect;
OldTopLeft:TPoint;
Xinc,YInc: Integer;
i: Integer;
begin
OldTopLeft:=fTopLeft;
@ -2428,15 +2430,19 @@ begin
RNew:=CellRect(aCol,aRow);
Xinc:=0;
if Rnew.Left + FGCache.TLColOff < FGCache.FixedWidth then Xinc:=-1
else if (RNew.Right + FGCache.TLColOff > (FGCache.ClientWidth + GetBorderWidth))
and (RNew.Left + FGCache.TLColOff - GetColWidths(aCol) >= FGCache.FixedWidth) then XInc:=1;
// Only scroll left if the left edge of the cell does not become invisible as a result
if RNew.Left + FGCache.TLColOff < FGCache.FixedWidth then Xinc:=-1
else if (RNew.Right+FGCache.TLColOff > (FGCache.ClientWidth+GetBorderWidth))
and (RNew.Left+FGCache.TLColOff-GetColWidths(aCol) >= FGCache.FixedWidth)
then XInc:=1;
// Only scroll left if the left edge of the cell does not become
// invisible as a result
Yinc:=0;
if RNew.Top + FGCache.TLRowOff < FGCache.FixedHeight then Yinc:=-1
else if (RNew.Bottom + FGCache.TLRowOff > (FGCache.ClientHeight + GetBorderWidth))
and (RNew.Top + FGCache.TLRowOff - GetRowHeights(aRow) >= FGCache.FixedHeight) then YInc:=1;
// Only scroll up if the top edge of the cell does not become invisible as a result
else if (RNew.Bottom+FGCache.TLRowOff > (FGCache.ClientHeight+GetBorderWidth))
and (RNew.Top+FGCache.TLRowOff-GetRowHeights(aRow) >= FGCache.FixedHeight)
then YInc:=1;
// Only scroll up if the top edge of the cell does not become
// invisible as a result
with FTopLeft do
if ((XInc=0)and(YInc=0)) or // the cell is already visible
@ -3849,35 +3855,37 @@ begin
result := True;
end;
// ex: IsCol=true, Index:=100, TopLeft.x:=98, FixedCols:=1, all ColWidths:=20
// Fisical = Relative => Ini := WidthfixedCols+WidthCol98+WidthCol99
// not Fisical = Absolute => Ini := WidthCols(0..99)
function TCustomGrid.ColRowToOffset(IsCol,Fisical:Boolean; index:Integer;
var Ini,Fin:Integer): Boolean;
{ ------------------------------------------------------------------------------
Example:
IsCol=true, Index:=100, TopLeft.x:=98, FixedCols:=1, all ColWidths:=20
Relative => StartPos := WidthfixedCols+WidthCol98+WidthCol99
not Relative = Absolute => StartPos := WidthCols(0..99) }
function TCustomGrid.ColRowToOffset(IsCol, Relative: Boolean; Index:Integer;
var StartPos, EndPos: Integer): Boolean;
var
Dim: Integer;
begin
with FGCache do begin
if IsCol then begin
Ini:=PtrInt(AccumWidth[index]);
StartPos:=PtrInt(AccumWidth[index]);
Dim:=GetColWidths(index);
end else begin
Ini:=PtrInt(AccumHeight[index]);
StartPos:=PtrInt(AccumHeight[index]);
Dim:= GetRowHeights(index);
end;
Ini := Ini + GetBorderWidth;
if not Fisical then begin
Fin:=Ini + Dim;
StartPos := StartPos + GetBorderWidth;
if not Relative then begin
EndPos:=StartPos + Dim;
Exit;
end;
if IsCol then begin
if index>=FFixedCols then
Ini:=Ini-PtrInt(AccumWidth[FTopLeft.X]) + FixedWidth - TLColOff;
StartPos:=StartPos-PtrInt(AccumWidth[FTopLeft.X]) + FixedWidth - TLColOff;
end else begin
if index>=FFixedRows then
Ini:=Ini-PtrInt(AccumHeight[FTopLeft.Y]) + FixedHeight - TLRowOff;
StartPos:=StartPos-PtrInt(AccumHeight[FTopLeft.Y]) + FixedHeight - TLRowOff;
end;
Fin:=Ini + Dim;
EndPos:=StartPos + Dim;
end;
Result:=true;
end;
@ -4142,8 +4150,8 @@ begin
R:=CellRect(FSplitter.x, FTopLeft.y);
FSplitter.y:=R.Left;
fGridState:= gsColSizing;
end else
if not FixedGrid then begin
end
else if not FixedGrid then begin
// normal selecting
fGridState:=gsSelecting;
FSplitter:=MouseToCell(Point(X,Y));

30
lcl/lazconfigstorage.pas
View File

@ -49,12 +49,16 @@ type
function GetValue(const APath, ADefault: String): String;
function GetValue(const APath: String; ADefault: Integer): Integer;
function GetValue(const APath: String; ADefault: Boolean): Boolean;
procedure GetValue(const APath: String; out ARect: TRect;
const ADefault: TRect);
procedure SetValue(const APath, AValue: String);
procedure SetDeleteValue(const APath, AValue, DefValue: String);
procedure SetValue(const APath: String; AValue: Integer);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer);
procedure SetValue(const APath: String; AValue: Boolean);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
procedure SetValue(const APath: String; const AValue: TRect);
procedure SetDeleteValue(const APath: String; const AValue, DefValue: TRect);
procedure DeletePath(const APath: string);
procedure DeleteValue(const APath: string);
property CurrentBasePath: string read FCurrentBasePath;
@ -100,6 +104,15 @@ begin
Result:=GetFullPathValue(ExtendPath(APath),ADefault);
end;
procedure TConfigStorage.GetValue(const APath: String; out ARect: TRect;
const ADefault: TRect);
begin
ARect.Left:=GetValue(APath+'Left',ADefault.Left);
ARect.Top:=GetValue(APath+'Top',ADefault.Top);
ARect.Right:=GetValue(APath+'Right',ADefault.Right);
ARect.Bottom:=GetValue(APath+'Bottom',ADefault.Bottom);
end;
procedure TConfigStorage.SetValue(const APath, AValue: String);
begin
SetFullPathValue(ExtendPath(APath),AValue);
@ -132,6 +145,23 @@ begin
SetDeleteFullPathValue(ExtendPath(APath),AValue,DefValue);
end;
procedure TConfigStorage.SetValue(const APath: String; const AValue: TRect);
begin
SetValue(APath+'Left',AValue.Left);
SetValue(APath+'Top',AValue.Top);
SetValue(APath+'Right',AValue.Right);
SetValue(APath+'Bottom',AValue.Bottom);
end;
procedure TConfigStorage.SetDeleteValue(const APath: String; const AValue,
DefValue: TRect);
begin
SetDeleteValue(APath+'Left',AValue.Left,DefValue.Left);
SetDeleteValue(APath+'Top',AValue.Top,DefValue.Top);
SetDeleteValue(APath+'Right',AValue.Right,DefValue.Right);
SetDeleteValue(APath+'Bottom',AValue.Bottom,DefValue.Bottom);
end;
procedure TConfigStorage.DeletePath(const APath: string);
begin
DeleteFullPath(ExtendPath(APath));

290
lcl/ldockctrl.pas
View File

@ -60,7 +60,17 @@ type
ldcntPages,
ldcntPage
);
const
LDConfigNodeTypeNames: array[TLDConfigNodeType] of string = (
'Control',
'Form',
'Splitter',
'Pages',
'Page'
);
type
{ TLazDockConfigNode }
TLazDockConfigNode = class(TPersistent)
@ -68,16 +78,16 @@ type
FBounds: TRect;
FName: string;
FParent: TLazDockConfigNode;
FSides: array[TAnchorKind] of TLazDockConfigNode;
FSides: array[TAnchorKind] of string;
FTheType: TLDConfigNodeType;
FChilds: TFPList;
function GetChildCount: Integer;
function GetChilds(Index: integer): TLazDockConfigNode;
function GetSides(Side: TAnchorKind): TLazDockConfigNode;
function GetSides(Side: TAnchorKind): string;
procedure SetBounds(const AValue: TRect);
procedure SetName(const AValue: string);
procedure SetParent(const AValue: TLazDockConfigNode);
procedure SetSides(Side: TAnchorKind; const AValue: TLazDockConfigNode);
procedure SetSides(Side: TAnchorKind; const AValue: string);
procedure SetTheType(const AValue: TLDConfigNodeType);
procedure DoAdd(ChildNode: TLazDockConfigNode);
procedure DoRemove(ChildNode: TLazDockConfigNode);
@ -86,14 +96,17 @@ type
destructor Destroy; override;
procedure Clear;
function FindByName(const AName: string): TLazDockConfigNode;
procedure SaveToConfig(Config: TConfigStorage; const Path: string = '');
procedure LoadFromConfig(Config: TConfigStorage; const Path: string = '');
procedure WriteDebugReport;
public
property Bounds: TRect read FBounds write SetBounds;
property Parent: TLazDockConfigNode read FParent write SetParent;
property Sides[Side: TAnchorKind]: TLazDockConfigNode read GetSides write SetSides;
property Sides[Side: TAnchorKind]: string read GetSides write SetSides;
property ChildCount: Integer read GetChildCount;
property Childs[Index: integer]: TLazDockConfigNode read GetChilds; default;
published
property TheType: TLDConfigNodeType read FTheType write SetTheType;
property TheType: TLDConfigNodeType read FTheType write SetTheType default ldcntControl;
property Name: string read FName write SetName;
end;
@ -105,6 +118,9 @@ type
private
FDockers: TFPList;
FManager: TAnchoredDockManager;
FConfigs: TFPList;// list of TLazDockConfigNode
function GetConfigCount: Integer;
function GetConfigs(Index: Integer): TLazDockConfigNode;
function GetDockerCount: Integer;
function GetDockers(Index: Integer): TCustomLazControlDocker;
protected
@ -119,13 +135,18 @@ type
Ignore: TCustomLazControlDocker): TCustomLazControlDocker;
function CreateUniqueName(const AName: string;
Ignore: TCustomLazControlDocker): string;
procedure SaveToStream(Stream: TStream);
function GetControlConfigName(AControl: TControl): string;
procedure SaveToConfig(Config: TConfigStorage; const Path: string = '');
procedure LoadFromConfig(Config: TConfigStorage; const Path: string = '');
procedure AddOrReplaceConfig(Config: TLazDockConfigNode);
procedure WriteDebugReport;
procedure ClearConfigs;
public
property Manager: TAnchoredDockManager read FManager;
property DockerCount: Integer read GetDockerCount;
property Dockers[Index: Integer]: TCustomLazControlDocker read GetDockers; default;
property ConfigCount: Integer read GetConfigCount;
property Configs[Index: Integer]: TLazDockConfigNode read GetConfigs;
end;
{ TLazDockingManager }
@ -139,11 +160,8 @@ type
When the control gets visible TCustomLazControlDocker restores the layout.
Before the control gets invisible, TCustomLazControlDocker saves the layout.
}
TCustomLazControlDocker = class(TComponent)
private
FConfigRootNode: TLazDockConfigNode;// the root node of the config tree
FConfigSelfNode: TLazDockConfigNode;// the node of 'Control'
FControl: TControl;
FDockerName: string;
FExtendPopupMenu: boolean;
@ -163,20 +181,16 @@ type
procedure ControlVisibleChanging(Sender: TObject);
procedure ControlVisibleChanged(Sender: TObject);
public
procedure ShowDockingEditor; virtual;
procedure ClearConfigNodes;
procedure GetLayoutFromControl;
function GetControlName(AControl: TControl): string;
procedure WriteConfigTreeDebugReport;
constructor Create(TheOwner: TComponent); override;
procedure ShowDockingEditor; virtual;
function GetLayoutFromControl: TLazDockConfigNode;
function GetControlName(AControl: TControl): string;
property Control: TControl read FControl write SetControl;
property Manager: TCustomLazDockingManager read FManager write SetManager;
property ExtendPopupMenu: boolean read FExtendPopupMenu write SetExtendPopupMenu;
property PopupMenuItem: TMenuItem read FPopupMenuItem;
property LocalizedName: string read FLocalizedName write SetLocalizedName;
property DockerName: string read FDockerName write SetDockerName;
property ConfigRootNode: TLazDockConfigNode read FConfigRootNode;
property ConfigSelfNode: TLazDockConfigNode read FConfigSelfNode;
end;
{ TLazControlDocker }
@ -188,12 +202,22 @@ type
property ExtendPopupMenu;
property DockerName;
end;
function LDConfigNodeTypeNameToType(const s: string): TLDConfigNodeType;
procedure Register;
implementation
function LDConfigNodeTypeNameToType(const s: string): TLDConfigNodeType;
begin
for Result:=Low(TLDConfigNodeType) to High(TLDConfigNodeType) do
if CompareText(LDConfigNodeTypeNames[Result],s)=0 then exit;
Result:=ldcntControl;
end;
procedure Register;
begin
RegisterComponents('Misc',[TLazDockingManager,TLazControlDocker]);
@ -372,7 +396,7 @@ begin
end;
end;
procedure TCustomLazControlDocker.GetLayoutFromControl;
function TCustomLazControlDocker.GetLayoutFromControl: TLazDockConfigNode;
procedure CopyChildsLayout(ParentNode: TLazDockConfigNode;
ParentNodeControl: TWinControl);
@ -417,7 +441,7 @@ procedure TCustomLazControlDocker.GetLayoutFromControl;
RaiseGDBException('inconsistency');
end;
DebugLn('CopyChildsLayout ',DbgSName(CurAnchorControl),' CurAnchorCtrlName="',CurAnchorCtrlName,'"');
ChildNode.Sides[a]:=CurAnchorNode;
ChildNode.Sides[a]:=CurAnchorNode.Name;
end;
end;
finally
@ -433,9 +457,7 @@ procedure TCustomLazControlDocker.GetLayoutFromControl;
NeedChildNodes: boolean;
begin
Result:=TLazDockConfigNode.Create(ParentNode,GetControlName(AControl));
if AControl=Control then
FConfigSelfNode:=Result;
// The Type
if AControl is TLazDockSplitter then
Result.FTheType:=ldcntSplitter
@ -481,52 +503,12 @@ procedure TCustomLazControlDocker.GetLayoutFromControl;
var
RootControl: TControl;
begin
ClearConfigNodes;
if (Control=nil) or (Manager=nil) then exit;
if (Control=nil) or (Manager=nil) then exit(nil);
RootControl:=Control;
while RootControl.Parent<>nil do
RootControl:=RootControl.Parent;
FConfigRootNode:=AddNode(nil,RootControl);
end;
procedure TCustomLazControlDocker.ClearConfigNodes;
begin
FConfigSelfNode:=nil;
FConfigRootNode.Free;
FConfigRootNode:=nil;
end;
procedure TCustomLazControlDocker.WriteConfigTreeDebugReport;
procedure WriteNode(const Prefix: string; ANode: TLazDockConfigNode);
var
a: TAnchorKind;
i: Integer;
s: string;
begin
if ANode=nil then exit;
DbgOut(Prefix,'Name="'+ANode.Name+'"');
DbgOut(' Type=',GetEnumName(TypeInfo(TLDConfigNodeType),ord(ANode.TheType)));
DbgOut(' Bounds='+dbgs(ANode.Bounds));
DbgOut(' Childs='+dbgs(ANode.ChildCount));
for a:=Low(TAnchorKind) to High(TAnchorKind) do begin
if ANode.Sides[a]=nil then continue;
s:=ANode.Sides[a].Name;
if s='' then
s:='?';
DbgOut(' '+AnchorNames[a]+'="'+s+'"');
end;
debugln;
for i:=0 to ANode.ChildCount-1 do begin
WriteNode(Prefix+' ',ANode[i]);
end;
end;
begin
DebugLn('TCustomLazControlDocker.WriteConfigTreeDebugReport '
,' Root=',dbgs(ConfigRootNode),' SelfNode=',dbgs(ConfigSelfNode));
WriteNode(' ',ConfigRootNode);
Result:=AddNode(nil,RootControl);
end;
constructor TCustomLazControlDocker.Create(TheOwner: TComponent);
@ -607,6 +589,20 @@ begin
Result:=FDockers.Count;
end;
function TCustomLazDockingManager.GetConfigCount: Integer;
begin
if FConfigs<>nil then
Result:=FConfigs.Count
else
Result:=0;
end;
function TCustomLazDockingManager.GetConfigs(Index: Integer
): TLazDockConfigNode;
begin
Result:=TLazDockConfigNode(FConfigs[Index]);
end;
constructor TCustomLazDockingManager.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
@ -622,6 +618,8 @@ begin
Dockers[i].Manager:=nil;
FreeAndNil(FDockers);
FreeAndNil(FManager);
ClearConfigs;
FreeAndNil(FConfigs);
inherited Destroy;
end;
@ -665,11 +663,6 @@ begin
Result:=CreateNextIdentifier(Result);
end;
procedure TCustomLazDockingManager.SaveToStream(Stream: TStream);
begin
RaiseGDBException('TODO TCustomLazDockingManager.SaveToStream');
end;
function TCustomLazDockingManager.GetControlConfigName(AControl: TControl
): string;
var
@ -682,6 +675,71 @@ begin
Result:='';
end;
procedure TCustomLazDockingManager.SaveToConfig(Config: TConfigStorage;
const Path: string);
var
i: Integer;
ADocker: TCustomLazControlDocker;
CurDockConfig: TLazDockConfigNode;
begin
// collect configs
for i:=0 to DockerCount-1 do begin
ADocker:=Dockers[i];
if ((ADocker.Control<>nil) and ADocker.Control.Visible) then begin
CurDockConfig:=ADocker.GetLayoutFromControl;
AddOrReplaceConfig(CurDockConfig);
end;
end;
Config.SetDeleteValue(Path+'Configs/Count',ConfigCount,0);
for i:=0 to ConfigCount-1 do begin
CurDockConfig:=Configs[i];
CurDockConfig.SaveToConfig(Config,Path+'Config'+IntToStr(i)+'/');
end;
end;
procedure TCustomLazDockingManager.LoadFromConfig(Config: TConfigStorage;
const Path: string);
var
i: Integer;
NewConfigCount: LongInt;
NewConfigName: String;
SubPath: String;
NewConfig: TLazDockConfigNode;
begin
// merge the configs
NewConfigCount:=Config.GetValue(Path+'Configs/Count',0);
for i:=0 to NewConfigCount-1 do begin
SubPath:=Path+'Config'+IntToStr(i)+'/';
NewConfigName:=Config.GetValue(SubPath+'Name/Value','');
if NewConfigName='' then continue;
NewConfig:=TLazDockConfigNode.Create(nil,NewConfigName);
NewConfig.LoadFromConfig(Config,SubPath);
AddOrReplaceConfig(NewConfig);
end;
// apply the configs
// TODO
end;
procedure TCustomLazDockingManager.AddOrReplaceConfig(
Config: TLazDockConfigNode);
var
i: Integer;
CurConfig: TLazDockConfigNode;
begin
if FConfigs=nil then
FConfigs:=TFPList.Create;
for i:=FConfigs.Count-1 downto 0 do begin
CurConfig:=Configs[i];
if CompareText(CurConfig.Name,Config.Name)=0 then begin
CurConfig.Free;
FConfigs.Delete(i);
end;
end;
FConfigs.Add(Config);
end;
procedure TCustomLazDockingManager.WriteDebugReport;
var
i: Integer;
@ -694,9 +752,18 @@ begin
end;
end;
procedure TCustomLazDockingManager.ClearConfigs;
var
i: Integer;
begin
if FConfigs=nil then exit;
for i:=0 to FConfigs.Count-1 do TObject(FConfigs[i]).Free;
FConfigs.Clear;
end;
{ TLazDockConfigNode }
function TLazDockConfigNode.GetSides(Side: TAnchorKind): TLazDockConfigNode;
function TLazDockConfigNode.GetSides(Side: TAnchorKind): string;
begin
Result:=FSides[Side];
end;
@ -737,7 +804,7 @@ begin
end;
procedure TLazDockConfigNode.SetSides(Side: TAnchorKind;
const AValue: TLazDockConfigNode);
const AValue: string);
begin
FSides[Side]:=AValue;
end;
@ -763,6 +830,7 @@ constructor TLazDockConfigNode.Create(ParentNode: TLazDockConfigNode;
const AName: string);
begin
FName:=AName;
FTheType:=ldcntControl;
Parent:=ParentNode;
end;
@ -796,4 +864,86 @@ begin
Result:=nil;
end;
procedure TLazDockConfigNode.SaveToConfig(Config: TConfigStorage;
const Path: string);
var
a: TAnchorKind;
i: Integer;
Child: TLazDockConfigNode;
begin
Config.SetDeleteValue(Path+'Name/Value',Name,'');
Config.SetDeleteValue(Path+'Bounds/',FBounds,Rect(0,0,0,0));
Config.SetDeleteValue(Path+'Type/Value',LDConfigNodeTypeNames[TheType],
LDConfigNodeTypeNames[ldcntControl]);
// Sides
for a:=Low(TAnchorKind) to High(TAnchorKind) do
Config.SetDeleteValue(Path+'Sides/'+AnchorNames[a]+'/Name',Sides[a],'');
// childs
Config.SetDeleteValue(Path+'Childs/Count',ChildCount,0);
for i:=0 to ChildCount-1 do begin
Child:=Childs[i];
Child.SaveToConfig(Config,Path+'Child'+IntToStr(i+1)+'/');
end;
end;
procedure TLazDockConfigNode.LoadFromConfig(Config: TConfigStorage;
const Path: string);
var
a: TAnchorKind;
i: Integer;
NewChildCount: LongInt;
NewChildName: String;
NewChild: TLazDockConfigNode;
begin
Clear;
Config.GetValue(Path+'Bounds/',FBounds,Rect(0,0,0,0));
TheType:=LDConfigNodeTypeNameToType(Config.GetValue(Path+'Type/Value',
LDConfigNodeTypeNames[ldcntControl]));
// Sides
for a:=Low(TAnchorKind) to High(TAnchorKind) do
Sides[a]:=Config.GetValue(Path+'Sides/'+AnchorNames[a]+'/Name','');
// childs
NewChildCount:=Config.GetValue(Path+'Childs/Count',0);
for i:=0 to NewChildCount-1 do begin
NewChildName:=Config.GetValue(Path+'Name/Value','');
NewChild:=TLazDockConfigNode.Create(Self,NewChildName);
NewChild.LoadFromConfig(Config,Path+'Child'+IntToStr(i+1)+'/');
FChilds.Add(NewChild);
end;
end;
procedure TLazDockConfigNode.WriteDebugReport;
procedure WriteNode(const Prefix: string; ANode: TLazDockConfigNode);
var
a: TAnchorKind;
i: Integer;
s: string;
begin
if ANode=nil then exit;
DbgOut(Prefix,'Name="'+ANode.Name+'"');
DbgOut(' Type=',GetEnumName(TypeInfo(TLDConfigNodeType),ord(ANode.TheType)));
DbgOut(' Bounds='+dbgs(ANode.Bounds));
DbgOut(' Childs='+dbgs(ANode.ChildCount));
for a:=Low(TAnchorKind) to High(TAnchorKind) do begin
s:=ANode.Sides[a];
if s='' then
s:='?';
DbgOut(' '+AnchorNames[a]+'="'+s+'"');
end;
debugln;
for i:=0 to ANode.ChildCount-1 do begin
WriteNode(Prefix+' ',ANode[i]);
end;
end;
begin
DebugLn('TLazDockConfigNode.WriteDebugReport Root=',dbgs(Self));
WriteNode(' ',Self);
end;
end.

144
lcl/xmlpropstorage.pas
View File

@ -21,16 +21,19 @@ interface
uses
Classes, SysUtils, LCLProc, Forms, PropertyStorage, XMLCfg, DOM;
Classes, SysUtils, LCLProc, Forms, PropertyStorage, XMLCfg, DOM,
LazConfigStorage;
type
{ TXMLPropStorage }
{ TPropStorageXMLConfig }
TPropStorageXMLConfig = class(TXMLConfig)
Public
Procedure DeleteSubNodes (const ARootNode: String);
end;
{ TCustomXMLPropStorage }
TCustomXMLPropStorage = class(TFormPropertyStorage)
private
FCount: Integer;
@ -53,6 +56,8 @@ type
property RootNodePath: String Read FRootNodePath Write FRootNodePath;
end;
{ TXMLPropStorage }
TXMLPropStorage = class(TCustomXMLPropStorage)
Published
property StoredValues;
@ -64,6 +69,35 @@ type
property OnRestoringProperties;
property OnRestoreProperties;
end;
{ TXMLConfigStorage }
TXMLConfigStorage = class(TConfigStorage)
private
FFreeXMLConfig: boolean;
FXMLConfig: TXMLConfig;
protected
function GetFullPathValue(const APath, ADefault: String): String; override;
function GetFullPathValue(const APath: String; ADefault: Integer): Integer; override;
function GetFullPathValue(const APath: String; ADefault: Boolean): Boolean; override;
procedure SetFullPathValue(const APath, AValue: String); override;
procedure SetDeleteFullPathValue(const APath, AValue, DefValue: String); override;
procedure SetFullPathValue(const APath: String; AValue: Integer); override;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Integer); override;
procedure SetFullPathValue(const APath: String; AValue: Boolean); override;
procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Boolean); override;
procedure DeleteFullPath(const APath: string); override;
procedure DeleteFullPathValue(const APath: string); override;
public
constructor Create(const Filename: string; LoadFromDisk: Boolean); override;
constructor Create(TheXMLConfig: TXMLConfig);
constructor Create(TheXMLConfig: TXMLConfig; const StartPath: string);
destructor Destroy; override;
property XMLConfig: TXMLConfig read FXMLConfig;
property FreeXMLConfig: boolean read FFreeXMLConfig write FFreeXMLConfig;
procedure WriteToDisk; override;
function GetFilename: string; override;
end;
procedure Register;
@ -173,4 +207,108 @@ begin
end;
end;
end.
{ TXMLConfigStorage }
function TXMLConfigStorage.GetFullPathValue(const APath, ADefault: String
): String;
begin
Result:=XMLConfig.GetValue(APath, ADefault);
end;
function TXMLConfigStorage.GetFullPathValue(const APath: String;
ADefault: Integer): Integer;
begin
Result:=XMLConfig.GetValue(APath, ADefault);
end;
function TXMLConfigStorage.GetFullPathValue(const APath: String;
ADefault: Boolean): Boolean;
begin
Result:=XMLConfig.GetValue(APath, ADefault);
end;
procedure TXMLConfigStorage.SetFullPathValue(const APath, AValue: String);
begin
XMLConfig.SetValue(APath, AValue);
end;
procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath, AValue,
DefValue: String);
begin
XMLConfig.SetDeleteValue(APath, AValue, DefValue);
end;
procedure TXMLConfigStorage.SetFullPathValue(const APath: String;
AValue: Integer);
begin
XMLConfig.SetValue(APath, AValue);
end;
procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath: String;
AValue, DefValue: Integer);
begin
XMLConfig.SetDeleteValue(APath, AValue, DefValue);
end;
procedure TXMLConfigStorage.SetFullPathValue(const APath: String;
AValue: Boolean);
begin
XMLConfig.SetValue(APath, AValue);
end;
procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath: String;
AValue, DefValue: Boolean);
begin
XMLConfig.SetDeleteValue(APath, AValue, DefValue);
end;
procedure TXMLConfigStorage.DeleteFullPath(const APath: string);
begin
XMLConfig.DeletePath(APath);
end;
procedure TXMLConfigStorage.DeleteFullPathValue(const APath: string);
begin
XMLConfig.DeleteValue(APath);
end;
constructor TXMLConfigStorage.Create(const Filename: string;
LoadFromDisk: Boolean);
begin
FXMLConfig:=TXMLConfig.Create(nil);
FXMLConfig.StartEmpty:=not LoadFromDisk;
FXMLConfig.Filename:=Filename;
FFreeXMLConfig:=true;
end;
constructor TXMLConfigStorage.Create(TheXMLConfig: TXMLConfig);
begin
FXMLConfig:=TheXMLConfig;
if FXMLConfig=nil then
raise Exception.Create('');
end;
constructor TXMLConfigStorage.Create(TheXMLConfig: TXMLConfig;
const StartPath: string);
begin
Create(TheXMLConfig);
AppendBasePath(StartPath);
end;
destructor TXMLConfigStorage.Destroy;
begin
if FreeXMLConfig then FreeAndNil(FXMLConfig);
inherited Destroy;
end;
procedure TXMLConfigStorage.WriteToDisk;
begin
FXMLConfig.Flush;
end;
function TXMLConfigStorage.GetFilename: string;
begin
Result:=FXMLConfig.Filename;
end;
end.