root/trunk/SimpleXML.pas

unit SimpleXML;

{
  Simple XML reader/writer
  (c) David Medlock, 2005
}
interface

uses classes;

type
  Node = class
    parent  : Node;
    name    : string;
    data    : string;
    children : TList;

    function Add( nam : string ) : Node; overload;
    function Add( nam, dat : string ) : Node ; overload;
    function AddBool( nam : string ; val : boolean ) : Node ;
    function AddChild( newnode : Node ) : Integer;
    function GetChild( N: Integer ) : Node;

    function FindNode( format : string ) : Node;
    function FindText( format : string ) : string;
    function Find( S : string ) : Node;

    function Count : Integer;
    property Child[ N : Integer ]:Node read GetChild ; default;

    function ToString : String;

    constructor Create( NodeName : string );
    destructor Free;
  end;


function LoadXML( fname : string ) : Node ;
procedure SaveXML( root : Node ; fname : string  );
function ParseXML( data : string ) : Node;


implementation

uses SysUtils, Contnrs, Math;

const
  LF  = Char($D);
  CR  = Char($A);
  CRLF = '' + CR + '' + LF;
  TAB = Char($F);
  Whitespace = ' ' + CR + LF + TAB;

var
  stack : TStack; // stack of nodes under construction
  text  : string; // text we are parsing



function EncodeAll( data : string ) : string; forward;
function DecodeAll( data : string ) : string; forward;

function Look( S : string ) : boolean; forward;
function Skip( S : String ): boolean ; forward;

function FormatNode( root : Node ; indent : string ) : string; forward;
function FormatChildren( N : Node ; indent : string ) : string; forward;

function Decode( var src : string ) : char ; forward;
procedure Encode( const C : char ; var dest : string ); forward;


function Done : boolean ;
begin
  result:= Length( text ) < 1;
end;

function Cur: char;
begin
  if Done then result:=Char(0)
  else result:=text[1];
end;



{ Version of Cur which decodes the text, and consumes input }
function NextDecodedChar : Char;
begin
  if Done then begin result:=Char(0); Exit; end;
  
  result:= Decode( text );
end;

procedure Next ;
begin
  if Done then Exit;
  text := Copy( text,2,Length(text)-1 );
end;


procedure Consume( N:Integer );
begin
  while N > 0 do
  begin
    Next;
    Dec(N);  
    if Done then Exit;
  end
end;


function IsAlNum : boolean ;
begin
  result := (not Done) and
    ( Cur in [ 'a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', ':' ] );
end;

function IsSpace : boolean ;
begin
  result := (not Done) and ( Cur in [ ' ', TAB, LF, CR ] );
end;


procedure SkipWhite;
begin
  while not Done do if IsSpace then Next Else Exit;
end;


function Look( S : string ) : boolean;
begin
  result:= Pos( S, text )=1; 
end;


function Skip( S : String ): boolean;
begin
  result:= Look( S ) ;
  if result then  Consume( Length(S) );
end;



function LoadXML( fname : string ) : Node ;
var
  infile : TextFile;
  line,data   : string;
begin
  result:= nil;
  if not FileExists( fname ) then Exit;
  AssignFile( infile, fname );
  Reset( infile );

  try
    while not Eof(InFile) do
    begin
      Readln(InFile, line);
      line:=Trim(line);
      data := data + line;
    end;
  finally
    CloseFile(InFile);
  end ;
    
  result:= ParseXML( data );
end;


function FormatChildren( N : Node ; indent : string ) : string;
var
  I : Integer;
  child : Node;
begin
  result := '';
  if N.Count = 0 then Exit;
  result := CR;
  for I:=0 to N.children.Count-1 do
  begin
    child:= N.children[I];
    result := result + FormatNode( child, indent + '  ' );
  end;
end;


function FormatNode( root : Node ; indent : string ) : string;
var
  S : string;
  E : string;
