{$MODE FPC}
{$MODESWITCH DEFAULTPARAMETERS}
{$MODESWITCH Out}
{$MODESWITCH RESULT}
unit dxml_sax;

interface

uses
  dansiview,
  derror,
  dstrnum,
  dparser,
  dstream,
  dtokenizer;

const
  XML_ERROR_UNDERDEVELOPED              = 1;
  XML_ERROR_EMPTY                       = 2;
  XML_ERROR_LT_EXPECTED                 = 3;
  XML_ERROR_UNEXPECTED_END              = 4;
  XML_ERROR_INVALID_TAG_NAME            = 5;
  XML_ERROR_OPEN_AND_CLOSE_DISMATCHING  = 6;
  XML_ERROR_INVALID_PARAM_NAME          = 7;
  XML_ERROR_NO_EQUAL_SIGN               = 8;
  XML_ERROR_NO_QUOTE_MARK               = 9;
  XML_ERROR_MISSED_CLOSE_QUOTE_MARK     = 10;
  XML_ERROR_INVALID_ONE_LINER_TAG       = 11;
  XML_ERROR_UNKNOWN_XML_HEADER          = 12;
  XML_ERROR_UNEXPECTED_XML_HEADER_END   = 13;
  XML_ERROR_GT_EXPECTED                 = 14;

type
PXmlParser = ^TXmlParser;
PXmlReader = ^TXmlReader;

TXmlReader = object
private
  // TODO get rid of Depth in the base class
  FDepth: LongInt;
public
  constructor Init;
  destructor Done; virtual;
  procedure OnDocumentBegin; virtual;
  procedure OnDocumentEnd; virtual;
  procedure OnHeaderBegin(const HeaderTag: TAnsiView); virtual;
  procedure OnHeaderEnd(const HeaderTag: TAnsiView); virtual;
  procedure OnOpenTagBegin(Parser: PXmlParser; const Name: TAnsiView); virtual;
  procedure OnAttribute(Parser: PXmlParser; const Name, Value: TAnsiView); virtual;
  procedure OnOpenTagEnd(Parser: PXmlParser; const Name: TAnsiView); virtual;
  procedure OnContent(Parser: PXmlParser; const Content: TAnsiView); virtual;
  procedure OnCloseTag(Parser: PXmlParser; const Name: TAnsiView); virtual;
  property Depth: LongInt read FDepth;
end;

TXmlParser = object
private type
  // TODO move this declaration to more common place
  PSourcePos = ^TSourcePos;
  TSourcePos = record
    Line, Pos: LongInt;
  end;
  PRecursiveState = ^TRecursiveState;
  TRecursiveState = record
    Recursed: Boolean;
    Name: AnsiString;
    _Result: Boolean;
  end;
private
  FError: TError;
  FReader: PXmlReader;
  FLookupReader: TLookupReader;
  FRecursed: PRecursiveState;
  function CurrentSourcePos: TSourcePos; inline;
  procedure SaveSourcePos(out SourcePos: TSourcePos);
  function RaiseError(const SourcePos: TSourcePos; Id: LongInt; const Msg: AnsiString): Boolean;
  function ReadName(var Name: AnsiString): Boolean;
  function ParseHeader: Boolean;
  function ParseAttribute: Boolean;
  function ParseTag: Boolean;
  function ParseAfterOpenTagBegin(const Name: AnsiString): Boolean;
  function ParseContent: Boolean;
  function DoParse: Boolean;
public
  constructor Init;
  destructor Done; virtual;
  function Parse(Data: TData; Reader: PXmlReader): Boolean; inline;
  function Recurse(NewReader: PXmlReader): Boolean;
  procedure SetReader(NewReader: PXmlReader);
  property Error: TError read FError;
end;

function ParseXml(Data: TData; Reader: PXmlReader; Error: PError = nil): Boolean;
function UnescapeHTML(const S: TAnsiView): AnsiString;

implementation

constructor TXmlReader.Init;
begin
  FDepth := 0;
end;

destructor TXmlReader.Done;
begin
end;

procedure TXmlReader.OnDocumentBegin;
begin
end;

