/packages/fcl-xml/src/xmlcfg.pp

  1{
  2    This file is part of the Free Component Library
  3
  4    Implementation of TXMLConfig class
  5    Copyright (c) 1999 - 2005 by Sebastian Guenther, sg@freepascal.org
  6
  7    See the file COPYING.FPC, included in this distribution,
  8    for details about the copyright.
  9
 10    This program is distributed in the hope that it will be useful,
 11    but WITHOUT ANY WARRANTY; without even the implied warranty of
 12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 13
 14 **********************************************************************}
 15
 16{
 17  TXMLConfig enables applications to use XML files for storing their
 18  configuration data
 19}
 20
 21{$ifdef fpc}{$MODE objfpc}{$endif}
 22{$H+}
 23
 24{ This unit is deprecated because it doesn't work well with non-ascii data.
 25  Attempts to change its behavior will likely cause problems with existing
 26  config files, so it is superseded altogether by xmlconf unit. }
 27unit XMLCfg deprecated;
 28
 29interface
 30
 31{off $DEFINE MEM_CHECK}
 32
 33uses
 34  {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
 35  SysUtils, Classes, DOM, XMLRead, XMLWrite;
 36
 37resourcestring
 38  SMissingPathName = 'A part of the pathname is invalid (missing)';
 39  SEscapingNecessary = 'Invalid pathname, escaping must be enabled';
 40  SWrongRootName = 'XML file has wrong root element name';
 41
 42type
 43
 44  EXMLConfigError = class(Exception);
 45
 46  {"APath" is the path and name of a value: A XML configuration file is
 47   hierachical. "/" is the path delimiter, the part after the last "/"
 48   is the name of the value. The path components will be mapped to XML
 49   elements, the name will be an element attribute.}
 50
 51  TXMLConfig = class(TComponent)
 52  private
 53    FFilename: String;
 54    FStartEmpty: Boolean;
 55    FUseEscaping: Boolean;
 56    FRootName: DOMString;
 57    procedure SetFilenameForce(const AFilename: String; ForceReload: Boolean);
 58    procedure SetFilename(const AFilename: String);
 59    procedure SetStartEmpty(AValue: Boolean);
 60    procedure SetRootName(const AValue: DOMString);
 61  protected
 62    Doc: TXMLDocument;
 63    FModified: Boolean;
 64    procedure Loaded; override;
 65    function FindNode(const APath: String; PathHasValue: boolean): TDomNode;
 66    function Escape(const s: String): String;
 67  public
 68    constructor Create(AOwner: TComponent); override;
 69    destructor Destroy; override;
 70    procedure Clear;
 71    procedure Flush;    // Writes the XML file
 72    function  GetValue(const APath, ADefault: String): String; overload;
 73    function  GetValue(const APath: String; ADefault: Integer): Integer; overload;
 74    function  GetValue(const APath: String; ADefault: Boolean): Boolean; overload;
 75    procedure SetValue(const APath, AValue: String); overload;
 76    procedure SetDeleteValue(const APath, AValue, DefValue: String); overload;
 77    procedure SetValue(const APath: String; AValue: Integer); overload;
 78    procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer); overload;
 79    procedure SetValue(const APath: String; AValue: Boolean); overload;
 80    procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean); overload;
 81    procedure DeletePath(const APath: string);
 82    procedure DeleteValue(const APath: string);
 83    property Modified: Boolean read FModified;
 84  published
 85    property Filename: String read FFilename write SetFilename;
 86    property StartEmpty: Boolean read FStartEmpty write SetStartEmpty;
 87    property UseEscaping: Boolean read FUseEscaping write FUseEscaping
 88      default True;
 89    property RootName: DOMString read FRootName write SetRootName;
 90  end deprecated;
 91
 92
 93// ===================================================================
 94
 95implementation
 96
 97
 98constructor TXMLConfig.Create(AOwner: TComponent);
 99begin
