viewcvs.cgi/schema/schema_builtin.ml


open Printf
open Schema_types

(* TODO dates: boundary checks (e.g. 95/26/2003) *)
(* TODO a lot of almost cut-and-paste code, expecially in gFoo types validation
*)

  (* auxiliary stuff *)

let char_of_hex =
  let int_of_hex_char = function
    | '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5 | '6' -> 6
    | '7' -> 7 | '8' -> 8 | '9' -> 9 | 'a' | 'A' -> 10 | 'b' | 'B' -> 11
    | 'c' | 'C' -> 12 | 'd' | 'D' -> 13 | 'e' | 'E' -> 14 | 'f' | 'F' -> 15
    | _ -> assert false
  in
    (* most significative, least significative *)
  fun ms ls -> Char.unsafe_chr (int_of_hex_char ms * 16 + int_of_hex_char ls)

let strip_parens s = Pcre.replace ~pat:"[()]" s
let add_limits s = "^" ^ s ^ "$"

let simple_type_error ~typ ~value =
  raise (XSI_validation_error (sprintf "'%s' isn't a valid xsd:%s" value typ))

  (* regular expressions used to validate built-in types *)

let timezone_RE_raw = "(Z)|(([+-])?(\\d{2}):(\\d{2}))"
let date_RE_raw = "(\\d{4,})-(\\d{2})-(\\d{2})"
let time_RE_raw = "(\\d{2}):(\\d{2}):(\\d{2})"

let gYearMonth_RE_raw = sprintf "(-)?(\\d{4,})-(\\d{2})(%s)?" timezone_RE_raw
let gYear_RE_raw = sprintf "(-)?(\\d{4,})(%s)?" timezone_RE_raw
let gMonthDay_RE_raw = sprintf "--(\\d{2})-(\\d{2})(%s)?" timezone_RE_raw
let gDay_RE_raw = sprintf "---(\\d{2})(%s)?" timezone_RE_raw
let gMonth_RE_raw = "--(\\d{2})--(%s)?"

let positive_field = false, "positive", Builtin_defs.bool
let year_field = false, "year", Builtin_defs.int
let month_field = false, "month", Builtin_defs.int
let day_field = false, "day", Builtin_defs.int
let hour_field = false, "hour", Builtin_defs.int
let minute_field = false, "minute", Builtin_defs.int
let second_field = false, "second", Builtin_defs.int ;; (* TODO this should be a decimal *)

  (* some cduce types corresponding to schema ones *)

  (* TODO the constraint that at least one part should be present isn't easily
  expressible with CDuce types *)
let duration_type = Types.rec_of_list' [
  positive_field;
  true, "year", Builtin_defs.int;
  true, "month", Builtin_defs.int;
  true, "day", Builtin_defs.int;
  true, "hour", Builtin_defs.int;
  true, "minute", Builtin_defs.int;
  true, "second", Builtin_defs.int; (* TODO this should be a decimal *)
]

let timezone_type = Types.rec_of_list' [
  false, "positive", Builtin_defs.bool;
  hour_field; minute_field
]

let timezone_type_fields = [ true, "timezone", timezone_type ]
let time_type_fields = [ hour_field; minute_field; second_field ]
let date_type_fields = [ year_field; month_field; day_field ]

let time_type = Types.rec_of_list' (time_type_fields @ timezone_type_fields)
let date_type = Types.rec_of_list' (positive_field :: date_type_fields)
let dateTime_type =
  Types.rec_of_list' (positive_field ::
    (date_type_fields @ time_type_fields @ timezone_type_fields))
let gYearMonth_type = Types.rec_of_list' [
  positive_field; year_field; month_field
]
let gYear_type = Types.rec_of_list' [ positive_field; year_field ]
let gMonthDay_type = Types.rec_of_list' [ month_field; day_field ]
let gDay_type = Types.rec_of_list' [ day_field ]
let gMonth_type = Types.rec_of_list' [ month_field ]

let nonPositiveInteger_type = Builtin_defs.non_pos_int
let negativeInteger_type = Builtin_defs.neg_int
let nonNegativeInteger_type = Builtin_defs.non_neg_int
let positiveInteger_type = Builtin_defs.pos_int

  (* validation functions: string -> Value.t *)