begin
  result:='';
  if not Assigned( root ) then Exit;
  if (Length(root.Data)<1) and (root.Count = 0) then
  begin
    result:= indent + '<' + root.Name + '/>' + CR ;
    Exit;
  end;

  S:= '<' + root.name + '>' + EncodeAll(root.data) ;
  E:= '</' + root.name + '>' ;

  if root.Count>0 then
    result:= indent + S + FormatChildren( root, indent ) +
              indent + E + CR
  else
    result:= indent + S + E + CR;
end;



procedure SaveXML( root : Node ; fname : string  );
var
  outfile : TextFile ;
  xml : string;
begin
  if not Assigned( root ) then Exit;
  AssignFile( outfile, fname );
  Rewrite( outfile );
  xml := root.ToString;
  Write( outfile, xml );
  CloseFile( outfile );
end;


function Begins( var S : string ; sub : string ) : boolean;
var
  N, I : Integer;
begin
  result:=false;
  N:= Length(sub);
  if N>Length(S) then Exit
  else begin
    for I:=1 to N do if S[I] <> sub[I] then Exit;
  end;
  S := Copy( S, N+1, Length(S)-N );
  result:=true;
end;


function Decode( var src : string  ) : char;
begin
  result:= Char(0);
  if Length(src)<1 then Exit;

  if src[1] <> '&' then
  begin
    result:= src[1];
    src:=Copy( src,2, Length(src)-1 );
    Exit;
  end;

  if Begins( src, '&amp;' ) then result:='&'
  else if Begins( src, '&quot' ) then result:='"'
  else if Begins( src, '&lt;' ) then result:='<'
  else if Begins( src, '&gt;' ) then result:='>'
  else if Begins( src, '&nbsp;' ) then result:=' '
  else raise Exception.Create( 'Unknown Character encoding!' ) ;
end;


procedure Encode( const c : char ; var dest : string );
begin
  Case C of
    ' ': dest:= dest + '&nbsp;';
    '&': dest:= dest + '&amp;' ;
    '<': dest:= dest + '&lt;' ;
    '>': dest:= dest + '&gt;' ;
    '"': dest:= dest + '&quot;' ;
    else dest:= dest + c;
  end;
end;



function EncodeAll( data : string ) : string;
var
  N : Integer;
begin
  result := '';
  for N:=1 to Length(data) do Encode( data[N], result );
end;

function DecodeAll( data: string ) : string ;
var
  tmp : string;
begin
  tmp := data;
  while Length(tmp) > 0 do result:= result + Decode( tmp );
end;



function ParseName : string ;
begin
  result:='';
  while not Done and IsAlnum do
  begin
    result:= result + Cur;
    Next;
  end
end;


function ParseText : string;
begin
  result:='';
  while not Done do
    while not (Cur = '<') do begin
      result:= result + Cur;
      Next;
    end;
end;


procedure TagBody;
var
  N : Node;
  buf : string;
begin
  buf := '';
  while Not Done do
  begin
    if Cur in ['<'] then Break;
    buf := buf + NextDecodedChar;
  end;

  if stack.count<1 then Exit;

  buf:= Trim(buf);
  if Length( buf )= 0 then Exit;

  N:= Node( stack.Peek );
  N.data := N.data + buf;
end;


procedure CloseTag;
var
  Prev : Node; // Most recently Opened tag
begin
  Assert( stack.Count>0 , 'Open Tag expected.' );
  Prev:= Node(Stack.Peek);
  if not Skip( '</' ) then raise Exception.Create( '</' + Prev.Name + '> Expected!');
  SkipWhite;
  Assert( Skip( Prev.Name ) , 'Expected Closing tag for node:' + Prev.Name );
  SkipWhite;
  Assert( Skip( '>' ) );
  if stack.count<2 then Exit;
  stack.pop;
  Node(Stack.Peek).AddChild( Prev );
end;


procedure CommentTag;
var
  E: Integer;
begin
  Assert( Skip('<!--') );
  E := Pos( '-->' , text );
  if (E=0) then raise Exception.Create( 'Unclosed Comment' )
  else
    text:=Copy( text, E+3, Length(text)-(E+3)+1 );
  SkipWhite;
end;

procedure OpenTag;
var
  n : Node;
