1 {
2  **********************************************************************
3   This file is part of LazUtils.
4   It is copied from Free Component Library and adapted to use
5   UTF8 strings instead of widestrings.
6 
7   See the file COPYING.modifiedLGPL.txt, included in this distribution,
8   for details about the license.
9  **********************************************************************
10 
11   Implementation of TXMLConfig class
12   Copyright (c) 1999 - 2001 by Sebastian Guenther, sg@freepascal.org
13 
14   TXMLConfig enables applications to use XML files for storing their
15   configuration data
16 }
17 
18 {$MODE objfpc}
19 {$modeswitch advancedrecords}
20 {$H+}
21 
22 unit Laz2_XMLCfg;
23 
24 interface
25 
26 {off $DEFINE MEM_CHECK}
27 
28 uses
29   {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
30   Classes, sysutils, LazFileCache,
31   Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite, LazUtilities,
32   typinfo;
33 
34 type
35 
36   {"APath" is the path and name of a value: A XML configuration file is
37    hierachical. "/" is the path delimiter, the part after the last "/"
38    is the name of the value. The path components will be mapped to XML
39    elements, the name will be an element attribute.}
40 
41   { TXMLConfig }
42 
43   TXMLConfig = class(TComponent)
44   private
45     FFilename: String;
46     FReadFlags: TXMLReaderFlags;
47     FWriteFlags: TXMLWriterFlags;
48     FPointSettings: TFormatSettings;
49     procedure CreateConfigNode;
50     procedure InitFormatSettings;
51     procedure SetFilename(const AFilename: String);
52   protected
53     type
54       TDomNodeArray = array of TDomNode;
55       TNodeCache = record
56         Node: TDomNode;
57         NodeSearchName: string;
58         ChildrenValid: boolean;
59         Children: TDomNodeArray; // child nodes with NodeName<>'' and sorted
60 
61         NodeListName: string;
62         NodeList: TDomNodeArray; // child nodes that are accessed with "name[?]" XPath
63 
64       public
65         class procedure GrowArray(var aArray: TDomNodeArray; aCount: Integer); static;
66         procedure RefreshChildren;
67         procedure RefreshChildrenIfNeeded;
68         procedure RefreshNodeList(const ANodeName: string);
69         procedure RefreshNodeListIfNeeded(const ANodeName: string);
AddNodeToListnull70         function AddNodeToList: TDOMNode;
71       end;
72   protected
73     doc: TXMLDocument;
74     FModified: Boolean;
75     fDoNotLoadFromFile: boolean;
76     fAutoLoadFromSource: string;
77     fPathCache: string;
78     fPathNodeCache: array of TNodeCache; // starting with doc.DocumentElement, then first child node of first sub path
79     procedure Loaded; override;
ExtendedToStrnull80     function ExtendedToStr(const e: extended): string;
StrToExtendednull81     function StrToExtended(const s: string; const ADefault: extended): extended;
82     procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); virtual;
83     procedure WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); virtual;
84     procedure FreeDoc; virtual;
85     procedure SetPathNodeCache(Index: integer; aNode: TDomNode; aNodeSearchName: string = '');
GetCachedPathNodenull86     function GetCachedPathNode(Index: integer): TDomNode; inline;
GetCachedPathNodenull87     function GetCachedPathNode(Index: integer; out aNodeSearchName: string): TDomNode; inline;
88     procedure InvalidateCacheTilEnd(StartIndex: integer);
InternalFindNodenull89     function InternalFindNode(const APath: String; PathLen: integer;
90                               CreateNodes: boolean = false): TDomNode;
91     procedure InternalCleanNode(Node: TDomNode);
FindChildNodenull92     function FindChildNode(PathIndex: integer; const aName: string;
93       CreateNodes: boolean = false): TDomNode;
94   public
95     constructor Create(AOwner: TComponent); override; overload;
96     constructor Create(const AFilename: String); overload; // create and load
97     constructor CreateClean(const AFilename: String); // create new
98     constructor CreateWithSource(const AFilename, Source: String); // create new and load from Source
99     destructor Destroy; override;
100     procedure Clear;
101     procedure Flush;    // Writes the XML file
102     procedure ReadFromStream(s: TStream);
103     procedure WriteToStream(s: TStream);
104 
GetValuenull105     function  GetValue(const APath, ADefault: String): String;
GetValuenull106     function  GetValue(const APath: String; ADefault: Integer): Integer;
GetValuenull107     function  GetValue(const APath: String; ADefault: Int64): Int64;
GetValuenull108     function  GetValue(const APath: String; ADefault: Boolean): Boolean;
GetExtendedValuenull109     function  GetExtendedValue(const APath: String;
110                                const ADefault: extended): extended;
111     procedure SetValue(const APath, AValue: String);
112     procedure SetDeleteValue(const APath, AValue, DefValue: String);
113     procedure SetValue(const APath: String; AValue: Int64);
114     procedure SetDeleteValue(const APath: String; AValue, DefValue: Int64);
115     procedure SetValue(const APath: String; AValue: Boolean);
116     procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
117     procedure GetValue(const APath: String; out ARect: TRect;
118                        const ADefault: TRect);
119     procedure SetDeleteValue(const APath: String; const AValue, DefValue: TRect);
120     procedure SetExtendedValue(const APath: String; const AValue: extended);
121     procedure SetDeleteExtendedValue(const APath: String;
122                                      const AValue, DefValue: extended);
123     procedure DeletePath(const APath: string);
124     procedure DeleteValue(const APath: string);
FindNodenull125     function FindNode(const APath: String; PathHasValue: boolean): TDomNode;
126     // checks if the path has values, set PathHasValue=true to skip the last part
HasPathnull127     function HasPath(const APath: string; PathHasValue: boolean): boolean;
HasChildPathsnull128     function HasChildPaths(const APath: string): boolean;
GetChildCountnull129     function GetChildCount(const APath: string): Integer;
IsLegacyListnull130     function IsLegacyList(const APath: string): Boolean;
GetListItemCountnull131     function GetListItemCount(const APath, AItemName: string; const aLegacyList: Boolean): Integer;
GetListItemXPathnull132     class function GetListItemXPath(const AName: string; const AIndex: Integer; const aLegacyList: Boolean;
133       const aLegacyList1Based: Boolean = False): string;
134     procedure SetListItemCount(const APath: string; const ACount: Integer; const ALegacyList: Boolean);
135     property Modified: Boolean read FModified write FModified;
136     procedure InvalidatePathCache;
137   published
138     property Filename: String read FFilename write SetFilename;
139     property Document: TXMLDocument read doc;
140     property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags;
141     property WriteFlags: TXMLWriterFlags read FWriteFlags write FWriteFlags;
142   end;
143 
144   { TRttiXMLConfig }
145 
146   TRttiXMLConfig = class(TXMLConfig)
147   protected
148     procedure WriteProperty(Path: String; Instance: TPersistent;
149                             PropInfo: Pointer; DefInstance: TPersistent = nil;
150                             OnlyProperty: String= '');
151     procedure ReadProperty(Path: String; Instance: TPersistent;
152                             PropInfo: Pointer; DefInstance: TPersistent = nil;
153                             OnlyProperty: String= '');
154   public
155     procedure WriteObject(Path: String; Obj: TPersistent;
156                           DefObject: TPersistent= nil; OnlyProperty: String= '');
157     procedure ReadObject(Path: String; Obj: TPersistent;
158                           DefObject: TPersistent= nil; OnlyProperty: String= '');
159   end;
160 
161 
162 // ===================================================================
163 
CompareDomNodeNamesnull164 function CompareDomNodeNames(DOMNode1, DOMNode2: Pointer): integer;
165 
166 implementation
167 
CompareDomNodeNamesnull168 function CompareDomNodeNames(DOMNode1, DOMNode2: Pointer): integer;
169 var
170   Node1: TDOMNode absolute DomNode1;
171   Node2: TDOMNode absolute DomNode2;
172 begin
173   Result:=CompareStr(Node1.NodeName,Node2.NodeName);
174 end;
175 
176 { TXMLConfig.TNodeCache }
177 
TXMLConfig.TNodeCache.AddNodeToListnull178 function TXMLConfig.TNodeCache.AddNodeToList: TDOMNode;
179 begin
180   Result:=Node.OwnerDocument.CreateElement(NodeListName);
181   Node.AppendChild(Result);
182   SetLength(NodeList, Length(NodeList)+1);
183   NodeList[High(NodeList)]:=Result;
184 end;
185 
186 class procedure TXMLConfig.TNodeCache.GrowArray(var aArray: TDomNodeArray;
187   aCount: Integer);
188 var
189   cCount: Integer;
190 begin
191   cCount:=length(aArray);
192   if aCount>cCount then begin
193     if cCount<8 then
194       cCount:=8
195     else
196       cCount:=cCount*2;
197     if aCount>cCount then
198       cCount := aCount;
199     SetLength(aArray,cCount);
200   end;
201 end;
202 
203 procedure TXMLConfig.TNodeCache.RefreshChildren;
204 var
205   aCount, m: Integer;
206   aChild: TDOMNode;
207 begin
208   // collect all children and sort
209   aCount:=0;
210   aChild:=Node.FirstChild;
211   while aChild<>nil do begin
212     if aChild.NodeName<>'' then begin
213       GrowArray(Children, aCount+1);
214       Children[aCount]:=aChild;
215       inc(aCount);
216     end;
217     aChild:=aChild.NextSibling;
218   end;
219   SetLength(Children,aCount);
220   if aCount>1 then
221     MergeSortWithLen(@Children[0],aCount,@CompareDomNodeNames); // sort ascending [0]<[1]
222   for m:=0 to aCount-2 do
223     if Children[m].NodeName=Children[m+1].NodeName then begin
224       // duplicate found: nodes with same name
225       // -> use only the first
226       Children[m+1]:=Children[m];
227     end;
228   ChildrenValid:=true;
229 end;
230 
231 procedure TXMLConfig.TNodeCache.RefreshChildrenIfNeeded;
232 begin
233   if not ChildrenValid then
234     RefreshChildren;
235 end;
236 
237 procedure TXMLConfig.TNodeCache.RefreshNodeList(const ANodeName: string);
238 var
239   aCount: Integer;
240   aChild: TDOMNode;
241 begin
242   aCount:=0;
243   aChild:=Node.FirstChild;
244   while aChild<>nil do
245   begin
246     if aChild.NodeName=ANodeName then
247     begin
248       GrowArray(NodeList, aCount+1);
249       NodeList[aCount]:=aChild;
250       inc(aCount);
251     end;
252     aChild:=aChild.NextSibling;
253   end;
254   SetLength(NodeList,aCount);
255   NodeListName := ANodeName;
256 end;
257 
258 procedure TXMLConfig.TNodeCache.RefreshNodeListIfNeeded(const ANodeName: string
259   );
260 begin
261   if NodeListName<>ANodeName then
262     RefreshNodeList(ANodeName);
263 end;
264 
265 // inline
TXMLConfig.GetCachedPathNodenull266 function TXMLConfig.GetCachedPathNode(Index: integer; out
267   aNodeSearchName: string): TDomNode;
268 begin
269   if Index<length(fPathNodeCache) then
270   begin
271     Result:=fPathNodeCache[Index].Node;
272     aNodeSearchName:=fPathNodeCache[Index].NodeSearchName;
273   end else
274   begin
275     Result:=nil;
276     aNodeSearchName:='';
277   end;
278 end;
279 
GetChildCountnull280 function TXMLConfig.GetChildCount(const APath: string): Integer;
281 var
282   Node: TDOMNode;
283 begin
284   Node:=FindNode(APath,false);
285   if Node=nil then
286     Result := 0
287   else
288     Result := Node.GetChildCount;
289 end;
290 
291 constructor TXMLConfig.Create(const AFilename: String);
292 begin
293   //DebugLn(['TXMLConfig.Create ',AFilename]);
294   Create(nil);
295   SetFilename(AFilename);
296 end;
297 
298 constructor TXMLConfig.CreateClean(const AFilename: String);
299 begin
300   //DebugLn(['TXMLConfig.CreateClean ',AFilename]);
301   fDoNotLoadFromFile:=true;
302   Create(AFilename);
303   FModified:=FileExistsCached(AFilename);
304 end;
305 
306 constructor TXMLConfig.CreateWithSource(const AFilename, Source: String);
307 begin
308   fAutoLoadFromSource:=Source;
309   try
310     CreateClean(AFilename);
311   finally
312     fAutoLoadFromSource:='';
313   end;
314 end;
315 
316 destructor TXMLConfig.Destroy;
317 begin
318   if Assigned(doc) then
319   begin
320     Flush;
321     FreeDoc;
322   end;
323   inherited Destroy;
324 end;
325 
326 procedure TXMLConfig.Clear;
327 var
328   cfg: TDOMElement;
329 begin
330   // free old document
331   FreeDoc;
332   // create new document
333   doc := TXMLDocument.Create;
334   cfg :=TDOMElement(doc.FindNode('CONFIG'));
335   if not Assigned(cfg) then begin
336     cfg := doc.CreateElement('CONFIG');
337     doc.AppendChild(cfg);
338   end;
339 end;
340 
341 procedure TXMLConfig.Flush;
342 begin
343   if Modified and (Filename<>'') then
344   begin
345     //DebugLn(['TXMLConfig.Flush ',Filename]);
346     WriteXMLFile(Doc,Filename);
347     FModified := False;
348   end;
349 end;
350 
351 procedure TXMLConfig.ReadFromStream(s: TStream);
352 begin
353   FreeDoc;
354   Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags);
355   if Doc=nil then
356     Clear;
357 end;
358 
359 procedure TXMLConfig.WriteToStream(s: TStream);
360 begin
361   if Doc=nil then
362     CreateConfigNode;
363   Laz2_XMLWrite.WriteXMLFile(Doc,s,WriteFlags);
364 end;
365 
TXMLConfig.GetValuenull366 function TXMLConfig.GetValue(const APath, ADefault: String): String;
367 var
368   Node, Attr: TDOMNode;
369   NodeName: String;
370   StartPos: integer;
371 begin
372   //CheckHeapWrtMemCnt('TXMLConfig.GetValue A '+APath);
373   Result:=ADefault;
374 
375   // skip root
376   StartPos:=length(APath)+1;
377   while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
378   if StartPos>length(APath) then exit;
379   // find sub node
380   Node:=InternalFindNode(APath,StartPos-1);
381   if Node=nil then
382     exit;
383   //CheckHeapWrtMemCnt('TXMLConfig.GetValue E');
384   NodeName:=copy(APath,StartPos,length(APath));
385   //CheckHeapWrtMemCnt('TXMLConfig.GetValue G');
386   Attr := Node.Attributes.GetNamedItem(NodeName);
387   if Assigned(Attr) then
388     Result := Attr.NodeValue;
389   //writeln('TXMLConfig.GetValue END Result="',Result,'"');
390 end;
391 
TXMLConfig.GetValuenull392 function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
393 begin
394   Result := StrToIntDef(GetValue(APath, ''),ADefault);
395 end;
396 
TXMLConfig.GetValuenull397 function TXMLConfig.GetValue(const APath: String; ADefault: Int64): Int64;
398 begin
399   Result := StrToInt64Def(GetValue(APath, ''),ADefault);
400 end;
401 
402 procedure TXMLConfig.GetValue(const APath: String; out ARect: TRect;
403   const ADefault: TRect);
404 begin
405   ARect.Left:=GetValue(APath+'Left',ADefault.Left);
406   ARect.Top:=GetValue(APath+'Top',ADefault.Top);
407   ARect.Right:=GetValue(APath+'Right',ADefault.Right);
408   ARect.Bottom:=GetValue(APath+'Bottom',ADefault.Bottom);
409 end;
410 
TXMLConfig.GetValuenull411 function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean;
412 var
413   s: String;
414 begin
415   s := GetValue(APath, '');
416 
417   if SameText(s, 'True') then
418     Result := True
419   else if SameText(s, 'False') then
420     Result := False
421   else
422     Result := ADefault;
423 end;
424 
TXMLConfig.GetExtendedValuenull425 function TXMLConfig.GetExtendedValue(const APath: String;
426   const ADefault: extended): extended;
427 begin
428   Result:=StrToExtended(GetValue(APath,''),ADefault);
429 end;
430 
TXMLConfig.GetListItemCountnull431 function TXMLConfig.GetListItemCount(const APath, AItemName: string;
432   const aLegacyList: Boolean): Integer;
433 var
434   Node: TDOMNode;
435   NodeLevel: SizeInt;
436 begin
437   if aLegacyList then
438     Result := GetValue(APath+'Count',0)
439   else
440   begin
441     Node:=InternalFindNode(APath,Length(APath));
442     if Node<>nil then
443     begin
444       NodeLevel := Node.GetLevel-1;
445       fPathNodeCache[NodeLevel].RefreshNodeListIfNeeded(AItemName);
446       Result := Length(fPathNodeCache[NodeLevel].NodeList);
447     end else
448       Result := 0;
449   end;
450 end;
451 
TXMLConfig.GetListItemXPathnull452 class function TXMLConfig.GetListItemXPath(const AName: string;
453   const AIndex: Integer; const aLegacyList: Boolean;
454   const aLegacyList1Based: Boolean): string;
455 begin
456   if ALegacyList then
457   begin
458     if aLegacyList1Based then
459       Result := AName+IntToStr(AIndex+1)
460     else
461       Result := AName+IntToStr(AIndex);
462   end else
463     Result := AName+'['+IntToStr(AIndex+1)+']';
464 end;
465 
466 procedure TXMLConfig.SetValue(const APath, AValue: String);
467 var
468   Node: TDOMNode;
469   NodeName: String;
470   StartPos: integer;
471 begin
472   StartPos:=length(APath)+1;
473   while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
474   if StartPos>length(APath) then exit;
475   if Doc=nil then
476     CreateConfigNode;
477   Node:=InternalFindNode(APath,StartPos-1,true);
478   if Node=nil then
479     exit;
480   NodeName:=copy(APath,StartPos,length(APath));
481   if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or
482     (TDOMElement(Node)[NodeName] <> AValue) then
483   begin
484     TDOMElement(Node)[NodeName] := AValue;
485     FModified := True;
486   end;
487 end;
488 
489 procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String);
490 begin
491   if AValue=DefValue then
492     DeleteValue(APath)
493   else
494     SetValue(APath,AValue);
495 end;
496 
497 procedure TXMLConfig.SetValue(const APath: String; AValue: Int64);
498 begin
499   SetValue(APath, IntToStr(AValue));
500 end;
501 
502 procedure TXMLConfig.SetDeleteValue(const APath: String; AValue, DefValue: Int64
503   );
504 begin
505   if AValue=DefValue then
506     DeleteValue(APath)
507   else
508     SetValue(APath,AValue);
509 end;
510 
511 procedure TXMLConfig.SetDeleteValue(const APath: String; const AValue,
512   DefValue: TRect);
513 begin
514   SetDeleteValue(APath+'Left',AValue.Left,DefValue.Left);
515   SetDeleteValue(APath+'Top',AValue.Top,DefValue.Top);
516   SetDeleteValue(APath+'Right',AValue.Right,DefValue.Right);
517   SetDeleteValue(APath+'Bottom',AValue.Bottom,DefValue.Bottom);
518 end;
519 
520 procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
521 begin
522   if AValue then
523     SetValue(APath, 'True')
524   else
525     SetValue(APath, 'False');
526 end;
527 
528 procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
529   DefValue: Boolean);
530 begin
531   if AValue=DefValue then
532     DeleteValue(APath)
533   else
534     SetValue(APath,AValue);
535 end;
536 
537 procedure TXMLConfig.SetExtendedValue(const APath: String;
538   const AValue: extended);
539 begin
540   SetValue(APath,ExtendedToStr(AValue));
541 end;
542 
543 procedure TXMLConfig.SetDeleteExtendedValue(const APath: String; const AValue,
544   DefValue: extended);
545 begin
546   if AValue=DefValue then
547     DeleteValue(APath)
548   else
549     SetExtendedValue(APath,AValue);
550 end;
551 
552 procedure TXMLConfig.DeletePath(const APath: string);
553 var
554   Node: TDOMNode;
555   ParentNode: TDOMNode;
556 begin
557   Node:=InternalFindNode(APath,length(APath));
558   if (Node=nil) or (Node.ParentNode=nil) then exit;
559   ParentNode:=Node.ParentNode;
560   ParentNode.RemoveChild(Node);
561   FModified:=true;
562   InvalidatePathCache;
563   InternalCleanNode(ParentNode);
564 end;
565 
566 procedure TXMLConfig.DeleteValue(const APath: string);
567 var
568   Node: TDomNode;
569   StartPos: integer;
570   NodeName: string;
571 begin
572   Node:=FindNode(APath,true);
573   if (Node=nil) then exit;
574   StartPos:=length(APath);
575   while (StartPos>0) and (APath[StartPos]<>'/') do dec(StartPos);
576   NodeName:=copy(APath,StartPos+1,length(APath)-StartPos);
577   if Assigned(TDOMElement(Node).GetAttributeNode(NodeName)) then begin
578     TDOMElement(Node).RemoveAttribute(NodeName);
579     FModified := True;
580   end;
581   InternalCleanNode(Node);
582 end;
583 
584 procedure TXMLConfig.Loaded;
585 begin
586   inherited Loaded;
587   if Length(Filename) > 0 then
588     SetFilename(Filename);              // Load the XML config file
589 end;
590 
FindNodenull591 function TXMLConfig.FindNode(const APath: String; PathHasValue: boolean): TDomNode;
592 var
593   PathLen: Integer;
594 begin
595   PathLen:=length(APath);
596   if PathHasValue then begin
597     while (PathLen>0) and (APath[PathLen]<>'/') do dec(PathLen);
598     while (PathLen>0) and (APath[PathLen]='/') do dec(PathLen);
599   end;
600   Result:=InternalFindNode(APath,PathLen);
601 end;
602 
TXMLConfig.HasPathnull603 function TXMLConfig.HasPath(const APath: string; PathHasValue: boolean): boolean;
604 begin
605   Result:=FindNode(APath,PathHasValue)<>nil;
606 end;
607 
TXMLConfig.HasChildPathsnull608 function TXMLConfig.HasChildPaths(const APath: string): boolean;
609 var
610   Node: TDOMNode;
611 begin
612   Node:=FindNode(APath,false);
613   Result:=(Node<>nil) and Node.HasChildNodes;
614 end;
615 
616 procedure TXMLConfig.InvalidatePathCache;
617 begin
618   fPathCache:='';
619   InvalidateCacheTilEnd(0);
620 end;
621 
TXMLConfig.IsLegacyListnull622 function TXMLConfig.IsLegacyList(const APath: string): Boolean;
623 begin
624   Result := GetValue(APath+'Count',-1)>=0;
625 end;
626 
ExtendedToStrnull627 function TXMLConfig.ExtendedToStr(const e: extended): string;
628 begin
629   Result := FloatToStr(e, FPointSettings);
630 end;
631 
TXMLConfig.StrToExtendednull632 function TXMLConfig.StrToExtended(const s: string; const ADefault: extended): extended;
633 begin
634   Result := StrToFloatDef(s, ADefault, FPointSettings);
635 end;
636 
637 procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String);
638 begin
639   InvalidatePathCache;
640   Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags);
641 end;
642 
643 procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
644 begin
645   Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName,WriteFlags);
646   InvalidateFileStateCache(AFileName);
647 end;
648 
649 procedure TXMLConfig.FreeDoc;
650 begin
651   InvalidatePathCache;
652   FreeAndNil(doc);
653 end;
654 
TXMLConfig.GetCachedPathNodenull655 function TXMLConfig.GetCachedPathNode(Index: integer): TDomNode;
656 var
657   x: string;
658 begin
659   Result := GetCachedPathNode(Index, x);
660 end;
661 
662 procedure TXMLConfig.SetPathNodeCache(Index: integer; aNode: TDomNode;
663   aNodeSearchName: string);
664 var
665   OldLength, NewLength: Integer;
666 begin
667   OldLength:=length(fPathNodeCache);
668   if OldLength<=Index then begin
669     if OldLength<8 then
670       NewLength:=8
671     else
672       NewLength:=OldLength*2;
673     if NewLength<Index then NewLength:=Index;
674     SetLength(fPathNodeCache,NewLength);
675     FillByte(fPathNodeCache[OldLength],SizeOf(TNodeCache)*(NewLength-OldLength),0);
676   end else if fPathNodeCache[Index].Node=aNode then
677     exit
678   else
679     InvalidateCacheTilEnd(Index+1);
680   if aNodeSearchName='' then
681     aNodeSearchName:=aNode.NodeName;
682   with fPathNodeCache[Index] do begin
683     Node:=aNode;
684     NodeSearchName:=aNodeSearchName;
685     ChildrenValid:=false;
686     NodeListName:='';
687   end;
688 end;
689 
690 procedure TXMLConfig.InvalidateCacheTilEnd(StartIndex: integer);
691 var
692   i: LongInt;
693 begin
694   for i:=StartIndex to length(fPathNodeCache)-1 do begin
695     with fPathNodeCache[i] do begin
696       if Node=nil then break;
697       Node:=nil;
698       ChildrenValid:=false;
699       NodeListName:='';
700     end;
701   end;
702 end;
703 
TXMLConfig.InternalFindNodenull704 function TXMLConfig.InternalFindNode(const APath: String; PathLen: integer;
705   CreateNodes: boolean): TDomNode;
706 var
707   NodePath, NdName: String;
708   StartPos, EndPos: integer;
709   PathIndex: Integer;
710   NameLen: Integer;
711 begin
712   //debugln(['TXMLConfig.InternalFindNode APath="',copy(APath,1,PathLen),'" CreateNodes=',CreateNodes]);
713   PathIndex:=0;
714   Result:=GetCachedPathNode(PathIndex);
715   if (Result=nil) and (doc<>nil) then begin
716     Result:=TDOMElement(doc.FindNode('CONFIG'));
717     SetPathNodeCache(PathIndex,Result);
718   end;
719   if PathLen=0 then exit;
720   StartPos:=1;
721   while (Result<>nil) do begin
722     EndPos:=StartPos;
723     while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
724     NameLen:=EndPos-StartPos;
725     if NameLen=0 then break;
726     inc(PathIndex);
727     Result:=GetCachedPathNode(PathIndex,NdName);
728     if (Result=nil) or (length(NdName)<>NameLen)
729     or not CompareMem(PChar(NdName),@APath[StartPos],NameLen) then begin
730       // different path => search
731       NodePath:=copy(APath,StartPos,NameLen);
732       Result:=FindChildNode(PathIndex-1,NodePath,CreateNodes);
733       if Result=nil then
734         Exit;
735       SetPathNodeCache(PathIndex,Result,NodePath);
736     end;
737     StartPos:=EndPos+1;
738     if StartPos>PathLen then exit;
739   end;
740   Result:=nil;
741 end;
742 
743 procedure TXMLConfig.InternalCleanNode(Node: TDomNode);
744 var
745   ParentNode: TDOMNode;
746 begin
747   if (Node=nil) then exit;
748   while (Node.FirstChild=nil) and (Node.ParentNode<>nil)
749   and (Node.ParentNode.ParentNode<>nil) do begin
750     if (Node is TDOMElement) and (not TDOMElement(Node).IsEmpty) then break;
751     ParentNode:=Node.ParentNode;
752     ParentNode.RemoveChild(Node);
753     InvalidatePathCache;
754     Node:=ParentNode;
755     FModified := True;
756   end;
757 end;
758 
TXMLConfig.FindChildNodenull759 function TXMLConfig.FindChildNode(PathIndex: integer; const aName: string;
760   CreateNodes: boolean): TDomNode;
761 var
762   l, r, m: Integer;
763   cmp, BrPos: Integer;
764   NodeName: string;
765 begin
766   BrPos := Pos('[', aName);
767   if (Length(aName)>=BrPos+2) and (aName[Length(aName)]=']')
768   and TryStrToInt(Trim(Copy(aName, BrPos+1, Length(aName)-BrPos-1)), m) then
769   begin
770     // support XPath in format "name[?]"
771     NodeName := Trim(Copy(aName, 1, BrPos-1));
772     fPathNodeCache[PathIndex].RefreshNodeListIfNeeded(NodeName);
773     if m<=0 then
774       raise Exception.CreateFmt('Invalid node index in XPath descriptor "%s".', [aName])
775     else if (m<=Length(fPathNodeCache[PathIndex].NodeList)) then
776       Result:=fPathNodeCache[PathIndex].NodeList[m-1]
777     else if CreateNodes then
778     begin
779       for l := Length(fPathNodeCache[PathIndex].NodeList)+1 to m do
780         Result := fPathNodeCache[PathIndex].AddNodeToList;
781       InvalidateCacheTilEnd(PathIndex+1);
782     end;
783   end else
784   begin
785     fPathNodeCache[PathIndex].RefreshChildrenIfNeeded;
786 
787     // binary search
788     l:=0;
789     r:=length(fPathNodeCache[PathIndex].Children)-1;
790     while l<=r do begin
791       m:=(l+r) shr 1;
792       cmp:=CompareStr(aName,fPathNodeCache[PathIndex].Children[m].NodeName);
793       if cmp<0 then
794         r:=m-1
795       else if cmp>0 then
796         l:=m+1
797       else
798         exit(fPathNodeCache[PathIndex].Children[m]);
799     end;
800     if CreateNodes then
801     begin
802       // create missing node
803       Result:=Doc.CreateElement(aName);
804       fPathNodeCache[PathIndex].Node.AppendChild(Result);
805       fPathNodeCache[PathIndex].ChildrenValid:=false;
806       InvalidateCacheTilEnd(PathIndex+1);
807     end else
808       Result:=nil;
809   end;
810 end;
811 
812 constructor TXMLConfig.Create(AOwner: TComponent);
813 begin
814   // for compatibility with old TXMLConfig, which wrote #13 as #13, not as &xD;
815   FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
816   FWriteFlags:=[xwfSpecialCharsInAttributeValue];
817   inherited Create(AOwner);
818   InitFormatSettings;
819 end;
820 
821 procedure TXMLConfig.SetFilename(const AFilename: String);
822 var
823   ms: TMemoryStream;
824 begin
825   {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
826   if FFilename = AFilename then exit;
827   FFilename := AFilename;
828   InvalidatePathCache;
829 
830   if csLoading in ComponentState then
831     exit;
832 
833   if Assigned(doc) then
834   begin
835     Flush;
836     FreeDoc;
837   end;
838 
839   doc:=nil;
840   //debugln(['TXMLConfig.SetFilename Load=',not fDoNotLoadFromFile,' FileExists=',FileExistsCached(Filename),' File=',Filename]);
841   if (not fDoNotLoadFromFile) and FileExistsCached(Filename) then
842     Laz2_XMLRead.ReadXMLFile(doc,Filename,ReadFlags)
843   else if fAutoLoadFromSource<>'' then begin
844     ms:=TMemoryStream.Create;
845     try
846       ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
847       ms.Position:=0;
848       Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags);
849     finally
850       ms.Free;
851     end;
852   end;
853 
854   CreateConfigNode;
855   {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF}
856 end;
857 
858 procedure TXMLConfig.SetListItemCount(const APath: string;
859   const ACount: Integer; const ALegacyList: Boolean);
860 begin
861   if ALegacyList then
862     SetDeleteValue(APath+'Count',ACount,0)
863 end;
864 
865 procedure TXMLConfig.CreateConfigNode;
866 var
867   cfg: TDOMElement;
868 begin
869   if not Assigned(doc) then
870     doc := TXMLDocument.Create;
871 
872   cfg :=TDOMElement(doc.FindNode('CONFIG'));
873   if not Assigned(cfg) then begin
874     cfg := doc.CreateElement('CONFIG');
875     doc.AppendChild(cfg);
876   end;
877 end;
878 
879 procedure TXMLConfig.InitFormatSettings;
880 begin
881   FPointSettings := DefaultFormatSettings;
882   FPointSettings.DecimalSeparator := '.';
883   FPointSettings.ThousandSeparator := ',';
884 end;
885 
886 { TRttiXMLConfig }
887 
888 procedure TRttiXMLConfig.WriteObject(Path: String; Obj: TPersistent;
889   DefObject: TPersistent; OnlyProperty: String = '');
890 var
891   PropCount,i : integer;
892   PropList  : PPropList;
893 begin
894   PropCount:=GetPropList(Obj,PropList);
895   if PropCount>0 then begin
896     try
897       for i := 0 to PropCount-1 do
898         WriteProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
899     finally
900       Freemem(PropList);
901     end;
902   end;
903 end;
904 
905 // based on FPC TWriter
906 procedure TRttiXMLConfig.WriteProperty(Path: String; Instance: TPersistent;
907   PropInfo: Pointer; DefInstance: TPersistent; OnlyProperty: String= '');
908 type
909   tset = set of 0..31;
910 var
911   i: Integer;
912   PropType: PTypeInfo;
913   Value, DefValue: Int64;
914   Ident: String;
915   IntToIdentFn: TIntToIdent;
916   SetType: Pointer;
917   FloatValue, DefFloatValue: Extended;
918   //WStrValue, WDefStrValue: WideString;
919   StrValue, DefStrValue: String;
920   //Int64Value, DefInt64Value: Int64;
921   BoolValue, DefBoolValue: boolean;
922   obj: TObject;
923 
924 begin
925   // do not stream properties without getter and setter
926   if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
927           Assigned(PPropInfo(PropInfo)^.SetProc)) then
928     exit;
929 
930   PropType := PPropInfo(PropInfo)^.PropType;
931   Path := Path + PPropInfo(PropInfo)^.Name;
932   if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
933     exit;
934 
935   case PropType^.Kind of
936     tkInteger, tkChar, tkEnumeration, tkSet, tkWChar, tkInt64, tkQWord:
937       begin
938         Value := GetOrdProp(Instance, PropInfo);
939         if (DefInstance <> nil) then
940           DefValue := GetOrdProp(DefInstance, PropInfo);
941         if ((DefInstance <> nil)  and (Value = DefValue)) or
942            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
943         then
944           DeleteValue(Path)
945         else begin
946           case PropType^.Kind of
947             tkInteger:
948               begin                      // Check if this integer has a string identifier
949                 IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
950                 if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident{%H-}) then
951                   SetValue(Path, Ident) // Integer can be written a human-readable identifier
952                 else
953                   SetValue(Path, Value); // Integer has to be written just as number
954               end;
955             tkInt64,tkQWord:
956               SetValue(Path, Value); // Integer has to be written just as number
957             tkChar:
958               SetValue(Path, Chr(Value));
959             tkWChar:
960               SetValue(Path, Value);
961             tkSet:
962               begin
963                 SetType := GetTypeData(PropType)^.CompType;
964                 Ident := '';
965                 for i := 0 to 31 do
966                   if (i in tset(Integer(Value))) then begin
967                     if Ident <> '' then Ident := Ident + ',';
968                     Ident := Ident + GetEnumName(PTypeInfo(SetType), i);
969                   end;
970                 SetValue(Path, Ident);
971               end;
972             tkEnumeration:
973               SetValue(Path, GetEnumName(PropType, Value));
974           end;
975         end;
976       end;
977     tkFloat:
978       begin
979         FloatValue := GetFloatProp(Instance, PropInfo);
980         if (DefInstance <> nil) then
981          DefFloatValue := GetFloatProp(DefInstance, PropInfo);
982         if ((DefInstance <> nil)  and (DefFloatValue = FloatValue)) or
983            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
984         then
985           DeleteValue(Path)
986         else
987           SetValue(Path, FloatToStr(FloatValue));
988       end;
989     tkSString, tkLString, tkAString:
990       begin
991         StrValue := GetStrProp(Instance, PropInfo);
992         if (DefInstance <> nil) then
993            DefStrValue := GetStrProp(DefInstance, PropInfo);
994         if ((DefInstance <> nil)  and (DefStrValue = StrValue)) or
995            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
996         then
997           DeleteValue(Path)
998         else
999           SetValue(Path, StrValue);
1000       end;
1001 (*    tkWString:
1002       begin
1003         WStrValue := GetWideStrProp(Instance, PropInfo);
1004         if (DefInstance <> nil) then
1005            WDefStrValue := GetWideStrProp(DefInstance, PropInfo);
1006         if ((DefInstance <> nil)  and (WDefStrValue = WStrValue)) or
1007            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
1008         then
1009           DeleteValue(Path)
1010         else
1011           SetValue(Path, WStrValue);
1012       end;*)
1013 (*    tkInt64, tkQWord:
1014       begin
1015         Int64Value := GetInt64Prop(Instance, PropInfo);
1016         if (DefInstance <> nil) then
1017           DefInt64Value := GetInt64Prop(DefInstance, PropInfo)
1018         if ((DefInstance <> nil) and (Int64Value = DefInt64Value)) or
1019            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
1020         then
1021           DeleteValue(Path, Path)
1022         else
1023           SetValue(StrValue);
1024       end;*)
1025     tkBool:
1026       begin
1027         BoolValue := GetOrdProp(Instance, PropInfo)<>0;
1028         if (DefInstance <> nil) then
1029           DefBoolValue := GetOrdProp(DefInstance, PropInfo)<>0;
1030         if ((DefInstance <> nil) and (BoolValue = DefBoolValue)) or
1031            ((DefInstance =  nil)  and (not IsStoredProp(Instance, PropInfo)))
1032         then
1033           DeleteValue(Path)
1034         else
1035           SetValue(Path, BoolValue);
1036       end;
1037     tkClass:
1038       begin
1039         obj := GetObjectProp(Instance, PropInfo);
1040         if (obj is TPersistent) and IsStoredProp(Instance, PropInfo) then
1041           WriteObject(Path+'/', TPersistent(obj))
1042         else
1043           DeleteValue(Path);
1044       end;
1045   end;
1046 end;
1047 
1048 procedure TRttiXMLConfig.ReadProperty(Path: String; Instance: TPersistent; PropInfo: Pointer;
1049   DefInstance: TPersistent; OnlyProperty: String);
1050 type
1051   tset = set of 0..31;
1052 var
1053   i, j: Integer;
1054   PropType: PTypeInfo;
1055   Value, DefValue: Int64;
1056   IntValue: Integer;
1057   Ident, s: String;
1058   IdentToIntFn: TIdentToInt;
1059   SetType: Pointer;
1060   FloatValue, DefFloatValue: Extended;
1061   //WStrValue, WDefStrValue: WideString;
1062   StrValue, DefStrValue: String;
1063   //Int64Value, DefInt64Value: Int64;
1064   BoolValue, DefBoolValue: boolean;
1065   obj: TObject;
1066 
1067 begin
1068   // do not stream properties without getter and setter
1069   if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
1070           Assigned(PPropInfo(PropInfo)^.SetProc)) then
1071     exit;
1072 
1073   PropType := PPropInfo(PropInfo)^.PropType;
1074   Path := Path + PPropInfo(PropInfo)^.Name;
1075   if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
1076     exit;
1077   if DefInstance = nil then
1078     DefInstance := Instance;
1079 
1080   case PropType^.Kind of
1081     tkInteger, tkChar, tkEnumeration, tkSet, tkWChar, tkInt64, tkQWord:
1082       begin
1083         DefValue := GetOrdProp(DefInstance, PropInfo);
1084         case PropType^.Kind of
1085           tkInteger:
1086             begin                      // Check if this integer has a string identifier
1087               Ident := GetValue(Path, IntToStr(DefValue));
1088               IdentToIntFn := FindIdentToInt(PPropInfo(PropInfo)^.PropType);
1089               if TryStrToInt(Ident, IntValue) then
1090                 SetOrdProp(Instance, PropInfo, IntValue)
1091               else if Assigned(IdentToIntFn) and IdentToIntFn(Ident, IntValue) then
1092                 SetOrdProp(Instance, PropInfo, IntValue)
1093               else
1094                 SetOrdProp(Instance, PropInfo, DefValue)
1095             end;
1096           tkInt64,tkQWord:
1097             begin                      // Check if this integer has a string identifier
1098               Ident := GetValue(Path, IntToStr(DefValue));
1099               if TryStrToInt64(Ident, Value) then
1100                 SetOrdProp(Instance, PropInfo, Value)
1101               else
1102                 SetOrdProp(Instance, PropInfo, DefValue)
1103             end;
1104           tkChar:
1105             begin
1106               Ident := GetValue(Path, chr(DefValue));
1107               if Length(Ident) > 0 then
1108                 SetOrdProp(Instance, PropInfo, ord(Ident[1]))
1109               else
1110                 SetOrdProp(Instance, PropInfo, DefValue);
1111             end;
1112           tkWChar:
1113             SetOrdProp(Instance, PropInfo, GetValue(Path, DefValue));
1114           tkSet:
1115             begin
1116               SetType := GetTypeData(PropType)^.CompType;
1117               Ident := GetValue(Path, '-');
1118               If Ident = '-' then
1119                 IntValue := DefValue
1120               else begin
1121                 IntValue := 0;
1122                 while length(Ident) > 0 do begin
1123                   i := Pos(',', Ident);
1124                   if i < 1 then
1125                     i := length(Ident) + 1;
1126                   s := copy(Ident, 1, i-1);
1127                   Ident := copy(Ident, i+1, length(Ident));
1128                   j := GetEnumValue(PTypeInfo(SetType), s);
1129                   if j <> -1 then
1130                     include(tset(IntValue), j)
1131                   else Begin
1132                     IntValue := DefValue;
1133                     break;
1134                   end;
1135                 end;
1136               end;
1137               SetOrdProp(Instance, PropInfo, IntValue);
1138             end;
1139           tkEnumeration:
1140             begin
1141               Ident := GetValue(Path, '-');
1142               If Ident = '-' then
1143                 Value := DefValue
1144               else
1145                 Value := GetEnumValue(PropType, Ident);
1146               if Value <> -1 then
1147                 SetOrdProp(Instance, PropInfo, Value)
1148               else
1149                 SetOrdProp(Instance, PropInfo, DefValue);
1150             end;
1151         end;
1152       end;
1153     tkFloat:
1154       begin
1155         DefFloatValue := GetFloatProp(DefInstance, PropInfo);
1156         Ident := GetValue(Path, FloatToStr(DefFloatValue));
1157         if TryStrToFloat(Ident, FloatValue) then
1158           SetFloatProp(Instance, PropInfo, FloatValue)
1159         else
1160           SetFloatProp(Instance, PropInfo, DefFloatValue)
1161       end;
1162     tkSString, tkLString, tkAString:
1163       begin
1164         DefStrValue := GetStrProp(DefInstance, PropInfo);
1165         StrValue := GetValue(Path, DefStrValue);
1166         SetStrProp(Instance, PropInfo, StrValue)
1167       end;
1168 (*    tkWString:
1169       begin
1170       end;*)
1171 (*    tkInt64, tkQWord:
1172       begin
1173       end;*)
1174     tkBool:
1175       begin
1176         DefBoolValue := GetOrdProp(DefInstance, PropInfo) <> 0;
1177         BoolValue := GetValue(Path, DefBoolValue);
1178         SetOrdProp(Instance, PropInfo, ord(BoolValue));
1179       end;
1180     tkClass:
1181       begin
1182         obj := GetObjectProp(Instance, PropInfo);
1183         if (obj is TPersistent) and HasPath(Path, False) then
1184           ReadObject(Path+'/', TPersistent(obj));
1185       end;
1186   end;
1187 end;
1188 
1189 procedure TRttiXMLConfig.ReadObject(Path: String; Obj: TPersistent; DefObject: TPersistent;
1190   OnlyProperty: String);
1191 var
1192   PropCount,i : integer;
1193   PropList  : PPropList;
1194 begin
1195   PropCount:=GetPropList(Obj,PropList);
1196   if PropCount>0 then begin
1197     try
1198       for i := 0 to PropCount-1 do
1199         ReadProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
1200     finally
1201       Freemem(PropList);
1202     end;
1203   end;
1204 end;
1205 
1206 end.
1207