Source file xml.ml

(*
 * Xml Light, an small Xml parser/printer with DTD support.
 * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
 *
 * 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

type xml = Types.xml =
	| Element of (string * (string * string) list * xml list)
	| PCData of string

type error_pos = Types.error_pos = {
	eline : int;
	eline_start : int;
	emin : int;
	emax : int;
}

type error_msg = Types.error_msg =
	| UnterminatedComment
	| UnterminatedString
	| UnterminatedEntity
	| IdentExpected
	| CloseExpected
	| NodeExpected
	| AttributeNameExpected
	| AttributeValueExpected
	| EndOfTagExpected of string
	| EOFExpected

type error = error_msg * error_pos

exception Error of error
exception File_not_found of string

exception Not_element of xml
exception Not_pcdata of xml
exception No_attribute of string

let default_parser = XmlParser.make()

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

let parse (p:XmlParser.t) (source:XmlParser.source) =
  XmlParser.parse p source

let parse_string_with p str = parse p (XmlParser.SString str)

let parse_in ch = parse default_parser (XmlParser.SChannel ch)
let parse_string str = parse_string_with default_parser str

let parse_file f =
	let p = XmlParser.make() in
	let path = Filename.dirname f in
	XmlParser.resolve p (fun file ->
		let name = (match path with "." -> file | _ -> path ^ "/" ^ file) in
		Dtd.check (Dtd.parse_file name)
	);
	parse p (XmlParser.SFile f)

let error_msg = function
	| UnterminatedComment -> "Unterminated comment"
	| UnterminatedString -> "Unterminated string"
	| UnterminatedEntity -> "Unterminated entity"
	| IdentExpected -> "Ident expected"
	| CloseExpected -> "Element close expected"
	| NodeExpected -> "Xml node expected"
	| AttributeNameExpected -> "Attribute name expected"
	| AttributeValueExpected -> "Attribute value expected"
	| EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
	| EOFExpected -> "End of file expected"

let error (msg,pos) =
	if pos.emin = pos.emax then
		sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
	else
		sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)

let line e = e.eline

let range e =
	e.emin - e.eline_start , e.emax - e.eline_start

let abs_range e =
	e.emin , e.emax

let tag = function
	| Element (tag,_,_) -> tag
	| x -> raise (Not_element x)

let pcdata = function
	| PCData text -> text
	| x -> raise (Not_pcdata x)

let attribs = function
	| Element (_,attr,_) -> attr
	| x -> raise (Not_element x)

let attrib x att =
	match x with
	| Element (_,attr,_) ->
		(try
			let att = String.lowercase_ascii att in
			snd (List.find (fun (n,_) -> String.lowercase_ascii n = att) attr)
		with
			Not_found ->
				raise (No_attribute att))
	| x ->
		raise (Not_element x)

let children = function
	| Element (_,_,clist) -> clist
	| x -> raise (Not_element x)

(*let enum = function
	| Element (_,_,clist) -> List.to_enum clist
	| x -> raise (Not_element x)
*)

let iter f = function
	| Element (_,_,clist) -> List.iter f clist
	| x -> raise (Not_element x)

let map f = function
	| Element (_,_,clist) -> List.map f clist
	| x -> raise (Not_element x)

let fold f v = function
	| Element (_,_,clist) -> List.fold_left f v clist
	| x -> raise (Not_element x)

module type X = sig
  type t
  val add_char : t -> char -> unit
  val add_string : t -> string -> unit
end

module Make(Buffer:X) = struct


let is_leading_character_of_decimal_or_hexidecimal char =
  ('0' <= char && char <= '9') || char = 'x'
;;

