← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/codetools/laz_xmlcfg.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/codetools/laz_xmlcfg.pas
1
 
{
2
 
    $Id: laz_xmlcfg.pas 28744 2010-12-17 19:12:20Z mattias $
3
 
    This file was part of the Free Component Library and was adapted to use UTF8
4
 
    strings instead of widestrings.
5
 
 
6
 
    Implementation of TXMLConfig class
7
 
    Copyright (c) 1999 - 2001 by Sebastian Guenther, sg@freepascal.org
8
 
 
9
 
    See the file COPYING.modifiedLGPL.txt, included in this distribution,
10
 
    for details about the copyright.
11
 
 
12
 
    This program is distributed in the hope that it will be useful,
13
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15
 
 
16
 
 **********************************************************************}
17
 
 
18
 
{
19
 
  TXMLConfig enables applications to use XML files for storing their
20
 
  configuration data
21
 
}
22
 
 
23
 
{$MODE objfpc}
24
 
{$H+}
25
 
 
26
 
unit Laz_XMLCfg;
27
 
 
28
 
{$I codetools.inc}
29
 
 
30
 
interface
31
 
 
32
 
{off $DEFINE MEM_CHECK}
33
 
 
34
 
 
35
 
uses
36
 
  {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
37
 
  Classes, sysutils,
38
 
  {$IFDEF NewXMLCfg}
39
 
  Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite,
40
 
  {$ELSE}
41
 
  Laz_DOM, Laz_XMLRead, Laz_XMLWrite,
42
 
  {$ENDIF}
43
 
  FileProcs;
44
 
 
45
 
type
46
 
 
47
 
  {"APath" is the path and name of a value: A XML configuration file is
48
 
   hierachical. "/" is the path delimiter, the part after the last "/"
49
 
   is the name of the value. The path components will be mapped to XML
50
 
   elements, the name will be an element attribute.}
51
 
 
52
 
  { TXMLConfig }
53
 
 
54
 
  TXMLConfig = class(TComponent)
55
 
  private
56
 
    FFilename: String;
57
 
    {$IFDEF NewXMLCfg}
58
 
    FReadFlags: TXMLReaderFlags;
59
 
    {$ENDIF}
60
 
    procedure SetFilename(const AFilename: String);
61
 
  protected
62
 
    doc: TXMLDocument;
63
 
    FModified: Boolean;
64
 
    fDoNotLoadFromFile: boolean;
65
 
    fAutoLoadFromSource: string;
66
 
    fPathCache: string;
67
 
    fPathNodeCache: array of TDomNode; // starting with doc.DocumentElement, then first child node of first sub path
68
 
    procedure Loaded; override;
69
 
    function ExtendedToStr(const e: extended): string;
70
 
    function StrToExtended(const s: string; const ADefault: extended): extended;
71
 
    procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); virtual;
72
 
    procedure WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); virtual;
73
 
    procedure FreeDoc; virtual;
74
 
    procedure SetPathNodeCache(Index: integer; Node: TDomNode);
75
 
    function GetPathNodeCache(Index: integer): TDomNode;
76
 
    procedure InvalidateCacheTilEnd(StartIndex: integer);
77
 
    function InternalFindNode(const APath: String; PathLen: integer;
78
 
                              CreateNodes: boolean = false): TDomNode;
79
 
    procedure InternalCleanNode(Node: TDomNode);
80
 
  public
81
 
    constructor Create(const AFilename: String); overload; // create and load
82
 
    constructor CreateClean(const AFilename: String); // create new
83
 
    constructor CreateWithSource(const AFilename, Source: String); // create new and load from Source
84
 
    destructor Destroy; override;
85
 
    procedure Clear;
86
 
    procedure Flush;    // Writes the XML file
87
 
    procedure ReadFromStream(s: TStream);
88
 
    procedure WriteToStream(s: TStream);
89
 
 
90
 
    function  GetValue(const APath, ADefault: String): String;
91
 
    function  GetValue(const APath: String; ADefault: Integer): Integer;
92
 
    function  GetValue(const APath: String; ADefault: Boolean): Boolean;
93
 
    function  GetExtendedValue(const APath: String;
94
 
                               const ADefault: extended): extended;