100  inherited Create(AOwner);
101  FUseEscaping := True;
102  FRootName := 'CONFIG';
103  Doc := TXMLDocument.Create;
104  Doc.AppendChild(Doc.CreateElement(RootName));
105end;
106
107destructor TXMLConfig.Destroy;
108begin
109  if Assigned(Doc) then
110  begin
111    Flush;
112    Doc.Free;
113  end;
114  inherited Destroy;
115end;
116
117procedure TXMLConfig.Clear;
118begin
119  Doc.ReplaceChild(Doc.CreateElement(RootName), Doc.DocumentElement);
120end;
121
122procedure TXMLConfig.Flush;
123begin
124 if (Filename<>EmptyStr) and Modified then
125  begin
126    WriteXMLFile(Doc, Filename);
127    FModified := False;
128  end;
129end;
130
131function TXMLConfig.GetValue(const APath, ADefault: String): String;
132var
133  Node, Child, Attr: TDOMNode;
134  NodeName: String;
135  PathLen: integer;
136  StartPos, EndPos: integer;
137begin
138  Result := ADefault;
139  PathLen := Length(APath);
140  Node := Doc.DocumentElement;
141  StartPos := 1;
142  while True do
143  begin
144    EndPos := StartPos;
145    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
146      Inc(EndPos);
147    if EndPos > PathLen then
148      break;
149    SetLength(NodeName, EndPos - StartPos);
150    Move(APath[StartPos], NodeName[1], EndPos - StartPos);
151    StartPos := EndPos + 1;
152    Child := Node.FindNode(Escape(NodeName));
153    if not Assigned(Child) then
154      exit;
155    Node := Child;
156  end;
157  if StartPos > PathLen then
158    exit;
159  SetLength(NodeName, PathLen - StartPos + 1);
160  Move(APath[StartPos], NodeName[1], Length(NodeName));
161  Attr := Node.Attributes.GetNamedItem(Escape(NodeName));
162  if Assigned(Attr) then
163    Result := Attr.NodeValue;
164end;
165
166function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
167begin
168  Result := StrToIntDef(GetValue(APath, IntToStr(ADefault)),ADefault);
169end;
170
171function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean;
172var
173  s: String;
174begin
175  if ADefault then
176    s := 'True'
177  else
178    s := 'False';
179
180  s := GetValue(APath, s);
181
182  if AnsiCompareText(s, 'TRUE')=0 then
183    Result := True
184  else if AnsiCompareText(s, 'FALSE')=0 then
185    Result := False
186  else
187    Result := ADefault;
188end;
189
190procedure TXMLConfig.SetValue(const APath, AValue: String);
191var
192  Node, Child: TDOMNode;
193  NodeName: String;
194  PathLen: integer;
195  StartPos, EndPos: integer;
196begin
197  Node := Doc.DocumentElement;
198  PathLen := Length(APath);
199  StartPos:=1;
200  while True do
201  begin
202    EndPos := StartPos;
203    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
204      Inc(EndPos);
205    if EndPos > PathLen then
206      break;
207    SetLength(NodeName, EndPos - StartPos);
208    Move(APath[StartPos], NodeName[1], EndPos - StartPos);
209    StartPos := EndPos + 1;
210    NodeName := Escape(NodeName);
211    Child := Node.FindNode(NodeName);
212    if not Assigned(Child) then
213    begin
214      Child := Doc.CreateElement(NodeName);
215      Node.AppendChild(Child);
216    end;
217    Node := Child;
218  end;
219
220  if StartPos > PathLen then
221    exit;
222  SetLength(NodeName, PathLen - StartPos + 1);
223  Move(APath[StartPos], NodeName[1], Length(NodeName));
224  NodeName := Escape(NodeName);
225  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or
226    (TDOMElement(Node)[NodeName] <> AValue) then
227  begin
228    TDOMElement(Node)[NodeName] := AValue;
229    FModified := True;
230  end;
231end;
232
233procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String);
234begin
235  if AValue = DefValue then
236    DeleteValue(APath)
237  else
238    SetValue(APath, AValue);
239end;
240
241procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
242begin
243  SetValue(APath, IntToStr(AValue));
244end;
245
246procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
247  DefValue: Integer);
248begin
249  if AValue = DefValue then
250    DeleteValue(APath)
251  else
252    SetValue(APath, AValue);
253end;
254
255procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
256begin
257  if AValue then
258    SetValue(APath, 'True')
259  else
260    SetValue(APath, 'False');
261end;
262
263procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
264  DefValue: Boolean);
265begin
266  if AValue = DefValue then
267    DeleteValue(APath)
268  else
269    SetValue(APath,AValue);
270end;
271
272procedure TXMLConfig.DeletePath(const APath: string);
273var
274  Node: TDomNode;
275begin
276  Node := FindNode(APath, False);
277  if (Node = nil) or (Node.ParentNode = nil) then
278    exit;
279  Node.ParentNode.RemoveChild(Node);
280  FModified := True;
281end;
282
283procedure TXMLConfig.DeleteValue(const APath: string);
284var
285  Node: TDomNode;
286  StartPos: integer;
287  NodeName: string;
288begin
289  Node := FindNode(APath, True);
290  if not Assigned(Node) then
291    exit;
292  StartPos := Length(APath);
293  while (StartPos > 0) and (APath[StartPos] <> '/') do
294   Dec(StartPos);
295  NodeName := Escape(Copy(APath, StartPos+1, Length(APath) - StartPos));
296  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) then
297    exit;
298  TDOMElement(Node).RemoveAttribute(NodeName);
299  FModified := True;
300end;
301
302procedure TXMLConfig.Loaded;
303begin
304  inherited Loaded;
305  if Length(Filename) > 0 then
306    SetFilenameForce(Filename, true);              // Load the XML config file
307end;
308
309function TXMLConfig.FindNode(const APath: String;
310  PathHasValue: boolean): TDomNode;
311var
312  NodePath: String;
313  StartPos, EndPos: integer;
314  PathLen: integer;
315begin
316  Result := Doc.DocumentElement;
317  PathLen := Length(APath);
318  StartPos := 1;
319  while Assigned(Result) do
320  begin
321    EndPos := StartPos;
322    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
323      Inc(EndPos);
324    if (EndPos > PathLen) and PathHasValue then
325      exit;
326    if EndPos = StartPos then
327      break;
328    SetLength(NodePath, EndPos - StartPos);
329    Move(APath[StartPos], NodePath[1], Length(NodePath));
330    Result := Result.FindNode(Escape(NodePath));
331    StartPos := EndPos + 1;
332    if StartPos > PathLen then
333      exit;
334  end;
335  Result := nil;
336end;
337
338function TXMLConfig.Escape(const s: String): String;
339const
340  AllowedChars = ['A'..'Z', 'a'..'z', '0'..'9', '.', '-', '_'];
341var
342  EscapingNecessary: Boolean;
343  i: Integer;
344begin
345  if Length(s) < 1 then
346    raise EXMLConfigError.Create(SMissingPathName);
347
348  if not (s[1] in ['A'..'Z', 'a'..'z', '_']) then
349    EscapingNecessary := True
350  else
351  begin
352    EscapingNecessary := False;
353    for i := 2 to Length(s) do
354      if not (s[i] in AllowedChars) then
355      begin
356        EscapingNecessary := True;
357        break;
358      end;
359  end;
360
361  if EscapingNecessary then
362    if UseEscaping then
363    begin
364      Result := '_';
365      for i := 1 to Length(s) do
366        if s[i] in (AllowedChars - ['_']) then
367	  Result := Result + s[i]
368	else
369	  Result := Result + '_' + IntToHex(Ord(s[i]), 2);
370    end else
371      raise EXMLConfigError.Create(SEscapingNecessary)
372  else	// No escaping necessary
373    Result := s;
374end;
375
376procedure TXMLConfig.SetFilenameForce(const AFilename: String; ForceReload: Boolean);
377begin
378  {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
379  if (not ForceReload) and (FFilename = AFilename) then
380    exit;
381  Flush;
382  FreeAndNil(Doc);
383
384  FFilename := AFilename;
385
386  if csLoading in ComponentState then
387    exit;
388
389  if FileExists(AFilename) and (not FStartEmpty) then
390    ReadXMLFile(Doc, AFilename);
391
392  if not Assigned(Doc) then
393    Doc := TXMLDocument.Create;
394
395  if not Assigned(Doc.DocumentElement) then
396    Doc.AppendChild(Doc.CreateElement(RootName))
397  else
398    if Doc.DocumentElement.NodeName <> RootName then
399      raise EXMLConfigError.Create('XML file has wrong root element name');
400
401  {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF}
402end;
403
404procedure TXMLConfig.SetFilename(const AFilename: String);
405begin
406  SetFilenameForce(AFilename, False);
407end;
408
409procedure TXMLConfig.SetRootName(const AValue: DOMString);
410var
411  Cfg: TDOMElement;
412begin
413  if AValue <> RootName then
414  begin
415    FRootName := AValue;
416    Cfg := Doc.CreateElement(AValue);
417    while Assigned(Doc.DocumentElement.FirstChild) do
418      Cfg.AppendChild(Doc.DocumentElement.FirstChild);
419    Doc.ReplaceChild(Cfg, Doc.DocumentElement);
420    FModified := True;
421  end;
422end;
423
424procedure TXMLConfig.SetStartEmpty(AValue: Boolean);
425begin
426  if AValue <> StartEmpty then
427  begin
428    FStartEmpty := AValue;
429    if (not AValue) and not Modified then
430      SetFilenameForce(Filename, True);
431  end;
432end;
433
434end.