let buffer_pcdata ~tmp text =
	let l = String.length text in
	for p = 0 to l-1 do
		match text.[p] with
		| '>' -> Buffer.add_string tmp "&gt;"
		| '<' -> Buffer.add_string tmp "&lt;"
         	| '&' ->
                        (* The condition is [p < l-3] instead of [p < l-2] to account for
                           a potential semi-colon. *)
                        if p < l-3 && text.[p+1] = '#' && is_leading_character_of_decimal_or_hexidecimal text.[p+2] then
                        (* According to https://en.wikipedia.org/wiki/XML#Escaping and
                           https://en.wikipedia.org/wiki/List_of_XML_and_HTML_character_entity_references#Character_reference_overview,
                           valid escape sequences starting with "&#" are in the form:
                           [&#NUMERIC_VALUE;]
                           , where NUMERIC_VALUE can be hexadecimal or decimal. For
                           example, "&#20013;" or "&#x4e2d;".
                        *)
                          Buffer.add_char tmp '&'
                        else
                          Buffer.add_string tmp "&amp;"
		| '\''-> Buffer.add_string tmp "&apos;"
		| '"' -> Buffer.add_string tmp "&quot;"
		| c   -> Buffer.add_char tmp c
	done

let buffer_attr ~tmp (n,v) =
	Buffer.add_char tmp ' ';
	Buffer.add_string tmp n;
	Buffer.add_string tmp "=\"";
	let l = String.length v in
	for p = 0 to l-1 do
		match v.[p] with
		| '"' -> Buffer.add_string tmp "&quot;"
		| c -> Buffer.add_char tmp c
	done;
	Buffer.add_char tmp '"'

let tag_for_silly_humans tag =
  let new_string = Bytes.of_string tag in
  let new_string = Bytes.capitalize_ascii new_string in
  for i = (Bytes.length new_string) - 1 downto 0 do
    match Bytes.get new_string i with
    | '_' -> Bytes.set new_string i ' '
    | _ -> ()
  done;
  let new_string = Bytes.to_string new_string in
  new_string ^ ": "

let reformat_tag ~format tag =
  match format with
  | `Xml -> tag
  | `No_tag -> tag_for_silly_humans tag

let write tmp x =
	let pcdata = ref false in
	let rec loop = function
		| Element (tag,alist,[]) ->
      Buffer.add_char tmp '<';
      Buffer.add_string tmp tag;
			List.iter (buffer_attr ~tmp) alist;
      Buffer.add_string tmp "/>";
			pcdata := false;
		| Element (tag,alist,l) ->
      Buffer.add_char tmp '<';
      Buffer.add_string tmp tag;
			List.iter (buffer_attr ~tmp) alist;
			Buffer.add_char tmp '>';
			pcdata := false;
			List.iter loop l;
			Buffer.add_string tmp "</";
			Buffer.add_string tmp tag;
			Buffer.add_char tmp '>';
			pcdata := false;
		| PCData text ->
			if !pcdata then Buffer.add_char tmp ' ';
			buffer_pcdata ~tmp text;
			pcdata := true;
	in
	loop x;
;;

let add_char_if_xml ~format tmp char =
  match format with
  | `Xml -> Buffer.add_char tmp char
  | `No_tag -> ()

let add_string_if_xml ~format tmp string =
  match format with
  | `Xml -> Buffer.add_string tmp string
  | `No_tag -> ()


let write_fmt tmp ~format x =
	let rec loop tab = function
		| Element (tag,alist,[]) ->
      if format = `Xml then begin
        Buffer.add_string tmp tab;
        add_char_if_xml ~format tmp '<';
        Buffer.add_string tmp (reformat_tag ~format tag);
        List.iter (buffer_attr ~tmp) alist;
        add_string_if_xml ~format tmp "/>";
        Buffer.add_char tmp '\n';
      end
		| Element (tag,alist,[PCData text]) ->
			Buffer.add_string tmp tab;
			add_char_if_xml ~format tmp '<';
			Buffer.add_string tmp (reformat_tag ~format tag);
			List.iter (buffer_attr ~tmp) alist;
			add_string_if_xml ~format tmp ">";
			buffer_pcdata ~tmp text;
      if format = `Xml then begin
        Buffer.add_string tmp "</";
        Buffer.add_string tmp tag;
        Buffer.add_char tmp '>';
      end;
			Buffer.add_char tmp '\n';
		| Element (tag,alist,l) ->
			Buffer.add_string tmp tab;
			add_char_if_xml ~format tmp '<';
			Buffer.add_string tmp (reformat_tag ~format tag);
			List.iter (buffer_attr ~tmp) alist;
			add_string_if_xml ~format tmp ">";
      Buffer.add_char tmp '\n';
			List.iter (loop (tab^"  ")) l;
      if format = `Xml then begin
        Buffer.add_string tmp tab;
        Buffer.add_string tmp "</";
        Buffer.add_string tmp tag;
        Buffer.add_char tmp '>';
      end;
			Buffer.add_char tmp '\n';
		| PCData text ->
			buffer_pcdata ~tmp text;
			Buffer.add_char tmp '\n';
	in
	loop "" x;
;;
end

include Make(Buffer)

let to_string xml =
  let buffer = Buffer.create 200 in
  write buffer xml;
  Buffer.contents buffer

let to_string_fmt ~format xml =
  let buffer = Buffer.create 200 in
  write_fmt buffer ~format xml;
  Buffer.contents buffer

let to_human_string x =
  let format = `No_tag in
  to_string_fmt ~format x
;;

let to_string_fmt x =
  let format = `Xml in
  to_string_fmt ~format x
;;

XmlParser._raises (fun x p ->
	Error (x,pos p))
	(fun f -> File_not_found f)
	(fun x p -> Dtd.Parse_error (x,pos p));
Dtd._raises (fun f -> File_not_found f);