unit dxml;

interface

uses
  dtypes,
  dstream;

const
  XML_HEADER    =   0;
  XML_TAG       =   1;
  XML_TEXT      =   2;

type
TXMLItemType = LongInt;
TXMLErrorId  = LongInt;

TXMLParam = record
  Name: TString;
  Value: TString;
end;

PXMLItem = ^TXMLItem;
TXMLItem = record
  Typ: LongInt;
  Text: TString; // for tag it is name; for header it is ''
  Params: array of TXMLParam; // for text it is nil
  Content: array of PXMLItem; // just for tag
end;

TXML = object
private
  FHeader: TXMLItem;
  FRoot: TXMLItem;
  // only while parsing
  FLookup: Byte;
  FStream: PStream;
  function GetLookup: Byte;
  function ReadLookup: Byte;
public
  constructor Init;
  destructor Done; virtual;
  function Load(Data: TData): Boolean;
  procedure Save(FileName: TString);
  procedure Clear;
  procedure SkipSpaces(Stream: PStream);
  function ReadParams(Stream: PStream; Item: PXMLItem; Finish: TSetOfChar): Boolean;
  function ReadTag(Stream: PStream; Item: PXMLItem): Boolean;
  function ReadContent(Stream: PStream; Item: PXMLItem; var EndTag: TString): Boolean;
  function ReadStr(Stream: PStream; var S: TString): Boolean;
  function GetHeader: PXMLItem;
  function GetRoot: PXMLItem;
  property Root: PXMLItem read GetRoot;
end;

procedure XMLSetEmpty(Item: PXMLItem; Typ: TXMLItemType; Text: TString);
procedure XMLAddParam(Item: PXMLItem; Name, Value: TString);
function XMLAddContent(Item: PXMLItem; Typ: TXMLItemType; Text: TString): PXMLItem;

implementation

procedure XMLSetEmpty(Item: PXMLItem; Typ: TXMLItemType; Text: TString);
begin
  Item.Typ := Typ;
  Item.Text := Text;
  SetLength(Item.Params, 0);
  SetLength(Item.Content, 0);
end;

procedure XMLAddParam(Item: PXMLItem; Name, Value: TString);
begin
  if Item.Typ = XML_TEXT then
    Exit;
  SetLength(Item.Params, Length(Item.Params) + 1);
  Item.Params[High(Item.Params)].Name := Name;
  Item.Params[High(Item.Params)].Value := Value;
end;

function XMLAddContent(Item: PXMLItem; Typ: TXMLItemType; Text: TString): PXMLItem;
begin
  if Item.Typ <> XML_TAG then
    Exit;
  SetLength(Item.Content, Length(Item.Content) + 1);
  New(Item.Content[High(Item.Content)]);
  Result := Item.Content[High(Item.Content)];
  Result.Typ := Typ;
  Result.Text := Text;
  SetLength(Result.Params, 0);
  SetLength(Result.Content, 0);
end;

function TXML.GetLookup: Byte;
begin
  Result := FLookup;
end;

function TXML.ReadLookup: Byte;
begin
  Result := FLookup;
  FLookup := FStream.ReadByte;
end;

constructor TXML.Init;
begin
  Clear;
end;

destructor TXML.Done;
begin
end;

function TXML.Load(Data: TData): Boolean;
label
  FinalActions;
var
  Stream: PStream;
begin
  Result := False;
  Stream := Data.Stream;
  FStream := Stream;
  ReadLookup;
  SkipSpaces(Stream);
  if ReadLookup <> Ord('<') then
    goto FinalActions;
  if ReadLookup = Ord('?') then begin
    ReadLookup;
    if not ReadStr(Stream, FHeader.Text) then
      goto FinalActions;
    if not ReadParams(Stream, @FHeader, ['?']) then
      goto FinalActions;
    ReadLookup;
    if ReadLookup <> Ord('>') then
      goto FinalActions;
    SkipSpaces(Stream);
  end;
  SkipSpaces(Stream);
  if ReadLookup <> Ord('<') then
    goto FinalActions;
  if GetLookup = Ord('!') then
    goto FinalActions;
  if not ReadTag(Stream, @FRoot) then
    goto FinalActions;
  Result := True;