begin
  Assert( Skip('<' ) );
  n := Node.Create( ParseName );
  { Used for a debugging breakpoint
  if n.name = 'ProjectFiles' then begin
    n.data:='';
  end;}
  
  SkipWhite;
  if Skip( '/>' ) then begin
    if stack.Count>0 then Node(stack.Peek).AddChild( n )
    else stack.push( n );
    Exit;
  end;
  Assert( Skip('>' ) );
  stack.Push( n );
end;


procedure Parse ;
begin
  while not Done do begin
    if Cur <> '<' then TagBody
    else if Look( '<!--' ) then CommentTag
    else if Look( '</' ) then CloseTag
    else if Look( '<' ) then OpenTag
    else
      raise Exception.Create( 'Unknown Tag type:' +
                  Copy( text, 1, Max( 10, Length(text) )));
  end;
end;


function ParseXML( data : string ) : Node;
begin
  stack := TStack.Create;
  text := data ;
  SkipWhite;
  Parse;
  result:=nil;
  if stack.Count=0 then Exit;
  result:=stack.pop;
  while stack.Count>0 do  Node(stack.Pop).Free;
  stack.free;  
end;


// ----------------------------------
// Node Functions Below 
// ----------------------------------

function Node.Add( nam : string ) : Node;
begin
  result:= Node.Create( nam );
  Self.Children.Add( result );
  result.parent := self;
end;

function Node.Add( nam, dat : string ) : Node;
begin
  result:= Node.Create( nam );
  result.data := dat;
  Self.Children.Add( result );
  result.parent := self;
end;

function Node.AddBool( nam : string ; val : boolean ) : Node ;
begin
  result:= Self.Add( nam );
  if val then result.data := 'true' else result.data := 'false';
  result.parent := self;
end; 



function Node.AddChild( newnode : Node ) : Integer;
begin
  result:= children.Add( newnode );
  newnode.parent := self;
end;

function Node.GetChild( N: Integer ) : Node;
begin
  result:=nil;
  if N >= children.Count then Exit;
  result:= children[N];
end;

function Node.Count : Integer;
begin
  result:= children.Count;
end;



constructor Node.Create( NodeName : string );
begin
  NodeName := Trim( NodeName );
  Assert( Length(NodeName)>0, 'Node Name cannot be empty!' ) ;
  self.Name := NodeName;
  self.Children := TList.Create;
end;


destructor Node.Free;
var
  N : Integer;
begin
  for N:=0 to children.Count-1 do
  begin
    Node(children[N]).Free;
  end;
  children.Free;
end;

function Node.ToString : String;
begin
  result:= FormatNode( Self, '' );
end;



{ Finds next item from | separated list, used by FindNodes }
function NextName( var S : String ) : string;
var
  N : Integer;
begin
  while Length(S) > 0 do
  begin
    N := Pos( '|', S );
    if N=0 then
    begin
      result:= S;
      S:='';
      Exit;
    end;

    if N=1 then
    begin
      S:= Copy( S, 2, Length(S)-1 );
      Continue;
    end;

    result:= Copy( S, 1, N-1 );
    S:= Copy( S, N+1, Length(S) - (N+1) );
  end;
end;


{ Finds first Node Under this Node matching the passed format
  uses '|' to separate the node names
  node := Node.Find( 'AddressBook|Names|Address|HomePhone' );
}
function Node.FindNode( format : string ) : Node;
var
  cur : Node;
  tok : string;
begin
  result:= nil;
  cur := Self;
  while Length(format)>0 do
  begin
    tok := NextName( format );
    if Length(tok) = 0 then Exit;
    cur := cur.Find( tok );
    if Not Assigned(cur) then Exit;
  end;

  result:= cur;
end;

function Node.FindText( format : string ) : string;
var
  tmp : Node;
begin
  result:='';
  tmp := Self.FindNode( format );
  if Assigned(tmp) then result:= tmp.data;
end;


function Node.Find( S : string ) : Node;
var
  N : Integer;
begin
  result:=nil;
  for N:=0 to children.Count-1 do
  begin
    if Node(children[N]).Name <> S then Continue;
    result:=children[N];
    Break;
  end;
end;
    

end.