load_xml.ml

(* Loading XML documents *)

ifdef EXPAT then
  let expat_support = true
else
  let expat_support = false

let use_parser = ref (if expat_support then `Expat else `Pxp)

open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Value
open Ident
open Encodings

type buf =
    { mutable buffer : string;
      mutable pos : int;
      mutable length : int }

let txt = { buffer = String.create 1024; pos = 0; length = 1024 }

let resize n =
  let new_len = txt.length * 2 + n in
  let new_buf = String.create new_len in
  String.unsafe_blit txt.buffer 0 new_buf 0 txt.pos;
  txt.buffer <- new_buf;
  txt.length <- new_len

let add_string s =
  let len = String.length s in
  let new_pos = txt.pos + len in
  if new_pos > txt.length then resize len;
  String.unsafe_blit s 0 txt.buffer txt.pos len;
  txt.pos <- new_pos

let rec only_ws s i =
  (i = 0) ||
  (let i = pred i in match (String.unsafe_get s i) with
     | ' ' | '\t' | '\n' | '\r' -> only_ws s i
     | _ -> false) 


let string s q =
  let s = Utf8.mk s in
  String_utf8 (Utf8.start_index s,Utf8.end_index s, s, q)


let attrib att = 
  let att = List.map (fun (l,v) -> LabelPool.mk (U.mk l), string v nil) att in
  LabelMap.from_list (fun _ _ -> assert false) att

let elem tag att child =
  Xml (Atom (Atoms.mk (U.mk tag)), Record (attrib att), child)

(*
class warner = object method warn w =  print_endline ("PXP WARNING: " ^ w) end
*)

type token = 
  | Element of Value.t 
  | Start of string * (string * string) list 
  | String of string

let stack = ref []

let rec create_elt accu = function
  | String s :: st -> create_elt (string s accu) st
  | Element x :: st -> create_elt (Pair (x,accu)) st
  | Start (name,att) :: st -> stack := Element (elem name att accu) :: st
  | [] -> assert false



let start_element_handler name att =
  if not (only_ws txt.buffer txt.pos) then 
    stack := String (String.sub txt.buffer 0 txt.pos) :: !stack; 
  txt.pos <- 0;   
  stack := Start (name,att) :: !stack

let end_element_handler _ =
  let accu =
    if only_ws txt.buffer txt.pos 
    then nil 
    else string (String.sub txt.buffer 0 txt.pos) nil in
  txt.pos <- 0; 
  create_elt accu !stack

ifdef EXPAT then

let load_expat =
  let buflen = 1024 in
  let buf = String.create buflen in
  fun s -> 
  let ic = 
    try open_in s
    with exn ->
      let msg = 
	Printf.sprintf "load_xml, file \"%s\": %s" s (Printexc.to_string exn)
      in
      raise (Location.Generic msg)
  in
  let p = Expat.parser_create "" in
  Expat.set_start_element_handler p start_element_handler;
  Expat.set_end_element_handler p end_element_handler;
  Expat.set_character_data_handler p add_string;
  let rec loop () =
    let n = input ic buf 0 buflen in
    if (n > 0) then (Expat.parse_sub p buf 0 n; loop ()) 
  in
  try 
    loop(); 
    Expat.final p;
    close_in ic;
  with 
      Expat.Expat_error e -> 
	close_in ic;
	let line = Expat.get_current_line_number p 
	and col  = Expat.get_current_column_number p in
	let msg =
	  Printf.sprintf
	    "load_xml, file \"%s\", at line %i, column %i: %s"
	    s 
	    (Expat.get_current_line_number p)
	    (Expat.get_current_column_number p)
	    (Expat.xml_error_to_string e)
	in
	raise (Location.Generic msg)
else

let load_expat s =
  failwith "Expat support not included"

let pxp_handle_event = function
  | E_start_tag (name,att,_) -> start_element_handler name att
  | E_char_data data -> add_string data
  | E_end_tag (_,_) -> end_element_handler ()
  | _ -> ()

let pxp_config = 
  { default_config with 
      (* warner = new warner; *)
      encoding = `Enc_utf8;
      store_element_positions = false;
      drop_ignorable_whitespace = true
  }

let load_pxp s =
  try
    let mgr = create_entity_manager pxp_config (from_file s) in
    process_entity pxp_config (`Entry_document[`Extend_dtd_fully]) mgr pxp_handle_event;
  with exn ->
    raise (Location.Generic (Pxp_types.string_of_exn exn))

let load_xml s =
  Location.protect_op "load_xml";
  try
    (match !use_parser with
       | `Expat -> load_expat s
       | `Pxp -> load_pxp s);
    match !stack with
      | [ Element x ] -> stack := []; x
      | _ -> assert false
  with e -> stack := []; txt.pos <-0; raise e

      

let load_html s =
  let rec val_of_doc q = function
    | Nethtml.Data data -> 
	if (only_ws data (String.length data)) then q else string data q
    | Nethtml.Element (tag, att, child) -> 
	Pair (elem tag att (val_of_docs child), q)
  and val_of_docs = function
    | [] -> nil
    | h::t -> val_of_doc (val_of_docs t) h
  in	

  Location.protect_op "load_html";
  let ic = open_in s in
  let doc = Nethtml.parse_document 
	      ~dtd:Nethtml.relaxed_html40_dtd 
	      (Lexing.from_channel ic) in
  let doc = Nethtml.decode ~enc:`Enc_utf8 ~subst:(fun _ -> "???") doc in
  close_in ic;
  val_of_docs doc