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

https://github.com/slibre/freepascal · Puppet · 434 lines · 427 code · 7 blank · 0 comment · 2 complexity · 4edf48f00cf08811c13083724298fc46 MD5 · raw file

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