1 { $Id: xmlpropstorage.pas 51954 2016-03-15 21:16:43Z juha $ }
2 {
3 *****************************************************************************
4 This file is part of the Lazarus Component Library (LCL)
5
6 See the file COPYING.modifiedLGPL.txt, included in this distribution,
7 for details about the license.
8 *****************************************************************************
9 }
10 unit XMLPropStorage;
11
12 {$mode objfpc}{$H+}
13
14 interface
15
16
17 uses
18 // RTL, FCL
19 Classes, SysUtils, XMLConf, DOM, XMLRead, XMLWrite,
20 // LCL
21 LCLProc, Forms,
22 // LazUtils
23 LazConfigStorage, LazUTF8, LazUTF8Classes;
24
25 type
26 { TPropStorageXMLConfig }
27
28 TPropStorageXMLConfig = class(TXMLConfig)
29 Public
30 procedure DeleteSubNodes(const ARootNode: String);
31 procedure LoadFromStream(s: TStream); virtual;
32 procedure SaveToStream(s: TStream); virtual;
33 property XMLDoc: TXMLDocument read Doc;
34 end;
35
36 { TCustomXMLPropStorage }
37
38 TCustomXMLPropStorage = class(TFormPropertyStorage)
39 private
40 FCount: Integer;
41 FFileName: String;
42 FXML: TPropStorageXMLConfig;
43 FRootNodePath: String;
44 protected
GetXMLFileNamenull45 function GetXMLFileName: string; virtual;
RootSectionnull46 function RootSection: String; Override;
FixPathnull47 function FixPath(const APath: String): String; virtual;
48 Property XMLConfig: TPropStorageXMLConfig Read FXML;
49 public
50 procedure StorageNeeded(ReadOnly: Boolean);override;
51 procedure FreeStorage; override;
DoReadStringnull52 function DoReadString(const Section, Ident, TheDefault: string): string; override;
53 procedure DoWriteString(const Section, Ident, Value: string); override;
54 procedure DoEraseSections(const ARootSection: String);override;
55 public
56 property FileName: String Read FFileName Write FFileName;
57 property RootNodePath: String Read FRootNodePath Write FRootNodePath;
58 end;
59
60 { TXMLPropStorage }
61
62 TXMLPropStorage = class(TCustomXMLPropStorage)
63 Published
64 property StoredValues;
65 property FileName;
66 property RootNodePath;
67 property Active;
68 property OnSavingProperties;
69 property OnSaveProperties;
70 property OnRestoringProperties;
71 property OnRestoreProperties;
72 end;
73
74 { TXMLConfigStorage }
75
76 TXMLConfigStorage = class(TConfigStorage)
77 private
78 FFilename: string;
79 FFreeXMLConfig: boolean;
80 FXMLConfig: TXMLConfig;
81 protected
GetFullPathValuenull82 function GetFullPathValue(const APath, ADefault: String): String; override;
GetFullPathValuenull83 function GetFullPathValue(const APath: String; ADefault: Integer): Integer; override;
GetFullPathValuenull84 function GetFullPathValue(const APath: String; ADefault: Boolean): Boolean; override;
85 procedure SetFullPathValue(const APath, AValue: String); override;
86 procedure SetDeleteFullPathValue(const APath, AValue, DefValue: String); override;
87 procedure SetFullPathValue(const APath: String; AValue: Integer); override;
88 procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Integer); override;
89 procedure SetFullPathValue(const APath: String; AValue: Boolean); override;
90 procedure SetDeleteFullPathValue(const APath: String; AValue, DefValue: Boolean); override;
91 procedure DeleteFullPath(const APath: string); override;
92 procedure DeleteFullPathValue(const APath: string); override;
93 public
94 procedure Clear; override;
95 constructor Create(const Filename: string; LoadFromDisk: Boolean); override;
96 constructor Create(TheXMLConfig: TXMLConfig);
97 constructor Create(TheXMLConfig: TXMLConfig; const StartPath: string);
98 constructor Create(s: TStream; const StartPath: string = '');
99 destructor Destroy; override;
100 property XMLConfig: TXMLConfig read FXMLConfig;
101 property FreeXMLConfig: boolean read FFreeXMLConfig write FFreeXMLConfig;
102 procedure WriteToDisk; override;
GetFilenamenull103 function GetFilename: string; override;
104 procedure SaveToStream(s: TStream); virtual;
105 end;
106
107 procedure Register;
108
109
110 implementation
111
112 {$IFDEF FPC_HAS_CPSTRING}
113 {$WARN IMPLICIT_STRING_CAST OFF}
114 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
115 {$ENDIF}
116
117 procedure Register;
118 begin
119 RegisterComponents('Misc',[TXMLPropStorage]);
120 end;
121
122 { TCustomXMLPropStorage }
123
124 procedure TCustomXMLPropStorage.StorageNeeded(ReadOnly: Boolean);
125 begin
126 If (FXML=Nil) and not (csDesigning in ComponentState) then
127 begin
128 FXML:=TPropStorageXMLConfig.Create(nil);
129 FXML.FileName := GetXMLFileName;
130 end;
131 Inc(FCount);
132 //debugln('TCustomXMLPropStorage.StorageNeeded ',dbgsname(FXML),' ',dbgs(FXML),' FCount=',dbgs(FCount));
133 end;
134
135 procedure TCustomXMLPropStorage.FreeStorage;
136 begin
137 Dec(FCount);
138 //debugln('TCustomXMLPropStorage.FreeStorage ',dbgsname(FXML),' ',dbgs(FXML),' FCount=',dbgs(FCount));
139 If (FCount<=0) then
140 begin
141 FCount:=0;
142 FreeAndNil(FXML);
143 end;
144 end;
145
GetXMLFileNamenull146 function TCustomXMLPropStorage.GetXMLFileName: string;
147 begin
148 if (FFileName<>'') then
149 Result:=FFileName
150 else if csDesigning in ComponentState then
151 raise Exception.Create('TCustomXMLPropStorage.GetXMLFileName: missing Filename')
152 else
153 {$ifdef unix}
154 Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariableUTF8('HOME'))
155 +'.'+ExtractFileName(Application.ExeName);
156
157 {$else}
158 Result:=ChangeFileExt(Application.ExeName,'.xml');
159 {$endif}
160 //debugln('TCustomXMLPropStorage.GetXMLFileName "',Result,'"');
161 end;
162
TCustomXMLPropStorage.FixPathnull163 function TCustomXMLPropStorage.FixPath(const APath: String): String;
164 begin
165 Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
166 end;
167
TCustomXMLPropStorage.RootSectionnull168 function TCustomXMLPropStorage.RootSection: String;
169 begin
170 If (FRootNodePath<>'') then
171 Result:=FRootNodePath
172 else
173 Result:=inherited RootSection;
174 Result:=FixPath(Result);
175 end;
176
DoReadStringnull177 function TCustomXMLPropStorage.DoReadString(const Section, Ident,
178 TheDefault: string): string;
179 var
180 Res: UnicodeString;
181 begin
182 Res:=FXML.GetValue(Utf8Decode(FixPath(Section)+'/'+Ident), Utf8Decode(TheDefault));
183 Result := Utf8Encode(Res);
184 //debugln('TCustomXMLPropStorage.DoReadString Section="',Section,'" Ident="',Ident,'" Result=',Result);
185 end;
186
187 procedure TCustomXMLPropStorage.DoWriteString(const Section, Ident,
188 Value: string);
189 begin
190 //debugln('TCustomXMLPropStorage.DoWriteString Section="',Section,'" Ident="',Ident,'" Value="',Value,'"');
191 FXML.SetValue(Utf8Decode(FixPath(Section)+'/'+Ident), Utf8Decode(Value));
192 end;
193
194 procedure TCustomXMLPropStorage.DoEraseSections(const ARootSection: String);
195 begin
196 //debugln('TCustomXMLPropStorage.DoEraseSections ARootSection="',ARootSection,'"');
197 FXML.DeleteSubNodes(FixPath(ARootSection));
198 end;
199
200 { TPropStorageXMLConfig }
201
202 procedure TPropStorageXMLConfig.DeleteSubNodes(const ARootNode: String);
203 var
204 Node, Child: TDOMNode;
205 i: Integer;
206 NodePath: String;
207 begin
208 Node := doc.DocumentElement;
209 NodePath := ARootNode;
210 while (Length(NodePath)>0) and (Node<>Nil) do
211 begin
212 i := Pos('/', NodePath);
213 if i = 0 then
214 I:=Length(NodePath)+1;
215 Child := Node.FindNode(UTF8Decode(Copy(NodePath,1,i - 1)));
216 System.Delete(NodePath,1,I);
217 Node := Child;
218 end;
219 If Assigned(Node) then begin
220 //debugln('TPropStorageXMLConfig.DeleteSubNodes ',ARootNode);
221 Node.Free;
222 end;
223 end;
224
225 procedure TPropStorageXMLConfig.LoadFromStream(s: TStream);
226 begin
227 FreeAndNil(Doc);
228 ReadXMLFile(Doc,s);
229 end;
230
231 procedure TPropStorageXMLConfig.SaveToStream(s: TStream);
232 begin
233 WriteXMLFile(Doc,s);
234 end;
235
236 { TXMLConfigStorage }
237
TXMLConfigStorage.GetFullPathValuenull238 function TXMLConfigStorage.GetFullPathValue(const APath, ADefault: String
239 ): String;
240 begin
241 Result:=XMLConfig.GetValue(APath, ADefault);
242 end;
243
TXMLConfigStorage.GetFullPathValuenull244 function TXMLConfigStorage.GetFullPathValue(const APath: String;
245 ADefault: Integer): Integer;
246 begin
247 Result:=XMLConfig.GetValue(APath, ADefault);
248 end;
249
TXMLConfigStorage.GetFullPathValuenull250 function TXMLConfigStorage.GetFullPathValue(const APath: String;
251 ADefault: Boolean): Boolean;
252 begin
253 Result:=XMLConfig.GetValue(APath, ADefault);
254 end;
255
256 procedure TXMLConfigStorage.SetFullPathValue(const APath, AValue: String);
257 begin
258 XMLConfig.SetValue(APath, AValue);
259 end;
260
261 procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath, AValue,
262 DefValue: String);
263 begin
264 XMLConfig.SetDeleteValue(APath, AValue, DefValue);
265 end;
266
267 procedure TXMLConfigStorage.SetFullPathValue(const APath: String;
268 AValue: Integer);
269 begin
270 XMLConfig.SetValue(APath, AValue);
271 end;
272
273 procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath: String;
274 AValue, DefValue: Integer);
275 begin
276 XMLConfig.SetDeleteValue(APath, AValue, DefValue);
277 end;
278
279 procedure TXMLConfigStorage.SetFullPathValue(const APath: String;
280 AValue: Boolean);
281 begin
282 XMLConfig.SetValue(APath, AValue);
283 end;
284
285 procedure TXMLConfigStorage.SetDeleteFullPathValue(const APath: String;
286 AValue, DefValue: Boolean);
287 begin
288 XMLConfig.SetDeleteValue(APath, AValue, DefValue);
289 end;
290
291 procedure TXMLConfigStorage.DeleteFullPath(const APath: string);
292 begin
293 XMLConfig.DeletePath(APath);
294 end;
295
296 procedure TXMLConfigStorage.DeleteFullPathValue(const APath: string);
297 begin
298 XMLConfig.DeleteValue(APath);
299 end;
300
301 procedure TXMLConfigStorage.Clear;
302 begin
303 FXMLConfig.Clear;
304 end;
305
306 constructor TXMLConfigStorage.Create(const Filename: string;
307 LoadFromDisk: Boolean);
308 var
309 ms: TMemoryStream;
310 fs: TFileStreamUTF8;
311 begin
312 FXMLConfig:=TPropStorageXMLConfig.Create(nil);
313 FFilename:=Filename;
314 FFreeXMLConfig:=true;
315 if LoadFromDisk then
316 begin
317 fs:=TFileStreamUTF8.Create(Filename,fmOpenRead+fmShareDenyWrite);
318 try
319 ms:=TMemoryStream.Create;
320 try
321 ms.CopyFrom(fs,fs.Size);
322 ms.Position:=0;
323 TPropStorageXMLConfig(FXMLConfig).LoadFromStream(ms);
324 finally
325 ms.Free;
326 end;
327 finally
328 fs.Free;
329 end;
330 end;
331 end;
332
333 constructor TXMLConfigStorage.Create(TheXMLConfig: TXMLConfig);
334 begin
335 FXMLConfig:=TheXMLConfig;
336 FFilename:=FXMLConfig.Filename;
337 if FXMLConfig=nil then
338 raise Exception.Create('');
339 end;
340
341 constructor TXMLConfigStorage.Create(TheXMLConfig: TXMLConfig;
342 const StartPath: string);
343 begin
344 Create(TheXMLConfig);
345 AppendBasePath(StartPath);
346 end;
347
348 constructor TXMLConfigStorage.Create(s: TStream; const StartPath: string);
349 begin
350 FXMLConfig:=TPropStorageXMLConfig.Create(nil);
351 FFreeXMLConfig:=true;
352 TPropStorageXMLConfig(FXMLConfig).LoadFromStream(s);
353 if StartPath<>'' then
354 AppendBasePath(StartPath);
355 end;
356
357 destructor TXMLConfigStorage.Destroy;
358 begin
359 if FreeXMLConfig then FreeAndNil(FXMLConfig);
360 inherited Destroy;
361 end;
362
363 procedure TXMLConfigStorage.WriteToDisk;
364 var
365 ms: TMemoryStream;
366 fs: TFileStreamUTF8;
367 begin
368 if FXMLConfig is TPropStorageXMLConfig then
369 begin
370 ms:=TMemoryStream.Create;
371 try
372 TPropStorageXMLConfig(FXMLConfig).SaveToStream(ms);
373 ms.Position:=0;
374 fs:=TFileStreamUTF8.Create(GetFilename,fmCreate);
375 try
376 fs.CopyFrom(ms,ms.Size);
377 finally
378 fs.Free;
379 end;
380 finally
381 ms.Free;
382 end;
383 end else
384 FXMLConfig.Flush;
385 end;
386
TXMLConfigStorage.GetFilenamenull387 function TXMLConfigStorage.GetFilename: string;
388 begin
389 Result:=FFilename;
390 end;
391
392 procedure TXMLConfigStorage.SaveToStream(s: TStream);
393 begin
394 if FXMLConfig is TPropStorageXMLConfig then begin
395 TPropStorageXMLConfig(FXMLConfig).SaveToStream(s);
396 end else
397 raise Exception.Create('TXMLConfigStorage.SaveToStream not supported for '+DbgSName(FXMLConfig));
398 end;
399
400 end.
401