schema_common.ml 6.53 KB
Newer Older
1
2
open Printf

3
open Encodings
4
open Schema_pcre
5
6
open Schema_types

7
8
let xsd = Schema_xml.xsd

9
10
11
12
13
14
15
16
17
18
19
20
let no_facets = {
  length = None;
  minLength = None;
  maxLength = None;
  enumeration = None;
  whiteSpace = `Collapse, true;
  maxInclusive = None;
  maxExclusive = None;
  minInclusive = None;
  minExclusive = None;
}

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
(** naive implementation: doesn't follow XML Schema constraints on facets
 * merging. Here all new facets override old ones *)
let merge_facets old_facets new_facets =
  let maxInclusive, maxExclusive =
    match new_facets.maxInclusive, new_facets.maxExclusive with
    | None, None -> old_facets.maxInclusive, old_facets.maxExclusive
    | Some _, Some _ -> assert false
    | v -> v
  in
  let minInclusive, minExclusive =
    match new_facets.minInclusive, new_facets.minExclusive with
    | None, None -> old_facets.minInclusive, old_facets.minExclusive
    | Some _, Some _ -> assert false
    | v -> v
  in
  { old_facets with
      length =
        (match new_facets.length with
        | None -> old_facets.length
        | v -> v);
      minLength =
        (match new_facets.minLength with
        | None -> old_facets.minLength
        | v -> v);
      maxLength =
        (match new_facets.maxLength with
        | None -> old_facets.maxLength
        | v -> v);
      enumeration =
        (match new_facets.enumeration with
        | None -> old_facets.enumeration
        | v -> v);
      whiteSpace = new_facets.whiteSpace;
      maxInclusive = maxInclusive;
      maxExclusive = maxExclusive;
      minInclusive = minInclusive;
      minExclusive = minExclusive;
  }

60
let name_of_simple_type_definition = function
61
  | { st_name = Some name } -> name
62
63
  | _ -> raise (Invalid_argument "anonymous simple type definition")
let name_of_complex_type_definition = function
64
  | { ct_name = Some name } -> name
65
66
  | _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
67
  | AnyType -> (xsd, Utf8.mk "anyType")
68
69
  | Simple st -> name_of_simple_type_definition st
  | Complex ct -> name_of_complex_type_definition ct
70

71
72
73
74
75
76
77
78
let simple_type_of_type = function
  | Simple s -> s
  | _ -> raise (Invalid_argument "simple_type_of_type")
let complex_type_of_type = function
  | Complex c -> c
  | _ -> raise (Invalid_argument "complex_type_of_type")
let content_type_of_type = function
  | AnyType -> assert false
79
  | Complex { ct_content = ct } -> ct
80
  | Simple st -> CT_simple st
81
82

exception XSD_validation_error of string
83
exception XSI_validation_error of string
84
85

let rec normalize_white_space =
86
87
88
  let ws_RE = pcre_regexp "[\t\r\n]" in
  let spaces_RE = pcre_regexp "[ ]+" in
  let margins_RE = pcre_regexp "^ (.*) $" in
89
90
91
  fun handling s ->
  match handling with
  | `Preserve -> s
92
  | `Replace -> pcre_replace ~rex:ws_RE ~templ:(Utf8.mk " ") s
93
94
  | `Collapse ->
      let s' =
95
        pcre_replace ~rex:spaces_RE ~templ:(Utf8.mk " ")
96
97
          (normalize_white_space `Replace s)
      in
98
      pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
99

100

101
102
103
104
105
106
let first_of_wildcard_constraint = function
  | WAny -> Atoms.any
  | WNot ns -> Atoms.diff Atoms.any (Atoms.any_in_ns ns)
  | WOne l -> 
      List.fold_left (fun acc ns -> Atoms.cup acc (Atoms.any_in_ns ns))
	Atoms.empty l
107
108
let first_of_model_group = function
  | All particles | Choice particles ->
109
      List.fold_left (fun acc p -> Atoms.cup acc p.part_first)
110
	Atoms.empty particles
111
112
  | Sequence particles ->
      let rec aux = function
113
114
        | hd::tl when hd.part_nullable -> Atoms.cup hd.part_first (aux tl)
        | hd::tl -> hd.part_first
115
        | [] -> Atoms.empty
116
117
      in
      aux particles
118
119

let nullable_of_model_group = function
120
121
122
  | All particles | Sequence particles -> 
      List.for_all (fun p -> p.part_nullable) particles
  | Choice particles -> List.exists (fun p -> p.part_nullable) particles
123
124
125
126
127
128
129
130
131
132

type to_be_visited =
  | Fully of Value.t  (* xml values still to be visited *)
  | Half of Value.t   (* xml values half visited (i.e. E_start_tag generated) *)
  | Other of Encodings.Utf8.t (* other values *)
  | Backlog of event  (* old events not yet delivered *)

let stream_of_value v =
  let stack = ref [Fully v] in
  let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
133
            what has still to be visited *)
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
    match !stack with
    | (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
        stack := (Half v) :: tl;
        let children = ref [] in  (* TODO inefficient *)
        let push v s = (s := v :: !s) in
        Value.iter_xml
          (fun pcdata -> push (Other pcdata) children)
          (fun v ->
            match v with
            | (Value.Xml (_, _, _)) as v -> push (Fully v) children
            | v -> raise (Invalid_argument "Schema_events.stream_of_value"))
          v;
        stack := (List.rev !children) @ !stack;
        List.iter (* push attributes as events on the stack *)
          (fun (qname, v) ->
            push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
              stack)
          (Value.get_fields attrs);
        Some (E_start_tag (Atoms.V.value atom))
    | (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
        stack := tl;
        Some (E_end_tag (Atoms.V.value atom))
    | (Fully (Value.Xml (_, _, _)))::_ | (Half (Value.Xml (_, _, _)))::_ ->
157
        Value.failwith'  "Validate: non XML element"
158
159
160
161
162
163
164
    | (Backlog ev) :: tl -> (* consume backlog *)
        stack := tl;
        Some ev
    | (Other v) :: tl ->
        stack := tl;
        Some (E_char_data v)
    | [] -> None
165
    | _ -> Value.failwith'  "Validate: non XML element"
166
167
168
169
170
171
172
173
174
175
  in
  Stream.from f

let string_of_event = function
  | E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
  | E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
  | E_attribute (qname, value) ->
      sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
  | E_char_data value -> Utf8.to_string value

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

let simple_restrict name base new_facets =
  { st_name = name;
    st_variety = base.st_variety;
    st_facets = merge_facets base.st_facets new_facets;
    st_base = Some base }

let simple_list name item =
  { st_name = name;
    st_variety = List item;
    st_facets = no_facets;
    st_base = None }

let simple_union name members =
  { st_name = name;
    st_variety = Union members;
    st_facets = no_facets;
    st_base = None }

195
196
197
198
199

let xsi_nil_qname = (Schema_xml.xsi,Utf8.mk "nil")
let xsi_nil_atom = Atoms.V.of_qname xsi_nil_qname
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_label = Ident.LabelPool.mk xsi_nil_qname
200
201
202

let merge_attribute_uses l =
  List.fold_left (fun (l,a) (l',a') -> (l @ l', a || a')) ([],false) l