95
 
    procedure SetValue(const APath, AValue: String);
96
 
    procedure SetDeleteValue(const APath, AValue, DefValue: String);
97
 
    procedure SetValue(const APath: String; AValue: Integer);
98
 
    procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer);
99
 
    procedure SetValue(const APath: String; AValue: Boolean);
100
 
    procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
101
 
    procedure SetExtendedValue(const APath: String; const AValue: extended);
102
 
    procedure SetDeleteExtendedValue(const APath: String;
103
 
                                     const AValue, DefValue: extended);
104
 
    procedure DeletePath(const APath: string);
105
 
    procedure DeleteValue(const APath: string);
106
 
    function FindNode(const APath: String; PathHasValue: boolean): TDomNode;
107
 
    function HasPath(const APath: string; PathHasValue: boolean): boolean; // checks if the path has values, set PathHasValue=true to skip the last part
108
 
    function HasChildPaths(const APath: string): boolean;
109
 
    property Modified: Boolean read FModified write FModified;
110
 
    procedure InvalidatePathCache;
111
 
  published
112
 
    property Filename: String read FFilename write SetFilename;
113
 
    property Document: TXMLDocument read doc;
114
 
    {$IFDEF NewXMLCfg}
115
 
    property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags;
116
 
    {$ENDIF}
117
 
  end;
118
 
 
119
 
 
120
 
// ===================================================================
121
 
 
122
 
implementation
123
 
 
124
 
constructor TXMLConfig.Create(const AFilename: String);
125
 
begin
126
 
  //DebugLn(['TXMLConfig.Create ',AFilename]);
127
 
  {$IFDEF NewXMLCfg}
128
 
  FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
129
 
  {$ENDIF}
130
 
  inherited Create(nil);
131
 
  SetFilename(AFilename);
132
 
end;
133
 
 
134
 
constructor TXMLConfig.CreateClean(const AFilename: String);
135
 
begin
136
 
  //DebugLn(['TXMLConfig.CreateClean ',AFilename]);
137
 
  fDoNotLoadFromFile:=true;
138
 
  Create(AFilename);
139
 
  FModified:=FileExistsCached(AFilename);
140
 
end;
141
 
 
142
 
constructor TXMLConfig.CreateWithSource(const AFilename, Source: String);
143
 
begin
144
 
  fAutoLoadFromSource:=Source;
145
 
  try
146
 
    CreateClean(AFilename);
147
 
  finally
148
 
    fAutoLoadFromSource:='';
149
 
  end;
150
 
end;
151
 
 
152
 
destructor TXMLConfig.Destroy;
153
 
begin
154
 
  if Assigned(doc) then
155
 
  begin
156
 
    Flush;
157
 
    FreeDoc;
158
 
  end;
159
 
  inherited Destroy;
160
 
end;
161
 
 
162
 
procedure TXMLConfig.Clear;
163
 
var
164
 
  cfg: TDOMElement;
165
 
begin
166
 
  // free old document
167
 
  FreeDoc;
168
 
  // create new document
169
 
  doc := TXMLDocument.Create;
170
 
  cfg :=TDOMElement(doc.FindNode('CONFIG'));
171
 
  if not Assigned(cfg) then begin
172
 
    cfg := doc.CreateElement('CONFIG');
173
 
    doc.AppendChild(cfg);
174
 
  end;
175
 
end;
176
 
 
177
 
procedure TXMLConfig.Flush;
178
 
begin
179
 
  if Modified and (Filename<>'') then
180
 
  begin
181
 
    //DebugLn(['TXMLConfig.Flush ',Filename]);
182
 
    WriteXMLFile(doc, Filename);
183
 
    FModified := False;
184
 
  end;
185
 
end;
186
 
 
187
 
procedure TXMLConfig.ReadFromStream(s: TStream);
188
 
begin
189
 
  FreeDoc;
190
 
  {$IFDEF NewXMLCfg}
191
 
  Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags);
192
 
  {$ELSE}
193
 
  Laz_XMLRead.ReadXMLFile(Doc,s);
194
 
  {$ENDIF}
195
 
  if Doc=nil then