procedure TXmlReader.OnDocumentEnd;
begin
end;

procedure TXmlReader.OnHeaderBegin(const HeaderTag: TAnsiView);
begin
end;

procedure TXmlReader.OnHeaderEnd(const HeaderTag: TAnsiView);
begin
end;

procedure TXmlReader.OnOpenTagBegin(Parser: PXmlParser; const Name: TAnsiView);
begin
  Inc(FDepth);
end;

procedure TXmlReader.OnAttribute(Parser: PXmlParser; const Name, Value: TAnsiView);
begin
end;

procedure TXmlReader.OnOpenTagEnd(Parser: PXmlParser; const Name: TAnsiView);
begin
end;

procedure TXmlReader.OnContent(Parser: PXmlParser; const Content: TAnsiView);
begin
end;

procedure TXmlReader.OnCloseTag(Parser: PXmlParser; const Name: TAnsiView);
begin
  Dec(FDepth);
end;

function IsAlphaNum(B: Byte): Boolean;
begin
  Result := B in [Ord('a')..Ord('z'), Ord('A')..Ord('Z'), Ord('0')..Ord('9'), Ord('_')];
end;

function IsAttrChar(B: Byte): Boolean;
begin
  Result := B in [Ord('a')..Ord('z'), Ord('A')..Ord('Z'), Ord('0')..Ord('9'), Ord(':'), Ord('_')];
end;

function TXmlParser.CurrentSourcePos: TSourcePos;
begin
  Result.Line := FLookupReader.Line;
  Result.Pos := FLookupReader.Pos;
end;

procedure TXmlParser.SaveSourcePos(out SourcePos: TSourcePos);
begin
  SourcePos.Line := FLookupReader.Line;
  SourcePos.Pos := FLookupReader.Pos;
end;

function TXmlParser.RaiseError(const SourcePos: TSourcePos; Id: LongInt; const Msg: AnsiString): Boolean;
begin
  Exit(SetupError(@FError, Id, '(' + IntToStr(SourcePos.Line) + ',' + IntToStr(SourcePos.Pos) + ') ' + Msg));
end;

function TXmlParser.ReadName(var Name: AnsiString): Boolean;
begin
  Name := '';
  while IsAlphaNum(FLookupReader.Lookup) do begin
    Name := Name + AnsiChar(FLookupReader.Lookup);
    if not FLookupReader.NextChar then
      Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  end;
  Exit(True);
end;

function TXmlParser.ParseHeader: Boolean;
var
  Name: AnsiString;
  SourcePos: TSourcePos;
begin
  if not FLookupReader.NextChar then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  FLookupReader.SkipSpaces;
  SaveSourcePos(SourcePos);
  if not ReadName(Name) then
    Exit(False);
  if Name <> 'xml' then
    Exit(RaiseError(SourcePos, XML_ERROR_UNKNOWN_XML_HEADER, 'unknown xml header: ' + Name));
  FReader^.OnHeaderBegin(Name);
  FLookupReader.SkipSpaces;
  while FLookupReader.Lookup <> Ord('?') do begin
    if not ParseAttribute then
      Exit(False);
    FLookupReader.SkipSpaces;
  end;
  if not FLookupReader.NextChar then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  SaveSourcePos(SourcePos);
  FLookupReader.SkipSpaces;
  if not FLookupReader.Match('>') then
    Exit(RaiseError(SourcePos, XML_ERROR_UNEXPECTED_XML_HEADER_END, 'unexpected header end'));
  FReader^.OnHeaderEnd(Name);
  Exit(True);
end;

function TXmlParser.ParseAttribute: Boolean;
var
  Name, Value: AnsiString;
  SourcePos: TSourcePos;
