/packages/fcl-xml/src/xmlcfg.pp
Puppet | 434 lines | 427 code | 7 blank | 0 comment | 2 complexity | 4edf48f00cf08811c13083724298fc46 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
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.