196
 
    Clear;
197
 
end;
198
 
 
199
 
procedure TXMLConfig.WriteToStream(s: TStream);
200
 
begin
201
 
  {$IFDEF NewXMLCfg}
202
 
  Laz2_XMLWrite.WriteXMLFile(Doc,s);
203
 
  {$ELSE}
204
 
  Laz_XMLWrite.WriteXMLFile(Doc,s);
205
 
  {$ENDIF}
206
 
end;
207
 
 
208
 
function TXMLConfig.GetValue(const APath, ADefault: String): String;
209
 
var
210
 
  Node, Attr: TDOMNode;
211
 
  NodeName: String;
212
 
  StartPos: integer;
213
 
begin
214
 
  //CheckHeapWrtMemCnt('TXMLConfig.GetValue A '+APath);
215
 
  Result:=ADefault;
216
 
 
217
 
  StartPos:=length(APath)+1;
218
 
  while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
219
 
  if StartPos>length(APath) then exit;
220
 
  Node:=InternalFindNode(APath,StartPos-1);
221
 
  if Node=nil then
222
 
    exit;
223
 
  //CheckHeapWrtMemCnt('TXMLConfig.GetValue E');
224
 
  NodeName:=copy(APath,StartPos,length(APath));
225
 
  //CheckHeapWrtMemCnt('TXMLConfig.GetValue G');
226
 
  Attr := Node.Attributes.GetNamedItem(NodeName);
227
 
  if Assigned(Attr) then
228
 
    Result := Attr.NodeValue;
229
 
  //writeln('TXMLConfig.GetValue END Result="',Result,'"');
230
 
end;
231
 
 
232
 
function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
233
 
begin
234
 
  Result := StrToIntDef(GetValue(APath, IntToStr(ADefault)),ADefault);
235
 
end;
236
 
 
237
 
function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean;
238
 
var
239
 
  s: String;
240
 
begin
241
 
  if ADefault then
242
 
    s := 'True'
243
 
  else
244
 
    s := 'False';
245
 
 
246
 
  s := GetValue(APath, s);
247
 
 
248
 
  if CompareText(s,'TRUE')=0 then
249
 
    Result := True
250
 
  else if CompareText(s,'FALSE')=0 then
251
 
    Result := False
252
 
  else
253
 
    Result := ADefault;
254
 
end;
255
 
 
256
 
function TXMLConfig.GetExtendedValue(const APath: String;
257
 
  const ADefault: extended): extended;
258
 
begin
259
 
  Result:=StrToExtended(GetValue(APath,ExtendedToStr(ADefault)),ADefault);
260
 
end;
261
 
 
262
 
procedure TXMLConfig.SetValue(const APath, AValue: String);
263
 
var
264
 
  Node: TDOMNode;
265
 
  NodeName: String;
266
 
  StartPos: integer;
267
 
begin
268
 
  StartPos:=length(APath)+1;
269
 
  while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
270
 
  if StartPos>length(APath) then exit;
271
 
  Node:=InternalFindNode(APath,StartPos-1,true);
272
 
  if Node=nil then
273
 
    exit;
274
 
  NodeName:=copy(APath,StartPos,length(APath));
275
 
  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or
276
 
    (TDOMElement(Node)[NodeName] <> AValue) then
277
 
  begin
278
 
    TDOMElement(Node)[NodeName] := AValue;
279
 
    FModified := True;
280
 
  end;
281
 
end;
282
 
 
283
 
procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String);
284
 
begin
285
 
  if AValue=DefValue then
286
 
    DeleteValue(APath)
287
 
  else
288
 
    SetValue(APath,AValue);
289
 
end;
290
 
 
291
 
procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
292
 
begin
293
 
  SetValue(APath, IntToStr(AValue));
294
 
end;
295
 
 
296
 
procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
297
 
  DefValue: Integer);
298
 
begin
299
 
  if AValue=DefValue then
300
 
    DeleteValue(APath)
301
 
  else
302
 
    SetValue(APath,AValue);
303
 
end;
304
 
 
305
 
procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
306
 
begin
307
 
  if AValue then
308
 
    SetValue(APath, 'True')
309
 
  else