let validate_string = Value.string_latin1

let validate_integer s =
  try
    Value.Integer (Intervals.V.mk s)
  with Failure _ -> simple_type_error ~typ:"integer" ~value:s
let validate_interval interval type_name s =
  let integer =
    try
      Intervals.V.mk s
    with Failure _ -> simple_type_error ~typ:type_name ~value:s
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
    simple_type_error ~typ:type_name ~value:s
let validate_nonPositiveInteger =
  validate_interval (Intervals.left Intervals.V.zero) "nonPositiveInteger"
let validate_negativeInteger =
  validate_interval (Intervals.left Intervals.V.minus_one) "negativeInteger"
let validate_nonNegativeInteger =
  validate_interval (Intervals.right Intervals.V.zero) "nonNegativeInteger"
let validate_positiveInteger =
  validate_interval (Intervals.right Intervals.V.one) "positiveInteger"

let validate_bool = function
  | "true" | "1" -> Value.vtrue
  | "false" | "0" -> Value.vfalse
  | v -> simple_type_error ~typ:"boolean" ~value:v

let parse_sign = function "+" | "" -> Value.vtrue | _ -> Value.vfalse

let parse_date =
  let rex = Pcre.regexp (add_limits date_RE_raw) in
  fun s ->
  let abort () = simple_type_error ~typ:"date" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  [ "year", validate_integer subs.(1);
  "month", validate_integer subs.(2);
  "day", validate_integer subs.(3) ]

let parse_time =
  let rex = Pcre.regexp (add_limits time_RE_raw) in
  fun s ->
  let abort () = simple_type_error ~typ:"time" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  [ "hour", validate_integer subs.(1);
  "minute", validate_integer subs.(2);
  "second", validate_integer subs.(3) ]

let parse_timezone =
  let rex = Pcre.regexp (add_limits timezone_RE_raw) in
  fun s ->
  let abort () =
    raise (XSI_validation_error (sprintf "'%s' isn't a valid timezone" s))
  in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  match subs.(1) with
  | "Z" ->
      ["positive", Value.vtrue;
      "hour", validate_integer "0";
      "minute", validate_integer "0"]
  | _ ->
      ["positive", parse_sign subs.(3);
      "hour", validate_integer subs.(4);
      "minute", validate_integer subs.(5)]
  (* parse a timezone from a string, if it's empty return the empty list,
  otherwise return a list containing a pair <"timezone", timezone value> *)
let parse_timezone' = function
  | "" -> []
  | v -> [ "timezone", Value.vrecord (parse_timezone v) ]

let validate_duration =
  let rex = Pcre.regexp
  "^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
  in
  fun s ->
  let abort () = simple_type_error ~typ:"duration" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      ["positive", parse_sign subs.(1) ]                                @
      (match subs.(3) with "" -> [] | v -> ["year", validate_integer v])    @
      (match subs.(5) with "" -> [] | v -> ["month", validate_integer v])   @
      (match subs.(7) with "" -> [] | v -> ["day", validate_integer v])     @
      (match subs.(10) with "" -> [] | v -> ["hour", validate_integer v])   @
      (match subs.(12) with "" -> [] | v -> ["minute", validate_integer v]) @
      (match subs.(14) with "" -> [] | v -> ["second", validate_integer v])
    in
    Value.vrecord fields
  with XSI_validation_error _ -> abort ()

let validate_dateTime =
  let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
    (strip_parens date_RE_raw) (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
  let abort () = simple_type_error ~typ:"dateTime" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      [ "positive", parse_sign subs.(1) ] @
      parse_date subs.(2) @
      parse_time subs.(3) @
      parse_timezone' subs.(4)
    in
    Value.vrecord fields
  with XSI_validation_error _ -> abort ()

let validate_gYearMonth =
  let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
  fun s ->
    let abort () = simple_type_error ~typ:"gYearMonth" ~value:s in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "positive", parse_sign subs.(1);
        "year", validate_integer subs.(2);
        "month", validate_integer subs.(3)
      ] @ parse_timezone' subs.(4)
      in
      Value.vrecord fields
    with XSI_validation_error _ -> abort ()

