Commit 3447d2e5 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-11-20 11:36:12 by szach] - major cleanup of schema import code

- schema validation still commented out

Original author: szach
Date: 2003-11-20 11:36:13+00:00
parent abdf2243
......@@ -9,6 +9,18 @@ open Schema_common
(** {2 Aux/Misc stuff} *)
let zero = Intervals.V.zero
let one = (Intervals.V.succ Intervals.V.zero)
let minus_one = (Intervals.V.pred Intervals.V.zero)
let long_l = (Intervals.V.mk "-9223372036854775808")
let long_r = (Intervals.V.mk "9223372036854775807")
let int_l = (Intervals.V.mk "-2147483648")
let int_r = (Intervals.V.mk "2147483647")
let short_l = (Intervals.V.mk "-32768")
let short_r = (Intervals.V.mk "32767")
let byte_l = (Intervals.V.mk "-128")
let byte_r = (Intervals.V.mk "127")
let regexp' s = Pcre.regexp ~flags:[`UTF8] s
let xml_S_RE = regexp' "[ \\t\\r\\n]+"
(* split a string at XML recommendation "S" production boundaries *)
......@@ -28,8 +40,9 @@ let char_of_hex =
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))
exception Schema_builtin_error of string
let simple_type_error name =
raise (Schema_builtin_error (Schema_xml.xsd_prefix ^ name))
(* regular expressions used to validate built-in types *)
......@@ -89,6 +102,10 @@ 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
let long_type = Builtin_defs.long_int
let int_type = Builtin_defs.int_int
let short_type = Builtin_defs.short_int
let byte_type = Builtin_defs.byte_int
let string_list_type = Sequence.star Builtin_defs.string
......@@ -99,12 +116,15 @@ let parse_sign = function "+" | "" -> Value.vtrue | _ -> Value.vfalse
let validate_integer s =
try
Value.Integer (Intervals.V.mk s)
with Failure _ -> simple_type_error ~typ:"integer" ~value:s
with Failure _ -> simple_type_error "integer"
let strip_decimal_RE = Pcre.regexp "\\..*$"
let validate_decimal s = validate_integer (Pcre.replace ~rex:strip_decimal_RE s)
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 abort () = simple_type_error "date" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
[ "year", validate_integer subs.(1);
"month", validate_integer subs.(2);
......@@ -113,7 +133,7 @@ let parse_date =
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 abort () = simple_type_error "time" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
[ "hour", validate_integer subs.(1);
"minute", validate_integer subs.(2);
......@@ -122,9 +142,7 @@ let parse_time =
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 abort () = raise (Schema_builtin_error "timezone") in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
match subs.(1) with
| "Z" ->
......@@ -155,12 +173,12 @@ let validate_interval interval type_name s =
let integer =
try
Intervals.V.mk s
with Failure _ -> simple_type_error ~typ:type_name ~value:s
with Failure _ -> simple_type_error type_name
in
if Intervals.contains integer interval then
Value.Integer integer
else
simple_type_error ~typ:type_name ~value:s
simple_type_error type_name
let validate_nonPositiveInteger =
validate_interval (Intervals.left Intervals.V.zero) "nonPositiveInteger"
let validate_negativeInteger =
......@@ -169,18 +187,23 @@ let validate_nonNegativeInteger =
validate_interval (Intervals.right Intervals.V.zero) "nonNegativeInteger"
let validate_positiveInteger =
validate_interval (Intervals.right Intervals.V.one) "positiveInteger"
let validate_long = validate_interval (Intervals.bounded long_l long_r) "long"
let validate_int = validate_interval (Intervals.bounded int_l int_r) "int"
let validate_short =
validate_interval (Intervals.bounded short_l short_r) "short"
let validate_byte = validate_interval (Intervals.bounded byte_l byte_r) "byte"
let validate_bool = function
| "true" | "1" -> Value.vtrue
| "false" | "0" -> Value.vfalse
| v -> simple_type_error ~typ:"boolean" ~value:v
| v -> simple_type_error "boolean"
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 abort () = simple_type_error "duration" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields =
......@@ -193,7 +216,7 @@ let validate_duration =
(match subs.(14) with "" -> [] | v -> ["second", validate_integer v])
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_error _ -> abort ()
let validate_dateTime =
let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
......@@ -201,7 +224,7 @@ let validate_dateTime =
(strip_parens timezone_RE_raw))
in
fun s ->
let abort () = simple_type_error ~typ:"dateTime" ~value:s in
let abort () = simple_type_error "dateTime" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields =
......@@ -211,12 +234,12 @@ let validate_dateTime =
parse_timezone' subs.(4)
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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 abort () = simple_type_error "gYearMonth" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields = [
......@@ -226,12 +249,12 @@ let validate_gYearMonth =
] @ parse_timezone' subs.(4)
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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 abort () = simple_type_error "gYear" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields = [
......@@ -240,12 +263,12 @@ let validate_gYear =
] @ parse_timezone' subs.(3)
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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 abort () = simple_type_error "gMonthDay" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields = [
......@@ -254,38 +277,38 @@ let validate_gMonthDay =
] @ parse_timezone' subs.(3)
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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 abort () = simple_type_error "gDay" 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 ()
with Schema_builtin_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 abort () = simple_type_error "gMonth" 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 ()
with Schema_builtin_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 abort () = simple_type_error "time" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields =
......@@ -295,14 +318,14 @@ let validate_time =
| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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 abort () = simple_type_error "date" in
let subs = try Pcre.extract ~rex s with Not_found -> abort () in
try
let fields =
......@@ -313,12 +336,12 @@ let validate_date =
| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
in
Value.vrecord fields
with XSI_validation_error _ -> abort ()
with Schema_builtin_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;
simple_type_error "hexBinary";
let res = String.create (len / 2) in
let rec aux idx =
if idx < len then begin
......@@ -336,7 +359,7 @@ 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
with Neturl.Malformed_URL -> simple_type_error "anyURI"
(** {2 API backend} *)
......@@ -366,12 +389,7 @@ let list' name itemname =
let fill () = (* fill "builtins" hashtbl *)
(* TODO missing built-in simple types: xsd:float, xsd:double, xsd:QName,
* xsd:NOTATION, xsd:decimal, xsd:long, xsd:int: xsd:short, xsd:byte
*)
let zero = Value.Integer Intervals.V.zero in
let one = Value.Integer (Intervals.V.succ Intervals.V.zero) in
let minus_one = Value.Integer (Intervals.V.pred Intervals.V.zero) in
* xsd:NOTATION, xsd:decimal *)
(* primitive builtins *)
......@@ -380,10 +398,9 @@ let fill () = (* fill "builtins" hashtbl *)
alias "xsd:anyType" "xsd:anySimpleType";
reg "xsd:string"
(Primitive "xsd:string", Builtin_defs.string, validate_string);
reg "xsd:integer"
(* not a primitive for Schema, but a primitive for us since we have neither
* xsd:decimal nor {total,fraction}Digits support *)
(Primitive "xsd:integer", Builtin_defs.int, validate_integer);
reg "xsd:decimal"
(* collapsed in CDuce to an integer, since CDuce has no decimal numbers *)
(Primitive "xsd:decimal", Builtin_defs.int, validate_decimal);
reg "xsd:boolean"
(Primitive "xsd:boolean", Builtin_defs.bool, validate_bool);
reg "xsd:hexBinary"
......@@ -413,22 +430,49 @@ let fill () = (* fill "builtins" hashtbl *)
(* derived builtins *)
reg "xsd:integer"
(restrict' "xsd:integer" "xsd:decimal" no_facets, (* fake restriction *)
Builtin_defs.int, validate_integer);
reg "xsd:nonPositiveInteger"
(restrict' "xsd:nonPositiveInteger" "xsd:integer"
{ no_facets with maxInclusive = Some (zero, false) },
{ no_facets with maxInclusive = Some (Value.Integer zero, false) },
nonPositiveInteger_type, validate_nonPositiveInteger);
reg "xsd:negativeInteger"
(restrict' "xsd:negativeInteger" "xsd:nonPositiveInteger"
{ no_facets with maxInclusive = Some (minus_one, false) },
{ no_facets with maxInclusive = Some (Value.Integer minus_one, false) },
negativeInteger_type, validate_negativeInteger);
reg "xsd:nonNegativeInteger"
(restrict' "xsd:nonNegativeInteger" "xsd:integer"
{ no_facets with minInclusive = Some (zero, false) },
{ no_facets with minInclusive = Some (Value.Integer zero, false) },
nonNegativeInteger_type, validate_nonNegativeInteger);
reg "xsd:positiveInteger"
(restrict' "xsd:positiveInteger" "xsd:nonNegativeInteger"
{ no_facets with minInclusive = Some (one, false) },
{ no_facets with minInclusive = Some (Value.Integer one, false) },
positiveInteger_type, validate_positiveInteger);
reg "xsd:long"
(restrict' "xsd:long" "xsd:integer"
{ no_facets with
minInclusive = Some (Value.Integer long_l, false);
maxInclusive = Some (Value.Integer long_r, false)},
long_type, validate_long);
reg "xsd:int"
(restrict' "xsd:int" "xsd:long"
{ no_facets with
minInclusive = Some (Value.Integer int_l, false);
maxInclusive = Some (Value.Integer int_r, false)},
int_type, validate_int);
reg "xsd:short"
(restrict' "xsd:short" "xsd:int"
{ no_facets with
minInclusive = Some (Value.Integer short_l, false);
maxInclusive = Some (Value.Integer short_r, false)},
short_type, validate_short);
reg "xsd:byte"
(restrict' "xsd:byte" "xsd:short"
{ no_facets with
minInclusive = Some (Value.Integer byte_l, false);
maxInclusive = Some (Value.Integer byte_r, false)},
byte_type, validate_short);
reg "xsd:normalizedString"
(restrict' "xsd:normalizedString" "xsd:string"
{ no_facets with whiteSpace = `Replace, false },
......@@ -466,5 +510,5 @@ let trd (_,_,z) = z
let get_builtin name = fst (lookup name)
let cd_type_of_builtin name = snd (lookup name)
let validator_of_builtin name = trd (lookup name)
let validate_builtin name = trd (lookup name)
......@@ -2,10 +2,16 @@
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception Schema_builtin_error of string
val is_builtin: string -> bool
val get_builtin: string -> Schema_types.simple_type_definition
val iter_builtin: (Schema_types.simple_type_definition -> unit) -> unit
val cd_type_of_builtin: string -> Types.descr
val validator_of_builtin: string -> (string -> Value.t)
(** @raise Schema_builtin_error [name] in case of validation error, where
* [name] is the name of a schema built in type prefixed with
* Schema_xml.xsd_prefix *)
val validate_builtin: string -> string -> Value.t
......@@ -34,6 +34,11 @@ let name_of_type_definition = function
| Complex ct -> name_of_complex_type_definition ct
let name_of_attribute_declaration (name, _, _) = name
let name_of_attribute_use (_, (name, _, _), _) = name
let name_of_attribute_group_definition = fst
let name_of_model_group_definition = fst
let name_of_particle = function
| (_, _, Elt elt_decl_ref) -> name_of_element_declaration !elt_decl_ref
| _ -> assert false
let variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic st
| Derived (_, variety, _, _) -> variety
......@@ -58,7 +63,7 @@ let iter_attribute_groups schema f = List.iter f schema.attribute_groups
let iter_model_groups schema f = List.iter f schema.model_groups
exception XSD_validation_error of string
exception XSI_validation_error of string
exception XSI_validation_error of validation_context * string
let regexp' s = Pcre.regexp ~flags:[`UTF8] s
......@@ -207,3 +212,69 @@ let restrict base new_facets new_name =
in
Derived (new_name, variety, facets, base)
let get_type name schema =
List.find
(fun x ->
try
name_of_type_definition x = name
with Invalid_argument _ -> false)
schema.types
let get_attribute name schema =
List.find
(fun x ->
try
name_of_attribute_declaration x = name
with Invalid_argument _ -> false)
schema.attributes
let get_element name schema =
List.find
(fun x ->
try
name_of_element_declaration x = name
with Invalid_argument _ -> false)
schema.elements
let get_attribute_group name schema =
List.find
(fun x ->
try
name_of_attribute_group_definition x = name
with Invalid_argument _ -> false)
schema.attribute_groups
let get_model_group name schema =
List.find
(fun x ->
try
name_of_model_group_definition x = name
with Invalid_argument _ -> false)
schema.model_groups
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
let get_component kind name schema =
let rec tries = function
| [] -> raise Not_found
| hd :: tl -> (try hd () with Not_found -> tries tl)
in
let elt () = Element (get_element name schema) in
let typ () = Type (get_type name schema) in
let att () = Attribute (get_attribute name schema) in
let att_group () = Attribute_group (get_attribute_group name schema) in
let mod_group () = Model_group (get_model_group name schema) in
match kind with
| Some `Element -> elt ()
| Some `Type -> typ ()
| Some `Attribute -> att ()
| Some `Attribute_group -> att_group ()
| Some `Model_group -> mod_group ()
| None -> tries [ elt; typ; att; att_group; mod_group ]
let string_of_component_kind (kind: component_kind) =
match kind with
| Some `Type -> "type"
| Some `Element -> "element"
| Some `Attribute -> "attribute"
| Some `Attribute_group -> "attribute group"
| Some `Model_group -> "model group"
| None -> "component"
......@@ -3,10 +3,10 @@
open Schema_types
(** validation failure *)
(** {2 Exceptions} *)
exception XSD_validation_error of string
exception XSI_validation_error of string
exception XSI_validation_error of validation_context * string
(** {2 XSD printer *)
......@@ -19,11 +19,6 @@ val print_attribute_group :
val print_model_group : Format.formatter -> model_group_definition -> unit
val print_simple_type : Format.formatter -> simple_type_definition -> unit
val print_complex_type : Format.formatter -> complex_type_definition -> unit
(*
val print_ct : Format.formatter -> content_type -> unit
val print_particle : Format.formatter -> particle -> unit
val print_term : Format.formatter -> term -> unit
*)
(** {2 Deconstruction functions} *)
......@@ -33,12 +28,26 @@ val name_of_simple_type_definition : simple_type_definition -> string
val name_of_complex_type_definition : complex_type_definition -> string
val name_of_attribute_declaration : attribute_declaration -> string
val name_of_attribute_use : attribute_use -> string
val name_of_attribute_group_definition : attribute_group_definition -> string
val name_of_model_group_definition : model_group_definition -> string
val name_of_particle : particle -> string
val string_of_component_kind : component_kind -> string
val variety_of_simple_type_definition : simple_type_definition -> variety
val facets_of_simple_type_definition : simple_type_definition -> facets
val simple_type_of_type : type_definition -> simple_type_definition
val complex_type_of_type : type_definition -> complex_type_definition
val content_type_of_type : type_definition -> content_type
val get_type: string -> schema -> type_definition
val get_attribute: string -> schema -> attribute_declaration
val get_element: string -> schema -> element_declaration
val get_attribute_group: string -> schema -> attribute_group_definition
val get_model_group: string -> schema -> model_group_definition
val get_component: component_kind -> string -> schema -> component
val iter_types: schema -> (type_definition -> unit) -> unit
val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
val iter_elements: schema -> (element_declaration -> unit) -> unit
......@@ -55,8 +64,7 @@ val merge_facets: facets -> facets -> facets
val restrict: simple_type_definition -> facets -> string option ->
simple_type_definition
(** {2 Miscellaneous} *)
(** {2 Miscellaneous} *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
to <`Collapse, true>, the mandatory value for all non string derived simple
types) *)
......
......@@ -73,7 +73,7 @@ let parse_facets base n =
debug_print ~n "Schema_parser.parse_facet";
let validate_base_type = Schema_validator.validate_simple_type base in
let validate_nonNegativeInteger =
Schema_builtin.validator_of_builtin "xsd:nonNegativeInteger"
Schema_builtin.validate_builtin "xsd:nonNegativeInteger"
in
let facets = ref no_facets in
n#iter_nodes (fun n ->
......@@ -92,7 +92,7 @@ let parse_facets base n =
let length = integer_of_value_t (validate_nonNegativeInteger value) in
facets := { !facets with maxLength = Some (length, fixed) }
| T_element "xsd:enumeration" ->
let value = _attribute "value" n in
let value = Value.string_latin1 (_attribute "value" n) in
let value = validate_base_type value in
let new_enumeration =
(match !facets.enumeration with
......@@ -110,19 +110,19 @@ let parse_facets base n =
| _ -> assert false),
fixed) }
| T_element "xsd:maxInclusive" ->
let value = _attribute "value" n in
let value = Value.string_latin1 (_attribute "value" n) in
facets := { !facets with
maxInclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:maxExclusive" ->
let value = _attribute "value" n in
let value = Value.string_latin1 (_attribute "value" n) in
facets := { !facets with
maxExclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:minInclusive" ->
let value = _attribute "value" n in
let value = Value.string_latin1 (_attribute "value" n) in
facets := { !facets with
minInclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:minExclusive" ->
let value = _attribute "value" n in
let value = Value.string_latin1 (_attribute "value" n) in
facets := { !facets with
minExclusive = Some (validate_base_type value, fixed) }
| _ -> ());
......@@ -195,10 +195,12 @@ and find_member_types (resolver: resolver) n =
let parse_att_value_constraint stype_def n =
debug_print ~n "Schema_parser.parse_att_value_constraint";
if _has_attribute "default" n then
let value = validate_simple_type stype_def (_attribute "default" n) in
let value = Value.string_latin1 (_attribute "default" n) in
let value = validate_simple_type stype_def value in
Some (`Default value)
else if _has_attribute "fixed" n then
let value = validate_simple_type stype_def (_attribute "fixed" n) in
let value = Value.string_latin1 (_attribute "fixed" n) in
let value = validate_simple_type stype_def value in
Some (`Fixed value)
else
None
......@@ -213,10 +215,12 @@ let parse_elt_value_constraint type_def n =
| _ -> validate_simple_type (Primitive "xsd:string")
in
if _has_attribute "default" n then
let value = validate_value (_attribute "default" n) in
let value = Value.string_latin1 (_attribute "default" n) in
let value = validate_value value in
Some (`Default value)
else if _has_attribute "fixed" n then
let value = validate_value (_attribute "fixed" n) in
let value = Value.string_latin1 (_attribute "fixed" n) in
let value = validate_value value in
Some (`Fixed value)
else
None
......
......@@ -13,8 +13,6 @@
(** {2 XSD representation} *)
(** {2 XSD representation} *)
type xs_nonNegativeInteger = Intervals.V.t (* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)