(*
 * Xml Light, an small Xml parser/printer with DTD support.
 * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
 * Copyright (C) 2003 Jacques Garrigue
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library has the special exception on linking described in file
 * README.
 *
 * This library 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.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
 * MA 02110-1301 USA
 *)

open Printf
open Xml_light_types
open Xml_light_errors

type t = {
  mutable prove : bool;
  mutable check_eof : bool;
  mutable concat_pcdata : bool;
  mutable resolve : string -> Xml_light_dtd_check.checked;
}

type source =
  | SFile of string
  | SChannel of in_channel
  | SString of string
  | SLexbuf of Lexing.lexbuf

type state = {
  source : Lexing.lexbuf;
  stack : Xml_lexer.token Stack.t;
  xparser : t;
}

exception Internal_error of xml_error_msg
exception NoMoreData

let make () =
  {
    prove = true;
    check_eof = true;
    concat_pcdata = true;
    resolve = (fun file -> raise (File_not_found file));
  }

let prove p v = p.prove <- v
let resolve p f = p.resolve <- f
let check_eof p v = p.check_eof <- v
let concat_pcdata p v = p.concat_pcdata <- v
let pop s = try Stack.pop s.stack with Stack.Empty -> Xml_lexer.token s.source
let push t s = Stack.push t s.stack

let rec read_node s =
  match pop s with
    | Xml_lexer.PCData s -> PCData s
    | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
    | Xml_lexer.Tag (tag, attr, false) -> Element (tag, attr, read_elems ~tag s)
    | t ->
        push t s;
        raise NoMoreData

and read_elems ?tag s =
  let elems = ref [] in
  (try
     while true do
       match (s.xparser.concat_pcdata, read_node s, !elems) with
         | true, PCData c, PCData c2 :: q ->
             elems := PCData (sprintf "%s\n%s" c2 c) :: q
         | _, x, l -> elems := x :: l
     done
   with NoMoreData -> ());
  match pop s with
    | Xml_lexer.Endtag s when Some s = tag -> List.rev !elems
    | Xml_lexer.Eof when tag = None -> List.rev !elems
    | t -> (
        match tag with
          | None -> raise (Internal_error EOFExpected)
          | Some s -> raise (Internal_error (EndOfTagExpected s)))

let read_xml s =
  match (s.xparser.prove, pop s) with
    | true, Xml_lexer.DocType (root, Xml_lexer.DTDFile file) ->
        let pos = Xml_lexer.pos s.source in
        let dtd = s.xparser.resolve file in
        Xml_lexer.restore pos;
        let x = read_node s in
        Dtd.prove dtd root x
    | true, Xml_lexer.DocType (root, Xml_lexer.DTDData dtd) ->
        let dtd = Dtd.check dtd in
        let x = read_node s in
        Dtd.prove dtd root x
    | false, Xml_lexer.DocType _ -> read_node s
    | _, t ->
        push t s;
        read_node s

let convert = function
  | Xml_lexer.EUnterminatedComment -> UnterminatedComment
  | Xml_lexer.EUnterminatedString -> UnterminatedString
  | Xml_lexer.EIdentExpected -> IdentExpected
  | Xml_lexer.ECloseExpected -> CloseExpected
  | Xml_lexer.ENodeExpected -> NodeExpected
  | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
  | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
  | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity

let dtd_convert = function
  | Xml_lexer.EInvalidDTDDecl -> InvalidDTDDecl
  | Xml_lexer.EInvalidDTDTag -> InvalidDTDTag
  | Xml_lexer.EDTDItemExpected -> DTDItemExpected
  | Xml_lexer.EInvalidDTDElement -> InvalidDTDElement
  | Xml_lexer.EInvalidDTDAttribute -> InvalidDTDAttribute

let pos source =
  let line, lstart, min, max = Xml_lexer.pos source in
  { eline = line; eline_start = lstart; emin = min; emax = max }

let do_parse xparser source =
  try
    Xml_lexer.init source;
    let s = { source; xparser; stack = Stack.create () } in
    let tk = pop s in
    (* skip UTF8 BOM *)
    if tk <> Xml_lexer.PCData "\239\187\191" then push tk s;
    let x = read_xml s in
    if xparser.check_eof && pop s <> Xml_lexer.Eof then
      raise (Internal_error EOFExpected);
    Xml_lexer.close source;
    x
  with
    | NoMoreData ->
        Xml_lexer.close source;
        raise (Xml_error (NodeExpected, pos source))
    | Internal_error e ->
        Xml_lexer.close source;
        raise (Xml_error (e, pos source))
    | Xml_lexer.Error e ->
        Xml_lexer.close source;
        raise (Xml_error (convert e, pos source))
    | Xml_lexer.DTDError e ->
        Xml_lexer.close source;
        raise (Dtd_parse_error (dtd_convert e, pos source))

let parse p = function
  | SChannel ch -> do_parse p (Lexing.from_channel ch)
  | SString str -> do_parse p (Lexing.from_string str)
  | SLexbuf lex -> do_parse p lex
  | SFile fname -> (
      let ch =
        try open_in fname with Sys_error _ -> raise (File_not_found fname)
      in
      try
        let x = do_parse p (Lexing.from_channel ch) in
        close_in ch;
        x
      with e ->
        close_in ch;
        raise e)
