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

let node_of_uri uri =
  try
    let source = match Url.process uri with 
      | Url.Filename s -> Pxp_types.from_file s 
      | Url.Url s -> Pxp_types.from_string 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	1458	let node_of_uri uri =
45			try
46			let source = match Url.process uri with
47			\| Url.Filename s -> Pxp_types.from_file s
48			\| Url.Url s -> Pxp_types.from_string s
49			in
50			node_of source
51	abate	1452	with exn -> raise (Location.Generic (Pxp_types.string_of_exn exn))
52	abate	500
53	abate	1452	let _may_attr name n =
54			try
55			match n#attribute name with
56			\| Pxp_types.Value v -> Some (Utf8.mk v)
57			\| _ -> None
58			with Not_found -> None
59
60			let _is_attr name n v =
61			try
62			match n#attribute name with
63			\| Pxp_types.Value v' -> v = v'
64			\| _ -> false
65			with Not_found -> false
66
67			let _attr name n =
68			match n#attribute name with
69			\| Pxp_types.Value v -> Utf8.mk v
70	abate	1528	\| _ -> error ("Attribute " ^ name ^ " is missing")
71	abate	1452
72			let _may_elem e (n: node) =
73			try Some (Pxp_document.find_element e n) with Not_found -> None
74
75			let _elems e n = Pxp_document.find_all_elements e n
76	abate	1454
77			let _filter_elems p n =
78			Pxp_document.find_all (fun n -> match n#node_type with
79			\| Pxp_document.T_element s -> List.mem s p
80			\| _ -> false) n
81	abate	1452
82			let _line n = match n#position with (_,l,_) -> l
83
84			let _iter_nodes n f = n#iter_nodes f
85
86			let _iter_elems n f = n#iter_nodes
87			(fun n ->
88			match n#node_type with
89			\| Pxp_document.T_element s -> f n s
90			\| _ -> ()
91			)
92	abate	1454
93			let _fold_elems n x f =
94			let x = ref x in
95			n#iter_nodes
96			(fun n ->
97			match n#node_type with
98			\| Pxp_document.T_element s -> x := f !x n s
99			\| _ -> ()
100			);
101			!x
102	abate	1452
103			let _tag n =
104			match n#node_type with
105			\| Pxp_document.T_element s -> s
106			\| _ -> assert false
107
108			let _has_tag n f =
109			match n#node_type with
110			\| Pxp_document.T_element s -> f s
111			\| _ -> false
112
113			let _namespaces n =
114			List.map
115			(fun n ->
116			(match n#node_type with
117			Pxp_document.T_namespace p -> p \| _ -> assert false),
118			n#data
119			)
120			n#namespaces_as_nodes
121
122			let _find p n = Pxp_document.find p n
123	abate	1460
124			let _resolve_qname n qname =
125			let (prefix,local) = Ns.split_qname qname in
126			let ns =
127			try Ns.mk (Utf8.mk (n # namespace_scope # uri_of_display_prefix prefix))
128			with Not_found -> Ns.empty
129			in
130			(ns,local)
131
132			let _may_qname_attr name n =
133			match _may_attr name n with
134			\| Some qname -> Some (_resolve_qname n qname)
135			\| None -> None
136
137			let _qname_attr name n =
138			match _may_attr name n with
139			\| Some qname -> _resolve_qname n qname
140	abate	1528	\| None -> error ("Cannot find qname attribute " ^ name)
141	abate	1460
142
143			let xsd = Ns.mk xsd_namespace
144	abate	1488	let xsi = Ns.mk xsi_namespace