viewcvs.cgi/runtime/load_xml.ml

(* Loading XML documents *)

(*TODO: close the file ! *)

open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Value
open Ident

let is_ws s =
  let rec check i = 
    (i < 0) || 
    (match s.[i] with
       | ' ' | '\t' | '\n' | '\r' -> check (i - 1) 
       | _ -> false) in
  check (String.length s - 1)


let string s q =
  String (0,String.length s,s,q)

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

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

let load_xml_aux s =
  let config = { default_config with 
                   store_element_positions = false;
                   drop_ignorable_whitespace = true
               }
  in
  let mgr = create_entity_manager config (from_file s) in
  let next_event = 
    create_pull_parser config (`Entry_document[]) mgr in
  let curr = ref E_end_of_stream in
  let get () =
    match next_event () with 
      | Some (E_error exn) -> failwith (Pxp_types.string_of_exn exn)
      | Some E_end_of_stream -> failwith "Unexpected end of XML stream"
      | Some x -> curr := x 
      | None -> () in

  let txt = Buffer.create 1024 in

  let rec parse_elt name att =
    let elt = elem name att (parse_seq ()) in
    (match !curr with
       | E_end_tag (_,_) -> get ()
       | _ -> failwith "Expect end_tag");
    elt
      

  and dump_txt q =
    let data = Buffer.contents txt in
    Buffer.clear txt;
    if (is_ws data) then q () else string data (q ())
      
  and parse_seq () =
    match !curr with
      | E_start_tag (name,att,_) ->
          get ();
          dump_txt (fun () ->
                      let e1 = parse_elt name att in
                      let rest = parse_seq () in
                      Pair (e1, rest)
                   )
      | E_char_data data ->
          get();
          Buffer.add_string txt data;
          parse_seq ()
      | E_end_tag (_,_) ->
          dump_txt (fun () -> nil)
      | _ -> failwith "Expect start_tag, char_data, or end_tag"
          
  and parse_doc () =
    match !curr with
      | E_start_tag (name,att,_) ->  get (); parse_elt name att
      | _ -> get (); parse_doc ()
  in
  get ();
  parse_doc ()


let load_xml s =
  Location.protect_op "load_xml";
  try load_xml_aux s 
  with exn ->
    raise
      (Location.Generic (Pxp_types.string_of_exn exn))
      

let load_html s =
  let rec val_of_doc q = function
    | Nethtml.Data data -> 
        if (is_ws 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_xml";
  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 ~subst:(fun _ -> "???") doc in
  close_in ic;
  val_of_docs doc
1	abate	70	(* Loading XML documents *)
2
3			(TODO: close the file ! )
4
5			open Pxp_yacc
6			open Pxp_lexer_types
7			open Pxp_types
8			open Value
9	abate	233	open Ident
10	abate	70
11	abate	131	let is_ws s =
12			let rec check i =
13			(i < 0) \|\|
14			(match s.[i] with
15			\| ' ' \| '\t' \| '\n' \| '\r' -> check (i - 1)
16			\| _ -> false) in
17			check (String.length s - 1)
18
19
20	abate	70	let string s q =
21	abate	131	String (0,String.length s,s,q)
22	abate	70
23	abate	188	let attrib att =
24	abate	233	let att = List.map (fun (l,v) -> LabelPool.mk l, string v nil) att in
25			LabelMap.from_list (fun _ _ -> assert false) att
26	abate	188
27			let elem tag att child =
28	abate	222	Xml (Atom (Atoms.mk tag), Pair (Record (attrib att), child))
29	abate	188
30			let load_xml_aux s =
31	abate	70	let config = { default_config with
32			store_element_positions = false;
33			drop_ignorable_whitespace = true
34			}
35			in
36			let mgr = create_entity_manager config (from_file s) in
37			let next_event =
38			create_pull_parser config (`Entry_document[]) mgr in
39			let curr = ref E_end_of_stream in
40			let get () =
41			match next_event () with
42	abate	83	\| Some (E_error exn) -> failwith (Pxp_types.string_of_exn exn)
43			\| Some E_end_of_stream -> failwith "Unexpected end of XML stream"
44	abate	70	\| Some x -> curr := x
45			\| None -> () in
46
47	abate	172	let txt = Buffer.create 1024 in
48
49	abate	70	let rec parse_elt name att =
50	abate	188	let elt = elem name att (parse_seq ()) in
51	abate	70	(match !curr with
52			\| E_end_tag (_,_) -> get ()
53			\| _ -> failwith "Expect end_tag");
54			elt
55
56	abate	172
57			and dump_txt q =
58			let data = Buffer.contents txt in
59			Buffer.clear txt;
60			if (is_ws data) then q () else string data (q ())
61	abate	70
62	abate	172	and parse_seq () =
63	abate	70	match !curr with
64	abate	172	\| E_start_tag (name,att,_) ->
65	abate	70	get ();
66	abate	172	dump_txt (fun () ->
67			let e1 = parse_elt name att in
68			let rest = parse_seq () in
69			Pair (e1, rest)
70			)
71	abate	70	\| E_char_data data ->
72	abate	172	get();
73			Buffer.add_string txt data;
74			parse_seq ()
75	abate	70	\| E_end_tag (_,_) ->
76	abate	172	dump_txt (fun () -> nil)
77	abate	70	\| _ -> failwith "Expect start_tag, char_data, or end_tag"
78
79			and parse_doc () =
80			match !curr with
81			\| E_start_tag (name,att,_) -> get (); parse_elt name att
82			\| _ -> get (); parse_doc ()
83			in
84			get ();
85	abate	73	parse_doc ()
86
87	abate	91
88	abate	188	let load_xml s =
89	abate	126	Location.protect_op "load_xml";
90	abate	188	try load_xml_aux s
91	abate	91	with exn ->
92			raise
93			(Location.Generic (Pxp_types.string_of_exn exn))
94
95	abate	188
96			let load_html s =
97			let rec val_of_doc q = function
98			\| Nethtml.Data data ->
99			if (is_ws data) then q else string data q
100			\| Nethtml.Element (tag, att, child) ->
101			Pair (elem tag att (val_of_docs child), q)
102			and val_of_docs = function
103			\| [] -> nil
104			\| h::t -> val_of_doc (val_of_docs t) h
105			in
106
107			Location.protect_op "load_xml";
108			let ic = open_in s in
109			let doc = Nethtml.parse_document
110			~dtd:Nethtml.relaxed_html40_dtd
111			(Lexing.from_channel ic) in
112			let doc = Nethtml.decode ~subst:(fun _ -> "???") doc in
113			close_in ic;
114			val_of_docs doc