begin
  Name := '';
  SaveSourcePos(SourcePos);
  while IsAttrChar(FLookupReader.Lookup) do begin
    Name := Name + AnsiChar(FLookupReader.Lookup);
    if not FLookupReader.NextChar then
      Exit(RaiseError(SourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
    SaveSourcePos(SourcePos);
  end;
  if Name = '' then
    Exit(RaiseError(SourcePos, XML_ERROR_INVALID_PARAM_NAME, 'invalid parameter name'));
  FLookupReader.SkipSpaces;
  if not FLookupReader.Match('=') then
    Exit(RaiseError(SourcePos, XML_ERROR_NO_EQUAL_SIGN, 'no equal sign in tag parameter'));
  FLookupReader.SkipSpaces;
  SaveSourcePos(SourcePos);
  if not FLookupReader.Match('"') then
    Exit(RaiseError(SourcePos, XML_ERROR_NO_QUOTE_MARK, 'no quote mark for parameter value'));
  Value := '';
  while FLookupReader.Lookup <> Ord('"') do begin
    Value := Value + AnsiChar(FLookupReader.Lookup);
    if not FLookupReader.NextChar then
      Exit(RaiseError(SourcePos, XML_ERROR_MISSED_CLOSE_QUOTE_MARK, 'missed close quote mark'));
  end;
  FReader^.OnAttribute(@Self, Name, Value);
  SaveSourcePos(SourcePos);
  if not FLookupReader.NextChar then
    Exit(RaiseError(SourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  Exit(True);
end;

function TXmlParser.ParseTag: Boolean;
var
  SourcePos: TSourcePos;
  Recursed: TRecursiveState;
  SavedRecursed: PRecursiveState;
begin
  Recursed.Name := '';
  SaveSourcePos(SourcePos);
  while IsAlphaNum(FLookupReader.Lookup) do begin
    Recursed.Name := Recursed.Name + AnsiChar(FLookupReader.Lookup);
    if not FLookupReader.NextChar then
      Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  end;
  if Recursed.Name = '' then
    Exit(RaiseError(SourcePos, XML_ERROR_INVALID_TAG_NAME, 'invalid tag name'));
  Recursed.Recursed := False;
  Recursed._Result := True;
  SavedRecursed := FRecursed;
  FRecursed := @Recursed;
  FReader^.OnOpenTagBegin(@Self, Recursed.Name);
  FRecursed := SavedRecursed;
  if Recursed.Recursed then begin
    Exit(True); // TODO get result from recursed function
  end else
    Exit(ParseAfterOpenTagBegin(Recursed.Name));
end;

function TXmlParser.ParseAfterOpenTagBegin(const Name: AnsiString): Boolean;
var
  CloseName: AnsiString;
  SourcePos: TSourcePos;
begin
  if not FLookupReader.SkipSpaces then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  while FLookupReader.Lookup <> Ord('>') do begin
    if FLookupReader.Lookup = Ord('/') then begin
      if not FLookupReader.NextChar then
        Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
      FLookupReader.SkipSpaces;
      if not FLookupReader.Match('>') then
        Exit(RaiseError(CurrentSourcePos, XML_ERROR_INVALID_ONE_LINER_TAG, 'invalid one liner tag'));
      FReader^.OnOpenTagEnd(@Self, Name);
      FReader^.OnCloseTag(@Self, Name);
      Exit(True);
    end;
    if not ParseAttribute then
      Exit(False);
    if not FLookupReader.SkipSpaces then
      Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  end;
  if not FLookupReader.NextChar then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  FReader^.OnOpenTagEnd(@Self, Name);
  if not ParseContent then
    Exit(False);
  if not FLookupReader.NextChar then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  CloseName := '';
  SaveSourcePos(SourcePos);
  while IsAlphaNum(FLookupReader.Lookup) do begin
    CloseName := CloseName + AnsiChar(FLookupReader.Lookup);
    if not FLookupReader.NextChar then
      Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  end;
  if CloseName = '' then
    Exit(RaiseError(SourcePos, XML_ERROR_INVALID_TAG_NAME, 'invalid tag name'));
  if Name <> CloseName then
    Exit(RaiseError(SourcePos, XML_ERROR_OPEN_AND_CLOSE_DISMATCHING, 'close tag "' + CloseName + '" does not match open "' + Name + '"'));
  FReader^.OnCloseTag(@Self, CloseName);
  if not FLookupReader.SkipSpaces then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
  if not FLookupReader.Match('>') then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_GT_EXPECTED, 'expected close mark'));
  Exit(True);
end;

function TXmlParser.ParseContent: Boolean;
var
  Content: AnsiString;
begin
  while True do begin
    Content := '';
    while FLookupReader.Lookup <> Ord('<') do begin
      Content := Content + AnsiChar(FLookupReader.Lookup);
      if not FLookupReader.NextChar then
        Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
    end;
    FReader^.OnContent(@Self, Content);
    if not (FLookupReader.NextChar and FLookupReader.SkipSpaces) then
      Exit(RaiseError(CurrentSourcePos, XML_ERROR_UNEXPECTED_END, 'unexpected end of input'));
    if FLookupReader.Lookup = Ord('/') then
      Exit(True);
    if not ParseTag then
      Exit(False);
  end;
end;

function TXmlParser.DoParse: Boolean;
var
  SourcePos: TSourcePos;
begin
  FReader^.OnDocumentBegin;
  if not FLookupReader.NextChar then
    Exit(RaiseError(CurrentSourcePos, XML_ERROR_EMPTY, 'empty input is not valid xml'));
  FLookupReader.SkipSpaces;
  SaveSourcePos(SourcePos);
  if not FLookupReader.Match('<') then
    Exit(RaiseError(SourcePos, XML_ERROR_LT_EXPECTED, 'xml must starts with tag'));
  FLookupReader.SkipSpaces;
  if FLookupReader.Lookup = Ord('?') then begin
    if not ParseHeader then
      Exit(False);
    FLookupReader.SkipSpaces;
    SaveSourcePos(SourcePos);
    if not FLookupReader.Match('<') then
      Exit(RaiseError(SourcePos, XML_ERROR_LT_EXPECTED, 'xml must starts with tag'));
  end;
  if not ParseTag then
    Exit(False);
  FReader^.OnDocumentEnd;
  Exit(True);
end;

constructor TXmlParser.Init;
begin
end;

destructor TXmlParser.Done;
begin
end;

function TXmlParser.Parse(Data: TData; Reader: PXmlReader): Boolean;
begin
  FReader := Reader;
  FLookupReader.Init(Data);
  Result := DoParse;
  // we don't need to free Data manually, it will be done inside LookupReader
  FLookupReader.Done;
end;

function TXmlParser.Recurse(NewReader: PXmlReader): Boolean;
var
  SavedReader: PXmlReader;
begin
  if FRecursed = nil then
    Exit(False);
  FRecursed^.Recursed := True;
  SavedReader := FReader;
  FReader := NewReader;
  Result := ParseAfterOpenTagBegin(FRecursed^.Name);
  FRecursed^._Result := Result;
  FReader := SavedReader;
end;

procedure TXmlParser.SetReader(NewReader: PXmlReader);
begin
  FReader := NewReader;
end;

function ParseXml(Data: TData; Reader: PXmlReader; Error: PError = nil): Boolean;
var
  Parser: TXmlParser;
begin
  Parser.Init;
  Result := Parser.Parse(Data, Reader);
  if (not Result) and (Error <> nil) then
    Error^ := Parser.Error;
  Parser.Done;
end;

function ConvertAmpCode(const AmpCode: TAnsiView): AnsiString;
begin
  if AmpCode = 'quot' then begin
    Result := '"';
  end else if AmpCode = 'amp' then begin
    Result := '&';
  end else if AmpCode = 'lt' then begin
    Result := '<';
  end else if AmpCode = 'gt' then begin
    Result := '>';
  end else
    Result := '&' + AmpCode.ToString + ';';
end;

function UnescapeHTML(const S: TAnsiView): AnsiString;
var
  I: LongInt;
  Code: AnsiString;
begin
  // optimization for most common case
  if AnsiPos('&', S) = 0 then
    Exit(S.ToString);
  Result := '';
  I := 1;
  while I <= S.Length do begin
    if S[I] = '&' then begin
      Inc(I);
      Code := '';
      while I <= S.Length do begin
        if S[I] = ';' then begin
          Result := Result + ConvertAmpCode(Code);
          Break;
        end;
        Code := Code + S[I];
        Inc(I);
      end;
      if I > S.Length then
        Result := Result + '&' + Code;
    end else
      Result := Result + S[I];
    Inc(I);
  end;
end;

end.
