freepascal.compiler/fcl/xml/xmlcfg.pp

{
    $Id$
    This file is part of the Free Component Library
    Copyright (c) 1999-2000 by Sebastian Guenther

    Implementation of TXMLConfig class

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{
  TXMLConfig enables applications to use XML files for storing their
  configuration data
}

{$MODE objfpc}
{$H+}

unit XMLCfg;

interface
uses DOM, XMLRead, XMLWrite;

type

  {"APath" is the path and name of a value: A XML configuration file is
   hierarchical. "/" is the path delimiter, the part after the last "/"
   is the name of the value. The path components will be mapped to XML
   elements, the name will be an element attribute.}

  TXMLConfig = class
  protected
    doc: TXMLDocument;
    FileName: String;
  public
    constructor Create(const AFileName: String);
    destructor Destroy; override;
    procedure Flush;    // Writes the XML file
    function  GetValue(const APath, ADefault: String): String;
    function  GetValue(const APath: String; ADefault: Integer): Integer;
    function  GetValue(const APath: String; ADefault: Boolean): Boolean;
    procedure SetValue(const APath, AValue: String);
    procedure SetValue(const APath: String; AValue: Integer);
    procedure SetValue(const APath: String; AValue: Boolean);
  end;


// ===================================================================

implementation

uses SysUtils;


constructor TXMLConfig.Create(const AFileName: String);
var
  f: File;
  cfg: TDOMElement;
begin
  FileName := AFileName;
  Assign(f, AFileName);
  {$I-}
  Reset(f, 1);
  {$I+}
  if IOResult = 0 then begin
    try
      ReadXMLFile(doc, f);
    except
      on e: EXMLReadError do
        WriteLn(StdErr, 'Warning: XML config parsing error: ', e.Message);
    end;
    Close(f);
  end;

  if not Assigned(doc) then
    doc := TXMLDocument.Create;

  cfg :=TDOMElement(doc.FindNode('CONFIG'));
  if not Assigned(cfg) then begin
    cfg := doc.CreateElement('CONFIG');
    doc.AppendChild(cfg);
  end;
end;

destructor TXMLConfig.Destroy;
begin
  Flush;
  if Assigned(doc) then
    doc.Free;
  inherited Destroy;
end;

procedure TXMLConfig.Flush;
var
  f: Text;
begin
  Assign(f, FileName);
  Rewrite(f);
  WriteXMLFile(doc, f);
  Close(f);
end;

function TXMLConfig.GetValue(const APath, ADefault: String): String;
var
  node, subnode, attr: TDOMNode;
  i: Integer;
  name, path: String;
begin
  node := doc.DocumentElement;
  path := APath;
  while True do begin
    i := Pos('/', path);
    if i = 0 then break;
    name := Copy(path, 1, i - 1);
    path := Copy(path, i + 1, Length(path));
    subnode := node.FindNode(name);
    if not Assigned(subnode) then begin
      Result := ADefault;
      exit;
    end;
    node := subnode;
  end;
  attr := node.Attributes.GetNamedItem(path);
  if Assigned(attr) then
    Result := attr.NodeValue
  else
    Result := ADefault;
end;

function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
begin
  Result := StrToInt(GetValue(APath, IntToStr(ADefault)));
end;

function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean;
var
  s: String;
begin
  if ADefault then
    s := 'True'
  else
    s := 'False';

  s := GetValue(APath, s);

  if UpperCase(s) = 'TRUE' then
    Result := True
  else if UpperCase(s) = 'FALSE' then
    Result := False
  else
    Result := ADefault;
end;

procedure TXMLConfig.SetValue(const APath, AValue: String);
var
  node, subnode, attr: TDOMNode;
  i: Integer;
  name, path: String;
begin
  node := doc.DocumentElement;
  path := APath;
  while True do begin
    i := Pos('/', path);
    if i = 0 then break;
    name := Copy(path, 1, i - 1);
    path := Copy(path, i + 1, Length(path));
    subnode := node.FindNode(name);
    if not Assigned(subnode) then begin
      subnode := doc.CreateElement(name);
      node.AppendChild(subnode);
    end;
    node := subnode;
  end;
  attr := node.Attributes.GetNamedItem(path);
  if not Assigned(attr) then begin
    attr := doc.CreateAttribute(path);
    node.Attributes.SetNamedItem(attr);
  end;
  attr.NodeValue := AValue;
end;

procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
begin
  SetValue(APath, IntToStr(AValue));
end;

procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
begin
  if AValue then
    SetValue(APath, 'True')
  else
    SetValue(APath, 'False');
end;


end.


{
  $Log$
  Revision 1.9  2000-02-13 10:03:31  sg
  * Hopefully final fix for TDOMDocument.DocumentElement:
    - Reading this property always delivers the first element in the document
    - Removed SetDocumentElement. Use "AppendChild" or one of the other
      generic methods for TDOMNode instead.

  Revision 1.8  2000/01/30 22:20:08  sg
  * TXMLConfig now frees its XML document (major memory leak...)

  Revision 1.7  2000/01/07 01:24:34  peter
    * updated copyright to 2000

  Revision 1.6  2000/01/06 01:20:37  peter
    * moved out of packages/ back to topdir

  Revision 1.1  2000/01/03 19:33:11  peter
    * moved to packages dir

  Revision 1.4  1999/12/22 13:38:01  sg
  * Lots of cosmetic changes (strings -> const AnsiStrings etc.)

  Revision 1.3  1999/07/25 16:24:13  michael
  + Fixes from Sebastiam Guenther - more error-proof

  Revision 1.2  1999/07/09 21:05:50  michael
  + fixes from Guenther Sebastian

  Revision 1.1  1999/07/09 08:35:09  michael
  + Initial implementation by Sebastian Guenther

}