viewcvs.cgi/schema/schema_xml.ml

open Encodings
open Schema_pcre

exception Error of string
let error s = raise (Error s)

type node =
  ('a Pxp_document.node Pxp_document.extension as 'a) Pxp_document.node

module Node = struct
  type t = node
  let compare = Pxp_document.compare
end

let start_with s pr =
  let s = Utf8.get_str s in
  (String.length s >= String.length pr) &&
    (String.sub s 0 (String.length pr) = pr)

let has_xsd_prefix s = start_with s "xsd:"

let xsd_namespace = Utf8.mk "http://www.w3.org/2001/XMLSchema"
let xsi_namespace = Utf8.mk "http://www.w3.org/2001/XMLSchema-instance"
let xsd_prefix = Utf8.mk "xsd"
let xsi_prefix = Utf8.mk "xsi"

let schema_ns_prefixes =
  [ xsd_prefix, xsd_namespace; xsi_prefix, xsi_namespace ]

let spec = Pxp_tree_parser.default_namespace_spec
let new_xsd_config () =
  let ns_manager = new Pxp_dtd.namespace_manager in
  List.iter
    (fun (p, ns) -> ns_manager#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
    schema_ns_prefixes;
  { Pxp_types.default_namespace_config with      
      Pxp_types.encoding = `Enc_utf8;
      Pxp_types.enable_namespace_processing = Some ns_manager
  }

let node_of src =
  (Pxp_tree_parser.parse_wfdocument_entity (new_xsd_config ()) src spec) # root

open Pxp_types
let channel_of_id rt rid =
  match rid.rid_system with
    | Some local -> 
        let s = Url.local rt local in
        let ch =
          match Url.process s with
            | Url.Url s -> new Netchannels.input_string s
            | Url.Filename s -> raise Not_competent
        in
        ch, None, None
    | None -> raise Not_competent

let node_of_uri uri =
  try
    let source = match Url.process uri with 
      | Url.Filename s -> Pxp_types.from_file s 
      | Url.Url s -> 
          let channel_of_id = channel_of_id uri in
          let r = 
            new Pxp_reader.resolve_to_any_obj_channel ~channel_of_id () in
          from_string ~alt:[r] s
    in
    node_of source
  with exn -> raise (Location.Generic (Pxp_types.string_of_exn exn))

let _may_attr name n =
  try
    match n#attribute name with
      | Pxp_types.Value v -> Some (Utf8.mk v)
      | _ -> None
  with Not_found -> None
    
let _is_attr name n v =
  try
    match n#attribute name with
      | Pxp_types.Value v' -> v = v'
      | _ -> false
  with Not_found -> false
    
let _attr name n =
  match n#attribute name with
    | Pxp_types.Value v -> Utf8.mk v
    | _ -> error ("Attribute " ^ name ^ " is missing")
        
let _may_elem e (n: node) =
  try Some (Pxp_document.find_element e n) with Not_found -> None
    
let _elems e n = Pxp_document.find_all_elements e n

let _filter_elems p n =
  Pxp_document.find_all (fun n -> match n#node_type with
                           | Pxp_document.T_element s -> List.mem s p
                           | _ -> false) n
  
let _line n = match n#position with (_,l,_) -> l
  
let _iter_nodes n f = n#iter_nodes f
  
let _iter_elems n f = n#iter_nodes
  (fun n ->
     match n#node_type with
       | Pxp_document.T_element s -> f n s
       | _ -> ()
  )

let _fold_elems n x f = 
  let x = ref x in
  n#iter_nodes
    (fun n ->
       match n#node_type with
         | Pxp_document.T_element s -> x := f !x n s
         | _ -> ()
    );
  !x
  
let _tag n =
  match n#node_type with
    | Pxp_document.T_element s -> s
    | _ -> assert false
        
let _has_tag n f =
  match n#node_type with
    | Pxp_document.T_element s -> f s
    | _ -> false
        
let _namespaces n =
  List.map 
    (fun n ->
       (match n#node_type with 
            Pxp_document.T_namespace p -> p | _ -> assert false),
       n#data
    )
    n#namespaces_as_nodes
    
let _find p n = Pxp_document.find p n

let _resolve_qname n qname =
  let (prefix,local) = Ns.split_qname qname in
  let ns = 
    try Ns.mk (Utf8.mk (n # namespace_scope # uri_of_display_prefix prefix))
    with Not_found -> Ns.empty
  in
  (ns,local)

let _may_qname_attr name n =
  match _may_attr name n with
    | Some qname -> Some (_resolve_qname n qname)
    | None -> None

let _qname_attr name n =
  match _may_attr name n with
    | Some qname -> _resolve_qname n qname
    | None -> error ("Cannot find qname attribute " ^ name)


let xsd = Ns.mk xsd_namespace
let xsi = Ns.mk xsi_namespace
1	abate	812	open Encodings
2	abate	1440	open Schema_pcre
3	abate	812
4	abate	1528	exception Error of string
5			let error s = raise (Error s)
6
7	abate	1452	type node =
8	abate	759	('a Pxp_document.node Pxp_document.extension as 'a) Pxp_document.node
9	abate	500
10	abate	1452	module Node = struct
11			type t = node
12			let compare = Pxp_document.compare
13			end
14	abate	500
15	abate	1452	let start_with s pr =
16			let s = Utf8.get_str s in
17			(String.length s >= String.length pr) &&
18			(String.sub s 0 (String.length pr) = pr)
19	abate	500
20	abate	1452	let has_xsd_prefix s = start_with s "xsd:"
21
22	abate	812	let xsd_namespace = Utf8.mk "http://www.w3.org/2001/XMLSchema"
23			let xsi_namespace = Utf8.mk "http://www.w3.org/2001/XMLSchema-instance"
24			let xsd_prefix = Utf8.mk "xsd"
25			let xsi_prefix = Utf8.mk "xsi"
26	abate	500
27	abate	759	let schema_ns_prefixes =
28			[ xsd_prefix, xsd_namespace; xsi_prefix, xsi_namespace ]
29	abate	500
30	abate	1452	let spec = Pxp_tree_parser.default_namespace_spec
31	abate	759	let new_xsd_config () =
32			let ns_manager = new Pxp_dtd.namespace_manager in
33	abate	812	List.iter
34			(fun (p, ns) -> ns_manager#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
35			schema_ns_prefixes;
36	abate	1473	{ Pxp_types.default_namespace_config with
37			Pxp_types.encoding = `Enc_utf8;
38	abate	759	Pxp_types.enable_namespace_processing = Some ns_manager
39			}
40	abate	500
41	abate	1452	let node_of src =
42	abate	1473	(Pxp_tree_parser.parse_wfdocument_entity (new_xsd_config ()) src spec) # root
43	abate	500
44	abate	1529	open Pxp_types
45			let channel_of_id rt rid =
46			match rid.rid_system with
47			\| Some local ->
48			let s = Url.local rt local in
49			let ch =
50			match Url.process s with
51			\| Url.Url s -> new Netchannels.input_string s
52			\| Url.Filename s -> raise Not_competent
53			in
54			ch, None, None
55			\| None -> raise Not_competent
56
57	abate	1458	let node_of_uri uri =
58			try
59			let source = match Url.process uri with
60			\| Url.Filename s -> Pxp_types.from_file s
61	abate	1529	\| Url.Url s ->
62			let channel_of_id = channel_of_id uri in
63			let r =
64			new Pxp_reader.resolve_to_any_obj_channel ~channel_of_id () in
65			from_string ~alt:[r] s
66	abate	1458	in
67			node_of source
68	abate	1452	with exn -> raise (Location.Generic (Pxp_types.string_of_exn exn))
69	abate	500
70	abate	1452	let _may_attr name n =
71			try
72			match n#attribute name with
73			\| Pxp_types.Value v -> Some (Utf8.mk v)
74			\| _ -> None
75			with Not_found -> None
76
77			let _is_attr name n v =
78			try
79			match n#attribute name with
80			\| Pxp_types.Value v' -> v = v'
81			\| _ -> false
82			with Not_found -> false
83
84			let _attr name n =
85			match n#attribute name with
86			\| Pxp_types.Value v -> Utf8.mk v
87	abate	1528	\| _ -> error ("Attribute " ^ name ^ " is missing")
88	abate	1452
89			let _may_elem e (n: node) =
90			try Some (Pxp_document.find_element e n) with Not_found -> None
91
92			let _elems e n = Pxp_document.find_all_elements e n
93	abate	1454
94			let _filter_elems p n =
95			Pxp_document.find_all (fun n -> match n#node_type with
96			\| Pxp_document.T_element s -> List.mem s p
97			\| _ -> false) n
98	abate	1452
99			let _line n = match n#position with (_,l,_) -> l
100
101			let _iter_nodes n f = n#iter_nodes f
102
103			let _iter_elems n f = n#iter_nodes
104			(fun n ->
105			match n#node_type with
106			\| Pxp_document.T_element s -> f n s
107			\| _ -> ()
108			)
109	abate	1454
110			let _fold_elems n x f =
111			let x = ref x in
112			n#iter_nodes
113			(fun n ->
114			match n#node_type with
115			\| Pxp_document.T_element s -> x := f !x n s
116			\| _ -> ()
117			);
118			!x
119	abate	1452
120			let _tag n =
121			match n#node_type with
122			\| Pxp_document.T_element s -> s
123			\| _ -> assert false
124
125			let _has_tag n f =
126			match n#node_type with
127			\| Pxp_document.T_element s -> f s
128			\| _ -> false
129
130			let _namespaces n =
131			List.map
132			(fun n ->
133			(match n#node_type with
134			Pxp_document.T_namespace p -> p \| _ -> assert false),
135			n#data
136			)
137			n#namespaces_as_nodes
138
139			let _find p n = Pxp_document.find p n
140	abate	1460
141			let _resolve_qname n qname =
142			let (prefix,local) = Ns.split_qname qname in
143			let ns =
144			try Ns.mk (Utf8.mk (n # namespace_scope # uri_of_display_prefix prefix))
145			with Not_found -> Ns.empty
146			in
147			(ns,local)
148
149			let _may_qname_attr name n =
150			match _may_attr name n with
151			\| Some qname -> Some (_resolve_qname n qname)
152			\| None -> None
153
154			let _qname_attr name n =
155			match _may_attr name n with
156			\| Some qname -> _resolve_qname n qname
157	abate	1528	\| None -> error ("Cannot find qname attribute " ^ name)
158	abate	1460
159
160			let xsd = Ns.mk xsd_namespace
161	abate	1488	let xsi = Ns.mk xsi_namespace