310
 
    SetValue(APath, 'False');
311
 
end;
312
 
 
313
 
procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
314
 
  DefValue: Boolean);
315
 
begin
316
 
  if AValue=DefValue then
317
 
    DeleteValue(APath)
318
 
  else
319
 
    SetValue(APath,AValue);
320
 
end;
321
 
 
322
 
procedure TXMLConfig.SetExtendedValue(const APath: String;
323
 
  const AValue: extended);
324
 
begin
325
 
  SetValue(APath,ExtendedToStr(AValue));
326
 
end;
327
 
 
328
 
procedure TXMLConfig.SetDeleteExtendedValue(const APath: String; const AValue,
329
 
  DefValue: extended);
330
 
begin
331
 
  if AValue=DefValue then
332
 
    DeleteValue(APath)
333
 
  else
334
 
    SetExtendedValue(APath,AValue);
335
 
end;
336
 
 
337
 
procedure TXMLConfig.DeletePath(const APath: string);
338
 
var
339
 
  Node: TDOMNode;
340
 
  ParentNode: TDOMNode;
341
 
begin
342
 
  Node:=InternalFindNode(APath,length(APath));
343
 
  if (Node=nil) or (Node.ParentNode=nil) then exit;
344
 
  ParentNode:=Node.ParentNode;
345
 
  ParentNode.RemoveChild(Node);
346
 
  FModified:=true;
347
 
  InvalidatePathCache;
348
 
  InternalCleanNode(ParentNode);
349
 
end;
350
 
 
351
 
procedure TXMLConfig.DeleteValue(const APath: string);
352
 
var
353
 
  Node: TDomNode;
354
 
  StartPos: integer;
355
 
  NodeName: string;
356
 
begin
357
 
  Node:=FindNode(APath,true);
358
 
  if (Node=nil) then exit;
359
 
  StartPos:=length(APath);
360
 
  while (StartPos>0) and (APath[StartPos]<>'/') do dec(StartPos);
361
 
  NodeName:=copy(APath,StartPos+1,length(APath)-StartPos);
362
 
  if Assigned(TDOMElement(Node).GetAttributeNode(NodeName)) then begin
363
 
    TDOMElement(Node).RemoveAttribute(NodeName);
364
 
    FModified := True;
365
 
  end;
366
 
  InternalCleanNode(Node);
367
 
end;
368
 
 
369
 
procedure TXMLConfig.Loaded;
370
 
begin
371
 
  inherited Loaded;
372
 
  if Length(Filename) > 0 then
373
 
    SetFilename(Filename);              // Load the XML config file
374
 
end;
375
 
 
376
 
function TXMLConfig.FindNode(const APath: String;
377
 
  PathHasValue: boolean): TDomNode;
378
 
var
379
 
  PathLen: Integer;
380
 
begin
381
 
  PathLen:=length(APath);
382
 
  if PathHasValue then begin
383
 
    while (PathLen>0) and (APath[PathLen]<>'/') do dec(PathLen);
384
 
    while (PathLen>0) and (APath[PathLen]='/') do dec(PathLen);
385
 
  end;
386
 
  Result:=InternalFindNode(APath,PathLen);
387
 
end;
388
 
 
389
 
function TXMLConfig.HasPath(const APath: string; PathHasValue: boolean
390
 
  ): boolean;
391
 
begin
392
 
  Result:=FindNode(APath,PathHasValue)<>nil;
393
 
end;
394
 
 
395
 
function TXMLConfig.HasChildPaths(const APath: string): boolean;
396
 
var
397
 
  Node: TDOMNode;
398
 
begin
399
 
  Node:=FindNode(APath,false);
400
 
  Result:=(Node<>nil) and Node.HasChildNodes;
401
 
end;
402
 
 
403
 
procedure TXMLConfig.InvalidatePathCache;
404
 
begin
405
 
  fPathCache:='';
406
 
  InvalidateCacheTilEnd(0);
407
 
end;
408
 
 
409
 
function TXMLConfig.ExtendedToStr(const e: extended): string;
410
 
var
411
 
  OldDecimalSeparator: Char;
412
 
  OldThousandSeparator: Char;
413
 