let validate_gYear =
  let rex = Pcre.regexp (add_limits gYear_RE_raw) in
  fun s ->
    let abort () = simple_type_error ~typ:"gYear" ~value:s in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "positive", parse_sign subs.(1);
        "year", validate_integer subs.(2);
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
    with XSI_validation_error _ -> abort ()

let validate_gMonthDay =
  let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
  fun s ->
    let abort () = simple_type_error ~typ:"gMonthDay" ~value:s in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "month", validate_integer subs.(1);
        "day", validate_integer subs.(2);
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
    with XSI_validation_error _ -> abort ()

let validate_gDay =
  let rex = Pcre.regexp (add_limits gDay_RE_raw) in
  fun s ->
    let abort () = simple_type_error ~typ:"gDay" ~value:s in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields =
        ("day", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
      in
      Value.vrecord fields
    with XSI_validation_error _ -> abort ()

let validate_gMonth =
  let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
  fun s ->
    let abort () = simple_type_error ~typ:"gMonth" ~value:s in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields =
        ("month", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
      in
      Value.vrecord fields
    with XSI_validation_error _ -> abort ()

let validate_time =
  let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
  let abort () = simple_type_error ~typ:"time" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      parse_time subs.(1) @
      (match subs.(2) with
      | "" -> []
      | v -> [ "timezone", Value.vrecord (parse_timezone v) ])
    in
    Value.vrecord fields
  with XSI_validation_error _ -> abort ()

let validate_date =
  let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
  let abort () = simple_type_error ~typ:"date" ~value:s in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      [ "positive", parse_sign subs.(1) ] @
      parse_date subs.(2) @
      (match subs.(3) with
      | "" -> []
      | v -> [ "timezone", Value.vrecord (parse_timezone v) ])
    in
    Value.vrecord fields
  with XSI_validation_error _ -> abort ()

let validate_hexBinary s =
  let len = String.length s in
  if len mod 2 <> 0 then
    simple_type_error ~typ:"hexBinary" ~value:s;
  let res = String.create (len / 2) in
  let rec aux idx =
    if idx < len then begin
      String.unsafe_set res (idx / 2)
        (char_of_hex (String.unsafe_get s idx) (String.unsafe_get s (idx + 1)));
      aux (idx + 2)
    end
  in
  aux 0;
  validate_string res

  (* TODO test base64Binary simple type! *)
let validate_base64Binary s = validate_string (Netencoding.Base64.decode s)

let validate_anyURI s =
  try
    validate_string (Neturl.string_of_url (Neturl.url_of_string
      Neturl.ip_url_syntax s))
  with Neturl.Malformed_URL -> simple_type_error ~typ:"anyURI" ~value:s

let builtins = [
  "xsd:string", (Builtin_defs.string, validate_string);
  "xsd:integer", (Builtin_defs.int, validate_integer);
  "xsd:nonPositiveInteger",
    (nonPositiveInteger_type, validate_nonPositiveInteger);
  "xsd:negativeInteger", (negativeInteger_type, validate_negativeInteger);
  "xsd:nonNegativeInteger",
    (nonNegativeInteger_type, validate_nonNegativeInteger);
  "xsd:positiveInteger", (positiveInteger_type, validate_positiveInteger);
  "xsd:boolean", (Builtin_defs.bool, validate_bool);
  "xsd:hexBinary", (Builtin_defs.string, validate_hexBinary);
  "xsd:base64Binary", (Builtin_defs.string, validate_base64Binary);
  "xsd:anyURI", (Builtin_defs.string, validate_anyURI);
    (* TODO anyType: is this useful? *)
  "xsd:anyType", (Types.any, (fun _ -> assert false));
    (* TODO anySimpleType: is ok as a string? *)
  "xsd:anySimpleType", (Builtin_defs.string, validate_string);
  "xsd:duration", (duration_type, validate_duration);
  "xsd:dateTime", (dateTime_type, validate_dateTime);
  "xsd:time", (time_type, validate_time);
  "xsd:date", (date_type, validate_date);
  "xsd:gYearMonth", (gYearMonth_type, validate_gYearMonth);
  "xsd:gYear", (gYear_type, validate_gYear);
  "xsd:gMonthDay", (gMonthDay_type, validate_gMonthDay);
  "xsd:gDay", (gDay_type, validate_gDay);
  "xsd:gMonth", (gMonth_type, validate_gMonth);
]

  (* module's interface implementation *)

let names = List.sort compare (List.map fst builtins)
let len = List.length builtins
let cd_types = Hashtbl.create len
let validators = Hashtbl.create len
let __validate_fun_of_builtin = Hashtbl.find validators
let cd_type_of_builtin = Hashtbl.find cd_types

let fill () =
  List.iter
    (fun (name, (typ, validator)) ->
      Hashtbl.add cd_types name typ;
      Hashtbl.add validators name validator)
    builtins

let _ = fill ()

1	abate	500
2	abate	507	open Printf
3			open Schema_types
4	abate	500
5			(* TODO dates: boundary checks (e.g. 95/26/2003) *)
6			(* TODO a lot of almost cut-and-paste code, expecially in gFoo types validation
7			*)
8
9			(* auxiliary stuff *)
10
11			let char_of_hex =
12			let int_of_hex_char = function
13			\| '0' -> 0 \| '1' -> 1 \| '2' -> 2 \| '3' -> 3 \| '4' -> 4 \| '5' -> 5 \| '6' -> 6
14			\| '7' -> 7 \| '8' -> 8 \| '9' -> 9 \| 'a' \| 'A' -> 10 \| 'b' \| 'B' -> 11
15			\| 'c' \| 'C' -> 12 \| 'd' \| 'D' -> 13 \| 'e' \| 'E' -> 14 \| 'f' \| 'F' -> 15
16			\| _ -> assert false
17			in
18			(* most significative, least significative *)
19			fun ms ls -> Char.unsafe_chr (int_of_hex_char ms * 16 + int_of_hex_char ls)
20
21	abate	507	let strip_parens s = Pcre.replace ~pat:"[()]" s
22			let add_limits s = "^" ^ s ^ "$"
23	abate	500
24			let simple_type_error ~typ ~value =
25			raise (XSI_validation_error (sprintf "'%s' isn't a valid xsd:%s" value typ))
26
27			(* regular expressions used to validate built-in types *)
28
29	abate	507	let timezone_RE_raw = "(Z)\|(([+-])?(\\d{2}):(\\d{2}))"
30			let date_RE_raw = "(\\d{4,})-(\\d{2})-(\\d{2})"
31			let time_RE_raw = "(\\d{2}):(\\d{2}):(\\d{2})"
32	abate	500
33	abate	507	let gYearMonth_RE_raw = sprintf "(-)?(\\d{4,})-(\\d{2})(%s)?" timezone_RE_raw
34			let gYear_RE_raw = sprintf "(-)?(\\d{4,})(%s)?" timezone_RE_raw
35			let gMonthDay_RE_raw = sprintf "--(\\d{2})-(\\d{2})(%s)?" timezone_RE_raw
36			let gDay_RE_raw = sprintf "---(\\d{2})(%s)?" timezone_RE_raw
37			let gMonth_RE_raw = "--(\\d{2})--(%s)?"
38	abate	500
39	abate	507	let positive_field = false, "positive", Builtin_defs.bool
40			let year_field = false, "year", Builtin_defs.int
41			let month_field = false, "month", Builtin_defs.int
42			let day_field = false, "day", Builtin_defs.int
43			let hour_field = false, "hour", Builtin_defs.int
44			let minute_field = false, "minute", Builtin_defs.int
45	abate	500	let second_field = false, "second", Builtin_defs.int ;; (* TODO this should be a decimal *)
46
47			(* some cduce types corresponding to schema ones *)
48
49			(* TODO the constraint that at least one part should be present isn't easily
50			expressible with CDuce types *)
51			let duration_type = Types.rec_of_list' [
52			positive_field;
53			true, "year", Builtin_defs.int;
54			true, "month", Builtin_defs.int;
55			true, "day", Builtin_defs.int;
56			true, "hour", Builtin_defs.int;
57			true, "minute", Builtin_defs.int;
58			true, "second", Builtin_defs.int; (* TODO this should be a decimal *)
59	abate	507	]
60	abate	500
61			let timezone_type = Types.rec_of_list' [
62			false, "positive", Builtin_defs.bool;
63			hour_field; minute_field
64	abate	507	]
65	abate	500
66	abate	507	let timezone_type_fields = [ true, "timezone", timezone_type ]
67			let time_type_fields = [ hour_field; minute_field; second_field ]
68			let date_type_fields = [ year_field; month_field; day_field ]
69	abate	500
70	abate	507	let time_type = Types.rec_of_list' (time_type_fields @ timezone_type_fields)
71			let date_type = Types.rec_of_list' (positive_field :: date_type_fields)
72	abate	500	let dateTime_type =
73			Types.rec_of_list' (positive_field ::
74			(date_type_fields @ time_type_fields @ timezone_type_fields))
75			let gYearMonth_type = Types.rec_of_list' [
76			positive_field; year_field; month_field
77	abate	507	]
78			let gYear_type = Types.rec_of_list' [ positive_field; year_field ]
79			let gMonthDay_type = Types.rec_of_list' [ month_field; day_field ]
80			let gDay_type = Types.rec_of_list' [ day_field ]
81			let gMonth_type = Types.rec_of_list' [ month_field ]
82	abate	500
83	abate	507	let nonPositiveInteger_type = Builtin_defs.non_pos_int
84			let negativeInteger_type = Builtin_defs.neg_int
85			let nonNegativeInteger_type = Builtin_defs.non_neg_int
86			let positiveInteger_type = Builtin_defs.pos_int
87	abate	500
88			(* validation functions: string -> Value.t *)
89
90	abate	507	let validate_string = Value.string_latin1
91	abate	500
92			let validate_integer s =
93			try
94	abate	656	Value.Integer (Intervals.V.mk s)
95	abate	500	with Failure _ -> simple_type_error ~typ:"integer" ~value:s
96			let validate_interval interval type_name s =
97			let integer =
98			try
99	abate	656	Intervals.V.mk s
100	abate	500	with Failure _ -> simple_type_error ~typ:type_name ~value:s
101			in
102			if Intervals.contains integer interval then
103			Value.Integer integer
104			else
105			simple_type_error ~typ:type_name ~value:s
106			let validate_nonPositiveInteger =
107	abate	656	validate_interval (Intervals.left Intervals.V.zero) "nonPositiveInteger"
108	abate	500	let validate_negativeInteger =
109	abate	656	validate_interval (Intervals.left Intervals.V.minus_one) "negativeInteger"
110	abate	500	let validate_nonNegativeInteger =
111	abate	656	validate_interval (Intervals.right Intervals.V.zero) "nonNegativeInteger"
112	abate	500	let validate_positiveInteger =
113	abate	656	validate_interval (Intervals.right Intervals.V.one) "positiveInteger"
114	abate	500
115			let validate_bool = function
116			\| "true" \| "1" -> Value.vtrue
117			\| "false" \| "0" -> Value.vfalse
118			\| v -> simple_type_error ~typ:"boolean" ~value:v
119
120	abate	507	let parse_sign = function "+" \| "" -> Value.vtrue \| _ -> Value.vfalse
121	abate	500
122			let parse_date =
123			let rex = Pcre.regexp (add_limits date_RE_raw) in
124			fun s ->
125			let abort () = simple_type_error ~typ:"date" ~value:s in
126			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
127			[ "year", validate_integer subs.(1);
128			"month", validate_integer subs.(2);
129			"day", validate_integer subs.(3) ]
130
131			let parse_time =
132			let rex = Pcre.regexp (add_limits time_RE_raw) in
133			fun s ->
134			let abort () = simple_type_error ~typ:"time" ~value:s in
135			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
136			[ "hour", validate_integer subs.(1);
137			"minute", validate_integer subs.(2);
138			"second", validate_integer subs.(3) ]
139
140			let parse_timezone =
141			let rex = Pcre.regexp (add_limits timezone_RE_raw) in
142			fun s ->
143			let abort () =
144			raise (XSI_validation_error (sprintf "'%s' isn't a valid timezone" s))
145			in
146			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
147			match subs.(1) with
148			\| "Z" ->
149			["positive", Value.vtrue;
150			"hour", validate_integer "0";
151			"minute", validate_integer "0"]
152			\| _ ->
153			["positive", parse_sign subs.(3);
154			"hour", validate_integer subs.(4);
155			"minute", validate_integer subs.(5)]
156			(* parse a timezone from a string, if it's empty return the empty list,
157			otherwise return a list containing a pair <"timezone", timezone value> *)
158			let parse_timezone' = function
159			\| "" -> []
160			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ]
161
162			let validate_duration =
163			let rex = Pcre.regexp
164			"^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
165			in
166			fun s ->
167			let abort () = simple_type_error ~typ:"duration" ~value:s in
168			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
169			try
170			let fields =
171			["positive", parse_sign subs.(1) ] @
172			(match subs.(3) with "" -> [] \| v -> ["year", validate_integer v]) @
173			(match subs.(5) with "" -> [] \| v -> ["month", validate_integer v]) @
174			(match subs.(7) with "" -> [] \| v -> ["day", validate_integer v]) @
175			(match subs.(10) with "" -> [] \| v -> ["hour", validate_integer v]) @
176			(match subs.(12) with "" -> [] \| v -> ["minute", validate_integer v]) @
177			(match subs.(14) with "" -> [] \| v -> ["second", validate_integer v])
178			in
179			Value.vrecord fields
180			with XSI_validation_error _ -> abort ()
181
182			let validate_dateTime =
183			let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
184			(strip_parens date_RE_raw) (strip_parens time_RE_raw)
185			(strip_parens timezone_RE_raw))
186			in
187			fun s ->
188			let abort () = simple_type_error ~typ:"dateTime" ~value:s in
189			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
190			try
191			let fields =
192			[ "positive", parse_sign subs.(1) ] @
193			parse_date subs.(2) @
194			parse_time subs.(3) @
195			parse_timezone' subs.(4)
196			in
197			Value.vrecord fields
198			with XSI_validation_error _ -> abort ()
199
200			let validate_gYearMonth =
201			let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
202			fun s ->
203			let abort () = simple_type_error ~typ:"gYearMonth" ~value:s in
204			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
205			try
206			let fields = [
207			"positive", parse_sign subs.(1);
208			"year", validate_integer subs.(2);
209			"month", validate_integer subs.(3)
210			] @ parse_timezone' subs.(4)
211			in
212			Value.vrecord fields
213			with XSI_validation_error _ -> abort ()
214
215			let validate_gYear =
216			let rex = Pcre.regexp (add_limits gYear_RE_raw) in
217			fun s ->
218			let abort () = simple_type_error ~typ:"gYear" ~value:s in
219			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
220			try
221			let fields = [
222			"positive", parse_sign subs.(1);
223			"year", validate_integer subs.(2);
224			] @ parse_timezone' subs.(3)
225			in
226			Value.vrecord fields
227			with XSI_validation_error _ -> abort ()
228
229			let validate_gMonthDay =
230			let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
231			fun s ->
232			let abort () = simple_type_error ~typ:"gMonthDay" ~value:s in
233			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
234			try
235			let fields = [
236			"month", validate_integer subs.(1);
237			"day", validate_integer subs.(2);
238			] @ parse_timezone' subs.(3)
239			in
240			Value.vrecord fields
241			with XSI_validation_error _ -> abort ()
242
243			let validate_gDay =
244			let rex = Pcre.regexp (add_limits gDay_RE_raw) in
245			fun s ->
246			let abort () = simple_type_error ~typ:"gDay" ~value:s in
247			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
248			try
249			let fields =
250			("day", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
251			in
252			Value.vrecord fields
253			with XSI_validation_error _ -> abort ()
254
255			let validate_gMonth =
256			let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
257			fun s ->
258			let abort () = simple_type_error ~typ:"gMonth" ~value:s in
259			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
260			try
261			let fields =
262			("month", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
263			in
264			Value.vrecord fields
265			with XSI_validation_error _ -> abort ()
266
267			let validate_time =
268			let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
269			(strip_parens timezone_RE_raw))
270			in
271			fun s ->
272			let abort () = simple_type_error ~typ:"time" ~value:s in
273			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
274			try
275			let fields =
276			parse_time subs.(1) @
277			(match subs.(2) with
278			\| "" -> []
279			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
280			in
281			Value.vrecord fields
282			with XSI_validation_error _ -> abort ()
283
284			let validate_date =
285			let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
286			(strip_parens timezone_RE_raw))
287			in
288			fun s ->
289			let abort () = simple_type_error ~typ:"date" ~value:s in
290			let subs = try Pcre.extract ~rex s with Not_found -> abort () in
291			try
292			let fields =
293			[ "positive", parse_sign subs.(1) ] @
294			parse_date subs.(2) @
295			(match subs.(3) with
296			\| "" -> []
297			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
298			in
299			Value.vrecord fields
300			with XSI_validation_error _ -> abort ()
301
302			let validate_hexBinary s =
303			let len = String.length s in
304			if len mod 2 <> 0 then
305			simple_type_error ~typ:"hexBinary" ~value:s;
306			let res = String.create (len / 2) in
307			let rec aux idx =
308			if idx < len then begin
309			String.unsafe_set res (idx / 2)
310			(char_of_hex (String.unsafe_get s idx) (String.unsafe_get s (idx + 1)));
311			aux (idx + 2)
312			end
313			in
314			aux 0;
315			validate_string res
316
317			(* TODO test base64Binary simple type! *)
318	abate	507	let validate_base64Binary s = validate_string (Netencoding.Base64.decode s)
319	abate	500
320			let validate_anyURI s =
321			try
322			validate_string (Neturl.string_of_url (Neturl.url_of_string
323			Neturl.ip_url_syntax s))
324			with Neturl.Malformed_URL -> simple_type_error ~typ:"anyURI" ~value:s
325
326			let builtins = [
327			"xsd:string", (Builtin_defs.string, validate_string);
328			"xsd:integer", (Builtin_defs.int, validate_integer);
329			"xsd:nonPositiveInteger",
330			(nonPositiveInteger_type, validate_nonPositiveInteger);
331			"xsd:negativeInteger", (negativeInteger_type, validate_negativeInteger);
332			"xsd:nonNegativeInteger",
333			(nonNegativeInteger_type, validate_nonNegativeInteger);
334			"xsd:positiveInteger", (positiveInteger_type, validate_positiveInteger);
335			"xsd:boolean", (Builtin_defs.bool, validate_bool);
336			"xsd:hexBinary", (Builtin_defs.string, validate_hexBinary);
337			"xsd:base64Binary", (Builtin_defs.string, validate_base64Binary);
338			"xsd:anyURI", (Builtin_defs.string, validate_anyURI);
339			(* TODO anyType: is this useful? *)
340			"xsd:anyType", (Types.any, (fun _ -> assert false));
341			(* TODO anySimpleType: is ok as a string? *)
342			"xsd:anySimpleType", (Builtin_defs.string, validate_string);
343			"xsd:duration", (duration_type, validate_duration);
344			"xsd:dateTime", (dateTime_type, validate_dateTime);
345			"xsd:time", (time_type, validate_time);
346			"xsd:date", (date_type, validate_date);
347			"xsd:gYearMonth", (gYearMonth_type, validate_gYearMonth);
348			"xsd:gYear", (gYear_type, validate_gYear);
349			"xsd:gMonthDay", (gMonthDay_type, validate_gMonthDay);
350			"xsd:gDay", (gDay_type, validate_gDay);
351			"xsd:gMonth", (gMonth_type, validate_gMonth);
352	abate	507	]
353	abate	500
354			(* module's interface implementation *)
355
356	abate	507	let names = List.sort compare (List.map fst builtins)
357			let len = List.length builtins
358			let cd_types = Hashtbl.create len
359			let validators = Hashtbl.create len
360			let __validate_fun_of_builtin = Hashtbl.find validators
361			let cd_type_of_builtin = Hashtbl.find cd_types
362	abate	500
363			let fill () =
364			List.iter
365			(fun (name, (typ, validator)) ->
366			Hashtbl.add cd_types name typ;
367			Hashtbl.add validators name validator)
368			builtins
369
370	abate	507	let _ = fill ()
371	abate	500