viewcvs.cgi/runtime/load_xml.ml

(* Loading XML documents *)

(*TODO: close the file ! *)

let auth = ref true
let set_auth b = auth := b

open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Value

let string s q =
  let rec check_ws i = (i < 0) || 
                       (match s.[i] with
                          | ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1) 
                          | _ -> false) in
  if check_ws (String.length s - 1) then q 
  else String (0,String.length s,s,q)

let run 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 rec parse_elt name att =
    let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
    let att = SortedMap.from_list (fun _ _ -> assert false) att in
    let child = parse_seq () in
    
    let elt = Xml 
                (Atom (Types.AtomPool.mk name),
                 Pair (Record att, child)
                ) in
    (match !curr with
       | E_end_tag (_,_) -> get ()
       | _ -> failwith "Expect end_tag");
    elt
      
      
  and parse_seq () =
    match !curr with
      | E_start_tag (name,att,_) -> 
          get ();
          let e1 = parse_elt name att in
          let rest = parse_seq () in
          Pair (e1, rest)
      | E_char_data data ->
          get ();
          let rest = parse_seq () in
          string data rest
      | E_end_tag (_,_) ->
          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 run s =
  if not !auth then
    raise 
      (Location.Generic
         "load_xml: operation not authorized in the web prototype"
      );
  try run s 
  with exn ->
    raise
      (Location.Generic (Pxp_types.string_of_exn exn))
      
1	abate	70	(* Loading XML documents *)
2
3			(TODO: close the file ! )
4
5	abate	91	let auth = ref true
6			let set_auth b = auth := b
7
8	abate	70	open Pxp_yacc
9			open Pxp_lexer_types
10			open Pxp_types
11			open Value
12
13			let string s q =
14			let rec check_ws i = (i < 0) \|\|
15			(match s.[i] with
16			\| ' ' \| '\t' \| '\n' \| '\r' -> check_ws (i - 1)
17			\| _ -> false) in
18			if check_ws (String.length s - 1) then q
19			else String (0,String.length s,s,q)
20
21			let run s =
22			let config = { default_config with
23			store_element_positions = false;
24			drop_ignorable_whitespace = true
25			}
26			in
27			let mgr = create_entity_manager config (from_file s) in
28			let next_event =
29			create_pull_parser config (`Entry_document[]) mgr in
30			let curr = ref E_end_of_stream in
31			let get () =
32			match next_event () with
33	abate	83	\| Some (E_error exn) -> failwith (Pxp_types.string_of_exn exn)
34			\| Some E_end_of_stream -> failwith "Unexpected end of XML stream"
35	abate	70	\| Some x -> curr := x
36			\| None -> () in
37
38			let rec parse_elt name att =
39	abate	78	let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
40	abate	70	let att = SortedMap.from_list (fun _ _ -> assert false) att in
41			let child = parse_seq () in
42
43	abate	110	let elt = Xml
44	abate	78	(Atom (Types.AtomPool.mk name),
45	abate	70	Pair (Record att, child)
46			) in
47			(match !curr with
48			\| E_end_tag (_,_) -> get ()
49			\| _ -> failwith "Expect end_tag");
50			elt
51
52
53			and parse_seq () =
54			match !curr with
55			\| E_start_tag (name,att,_) ->
56			get ();
57			let e1 = parse_elt name att in
58			let rest = parse_seq () in
59			Pair (e1, rest)
60			\| E_char_data data ->
61			get ();
62			let rest = parse_seq () in
63			string data rest
64			\| E_end_tag (_,_) ->
65			nil
66			\| _ -> failwith "Expect start_tag, char_data, or end_tag"
67
68			and parse_doc () =
69			match !curr with
70			\| E_start_tag (name,att,_) -> get (); parse_elt name att
71			\| _ -> get (); parse_doc ()
72			in
73			get ();
74	abate	73	parse_doc ()
75
76	abate	91
77			let run s =
78			if not !auth then
79			raise
80			(Location.Generic
81			"load_xml: operation not authorized in the web prototype"
82			);
83			try run s
84			with exn ->
85			raise
86			(Location.Generic (Pxp_types.string_of_exn exn))
87