begin
414
 
  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
415
 
  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
416
 
  DefaultFormatSettings.DecimalSeparator:='.';
417
 
  DefaultFormatSettings.ThousandSeparator:=',';
418
 
  Result:=FloatToStr(e);
419
 
  DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
420
 
  DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
421
 
end;
422
 
 
423
 
function TXMLConfig.StrToExtended(const s: string; const ADefault: extended): extended;
424
 
var
425
 
  OldDecimalSeparator: Char;
426
 
  OldThousandSeparator: Char;
427
 
begin
428
 
  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
429
 
  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
430
 
  DefaultFormatSettings.DecimalSeparator:='.';
431
 
  DefaultFormatSettings.ThousandSeparator:=',';
432
 
  Result:=StrToFloatDef(s,ADefault);
433
 
  DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
434
 
  DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
435
 
end;
436
 
 
437
 
procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String
438
 
  );
439
 
begin
440
 
  InvalidatePathCache;
441
 
  {$IFDEF NewXMLCfg}
442
 
  Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags);
443
 
  {$ELSE}
444
 
  Laz_XMLRead.ReadXMLFile(ADoc,AFilename);
445
 
  {$ENDIF}
446
 
end;
447
 
 
448
 
procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
449
 
begin
450
 
  {$IFDEF NewXMLCfg}
451
 
  Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName);
452
 
  {$ELSE}
453
 
  Laz_XMLWrite.WriteXMLFile(ADoc,AFileName);
454
 
  {$ENDIF}
455
 
  InvalidateFileStateCache(AFileName);
456
 
end;
457
 
 
458
 
procedure TXMLConfig.FreeDoc;
459
 
begin
460
 
  InvalidatePathCache;
461
 
  FreeAndNil(doc);
462
 
end;
463
 
 
464
 
procedure TXMLConfig.SetPathNodeCache(Index: integer; Node: TDomNode);
465
 
var
466
 
  OldLength: Integer;
467
 
  i: LongInt;
468
 
  NewSize: Integer;
469
 
begin
470
 
  OldLength:=length(fPathNodeCache);
471
 
  if OldLength<=Index then begin
472
 
    NewSize:=OldLength*2+4;
473
 
    if NewSize<Index then NewSize:=Index;
474
 
    SetLength(fPathNodeCache,NewSize);
475
 
    for i:=OldLength to length(fPathNodeCache)-1 do
476
 
      fPathNodeCache[i]:=nil;
477
 
  end;
478
 
  fPathNodeCache[Index]:=Node;
479
 
end;
480
 
 
481
 
function TXMLConfig.GetPathNodeCache(Index: integer): TDomNode;
482
 
begin
483
 
  if Index<length(fPathNodeCache) then
484
 
    Result:=fPathNodeCache[Index]
485
 
  else
486
 
    Result:=nil;
487
 
end;
488
 
 
489
 
procedure TXMLConfig.InvalidateCacheTilEnd(StartIndex: integer);
490
 
var
491
 
  i: LongInt;
492
 
begin
493
 
  for i:=StartIndex to length(fPathNodeCache)-1 do begin
494
 
    if fPathNodeCache[i]=nil then break;
495
 
    fPathNodeCache[i]:=nil;
496
 
  end;
497
 
end;
498
 
 
499
 
function TXMLConfig.InternalFindNode(const APath: String; PathLen: integer;
500
 
  CreateNodes: boolean): TDomNode;
501
 
var
502
 
  NodePath: String;
503
 
  StartPos, EndPos: integer;
504
 
  PathIndex: Integer;
505
 
  Parent: TDOMNode;
506
 
  NameLen: Integer;
507
 
begin
508
 
  //debugln(['TXMLConfig.InternalFindNode APath="',copy(APath,1,PathLen),'" CreateNodes=',CreateNodes]);
509
 
  PathIndex:=0;
510
 
  Result:=GetPathNodeCache(PathIndex);
511
 
  if Result=nil then begin
512
 
    Result := TDOMElement(doc.FindNode('CONFIG'));
513
 
    SetPathNodeCache(PathIndex,Result);
514
 
  end;
515
 
  if PathLen=0 then exit;