FinalActions:
  Data.Done;
end;

procedure TXML.Save(FileName: TString);
begin
end;

procedure TXML.Clear;
begin
  XMLSetEmpty(@FHeader, XML_HEADER, '');
  XMLSetEmpty(@FRoot, XML_TAG, '');
end;

procedure TXML.SkipSpaces(Stream: PStream);
begin
  while GetLookup <= 32 do
    ReadLookup;
end;

function TXML.ReadParams(Stream: PStream; Item: PXMLItem; Finish: TSetOfChar): Boolean;
var
  Name, Value: String;
begin
  Result := False;
  SkipSpaces(Stream);
  while not (TChar(GetLookup) in Finish) do begin
    Name := '';
    while not (TChar(GetLookup) in [#0..#32, '=']) do
      Name := Name + TChar(ReadLookup);
    SkipSpaces(Stream);
    if ReadLookup <> Ord('=') then
      Exit;
    SkipSpaces(Stream);
    Value := '';
    if TChar(GetLookup) = '"' then begin
      ReadLookup;
      while TChar(GetLookup) <> '"' do
        Value := Value + TChar(ReadLookup);
      ReadLookup;
    end else if TChar(GetLookup) = '''' then begin
      ReadLookup;
      while TChar(GetLookup) <> '''' do
        Value := Value + TChar(ReadLookup);
      ReadLookup;
    end else
      Exit;
    XMLAddParam(Item, Name, Value);
    SkipSpaces(Stream);
  end;
  Result := True;
end;

function TXML.ReadTag;
var
  S: TString;
begin
  Result := False;
  XMLSetEmpty(Item, XML_TAG, '');
  SkipSpaces(Stream);
  Item.Text := '';
  while not (TChar(GetLookup) in [#0..#32, '>', '/']) do
    Item.Text := Item.Text + TChar(ReadLookup);
  if not ReadParams(Stream, Item, ['/', '>']) then
    Exit;
  case ReadLookup of
    Ord('/'): 
      if ReadLookup <> Ord('>') then
        Exit;
    Ord('>'): 
      begin
        if not ReadContent(Stream, Item, S) then
           Exit;
        if S <> Item.Text then
          Exit;
      end;
  else
    Exit;
  end;
  Result := True;
end;

function TXML.ReadContent(Stream: PStream; Item: PXMLItem; var EndTag: TString): Boolean;
var
  Text: TString;
begin
  Result := False;
  SkipSpaces(Stream);
  while True do begin
    Text := '';
    while TChar(GetLookup) <> '<' do
      Text := Text + TChar(ReadLookup);
    if Text <> '' then
      XMLAddContent(Item, XML_TEXT, Text);
    ReadLookup;
    if TChar(GetLookup) <> '/' then begin 
      if not ReadTag(Stream, XMLAddContent(Item, XML_TAG, '')) then
        Exit
    end else begin
      Text := '';
      ReadLookup;
      SkipSpaces(Stream);
      while not (TChar(GetLookup) in [#0..#32, '>']) do
        Text := Text + TChar(ReadLookup);
      EndTag := Text;
      SkipSpaces(Stream);
      if ReadLookup <> Ord('>') then
        Exit;
      Break;
    end;
    SkipSpaces(Stream);
  end;
  Result := True;
end;

function TXML.ReadStr(Stream: PStream; var S: TString): Boolean;
begin
  S := '';
  while GetLookup > 32 do
    S := S + TChar(ReadLookup);
  Result := True;
end;

function TXML.GetHeader: PXMLItem;
begin
  Result := @FHeader;
end;

function TXML.GetRoot: PXMLItem;
begin
  Result := @FRoot;
end;

end.