516
 
  StartPos:=1;
517
 
  while (Result<>nil) do begin
518
 
    EndPos:=StartPos;
519
 
    while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
520
 
    NameLen:=EndPos-StartPos;
521
 
    if NameLen=0 then break;
522
 
    inc(PathIndex);
523
 
    Parent:=Result;
524
 
    Result:=GetPathNodeCache(PathIndex);
525
 
    if (Result<>nil) and (length(Result.NodeName)=NameLen)
526
 
    and CompareMem(PChar(Result.NodeName),@APath[StartPos],NameLen) then begin
527
 
      // cache valid
528
 
    end else begin
529
 
      // different path => search
530
 
      InvalidateCacheTilEnd(PathIndex);
531
 
      NodePath:=copy(APath,StartPos,NameLen);
532
 
      Result:=Parent.FindNode(NodePath);
533
 
      if Result=nil then begin
534
 
        if not CreateNodes then exit;
535
 
        // create missing node
536
 
        Result := Doc.CreateElement(NodePath);
537
 
        Parent.AppendChild(Result);
538
 
        if EndPos>PathLen then exit;
539
 
      end;
540
 
      SetPathNodeCache(PathIndex,Result);
541
 
    end;
542
 
    StartPos:=EndPos+1;
543
 
    if StartPos>PathLen then exit;
544
 
  end;
545
 
  Result:=nil;
546
 
end;
547
 
 
548
 
procedure TXMLConfig.InternalCleanNode(Node: TDomNode);
549
 
var
550
 
  ParentNode: TDOMNode;
551
 
begin
552
 
  if (Node=nil) then exit;
553
 
  while (Node.FirstChild=nil) and (Node.ParentNode<>nil)
554
 
  and (Node.ParentNode.ParentNode<>nil) do begin
555
 
    if (Node is TDOMElement) and (not TDOMElement(Node).IsEmpty) then break;
556
 
    ParentNode:=Node.ParentNode;
557
 
    ParentNode.RemoveChild(Node);
558
 
    InvalidatePathCache;
559
 
    Node:=ParentNode;
560
 
    FModified := True;
561
 
  end;
562
 
end;
563
 
 
564
 
procedure TXMLConfig.SetFilename(const AFilename: String);
565
 
var
566
 
  cfg: TDOMElement;
567
 
  ms: TMemoryStream;
568
 
begin
569
 
  {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
570
 
  if FFilename = AFilename then exit;
571
 
  FFilename := AFilename;
572
 
  InvalidatePathCache;
573
 
 
574
 
  if csLoading in ComponentState then
575
 
    exit;
576
 
 
577
 
  if Assigned(doc) then
578
 
  begin
579
 
    Flush;
580
 
    FreeDoc;
581
 
  end;
582
 
 
583
 
  doc:=nil;
584
 
  //debugln(['TXMLConfig.SetFilename ',not fDoNotLoadFromFile,' ',FileExistsCached(Filename)]);
585
 
  if (not fDoNotLoadFromFile) and FileExistsCached(Filename) then
586
 
    ReadXMLFile(doc,Filename)
587
 
  else if fAutoLoadFromSource<>'' then begin
588
 
    ms:=TMemoryStream.Create;
589
 
    try
590
 
      ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
591
 
      ms.Position:=0;
592
 
      {$IFDEF NewXMLCfg}
593
 
      Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags);
594
 
      {$ELSE}
595
 
      Laz_XMLRead.ReadXMLFile(doc,ms);
596
 
      {$ENDIF}
597
 
    finally
598
 
      ms.Free;
599
 
    end;
600
 
  end;
601
 
 
602
 
  if not Assigned(doc) then
603
 
    doc := TXMLDocument.Create;
604
 
 
605
 
  cfg :=TDOMElement(doc.FindNode('CONFIG'));
606
 
  //debugln(['TXMLConfig.SetFilename ',DbgSName(cfg)]);
607
 
  if not Assigned(cfg) then begin
608
 
    cfg := doc.CreateElement('CONFIG');
609
 
    doc.AppendChild(cfg);
610
 
  end;
611
 
  {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF}
612
 
end;
613
 
 
614
 
 
615
 
end.