Skip to content

GitLab

Commit 76416684 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-17 17:01:05 by afrisch] Handle recursion in schema 

Original author: afrisch
Date: 2005-02-17 17:01:05+00:00
parent 7adc4fb0
Hide whitespace changes
Inline Side-by-side
schema/schema_builtin.ml
View file @ 76416684
......@@ -422,10 +422,11 @@ let restrict' name basename new_facets =
let facets =
merge_facets (facets_of_simple_type_definition base) new_facets
in
Derived (Some name, variety, facets, base)
Derived (Some name, variety, facets, ref (Simple base))
let list' name itemname =
let (name, itemname) = (add_xsd_prefix name, add_xsd_prefix itemname) in
let (base, _, _) = Hashtbl.find builtins itemname in
let base = ref (Simple base) in
Derived (Some name, List base, no_facets, base)
let fill () = (* fill "builtins" hashtbl *)
......@@ -480,43 +481,43 @@ let fill () = (* fill "builtins" hashtbl *)
Builtin_defs.int, validate_integer);
reg "nonPositiveInteger"
(restrict' "nonPositiveInteger" "integer"
{ no_facets with maxInclusive = Some (Value.Integer zero, false) },
{ no_facets with maxInclusive = Some (lazy (Value.Integer zero), false) },
nonPositiveInteger_type, validate_nonPositiveInteger);
reg "negativeInteger"
(restrict' "negativeInteger" "nonPositiveInteger"
{ no_facets with maxInclusive = Some (Value.Integer minus_one, false) },
{ no_facets with maxInclusive = Some (lazy (Value.Integer minus_one), false) },
negativeInteger_type, validate_negativeInteger);
reg "nonNegativeInteger"
(restrict' "nonNegativeInteger" "integer"
{ no_facets with minInclusive = Some (Value.Integer zero, false) },
{ no_facets with minInclusive = Some (lazy (Value.Integer zero), false) },
nonNegativeInteger_type, validate_nonNegativeInteger);
reg "positiveInteger"
(restrict' "positiveInteger" "nonNegativeInteger"
{ no_facets with minInclusive = Some (Value.Integer one, false) },
{ no_facets with minInclusive = Some (lazy (Value.Integer one), false) },
positiveInteger_type, validate_positiveInteger);
reg "long"
(restrict' "long" "integer"
{ no_facets with
minInclusive = Some (Value.Integer long_l, false);
maxInclusive = Some (Value.Integer long_r, false)},
minInclusive = Some (lazy (Value.Integer long_l), false);
maxInclusive = Some (lazy (Value.Integer long_r), false)},
long_type, validate_long);
reg "int"
(restrict' "int" "long"
{ no_facets with
minInclusive = Some (Value.Integer int_l, false);
maxInclusive = Some (Value.Integer int_r, false)},
minInclusive = Some (lazy (Value.Integer int_l), false);
maxInclusive = Some (lazy (Value.Integer int_r), false)},
int_type, validate_int);
reg "short"
(restrict' "short" "int"
{ no_facets with
minInclusive = Some (Value.Integer short_l, false);
maxInclusive = Some (Value.Integer short_r, false)},
minInclusive = Some (lazy (Value.Integer short_l), false);
maxInclusive = Some (lazy (Value.Integer short_r), false)},
short_type, validate_short);
reg "byte"
(restrict' "byte" "short"
{ no_facets with
minInclusive = Some (Value.Integer byte_l, false);
maxInclusive = Some (Value.Integer byte_r, false)},
minInclusive = Some (lazy (Value.Integer byte_l), false);
maxInclusive = Some (lazy (Value.Integer byte_r), false)},
byte_type, validate_short);
reg "normalizedString"
(restrict' "normalizedString" "string"
......
schema/schema_common.ml
View file @ 76416684
open Printf
open Encodings
......@@ -22,6 +21,69 @@ let no_facets = {
*)
}
(** 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;
}
let rec facets_of_simple_type_definition = function
| Primitive _ -> no_facets
| Derived (_, _, facets, _) -> facets
let rec variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic (ref (Simple st))
| Derived (_, variety, _, _) -> variety
let get_simple_type = function
| { contents = Simple c } -> c
| { contents = AnyType } -> Primitive (Utf8.mk "xsd:anySimpleType")
| _ -> assert false
let rec normalize_simple_type = function
| Derived (name, Restrict, new_facets, base) ->
(match normalize_simple_type (get_simple_type base) with
| Derived (_,variety,old_facets,base) ->
Derived (name,variety,merge_facets old_facets new_facets,base)
| Primitive _ as st ->
let b = ref (Simple st) in
Derived (name,Atomic b,new_facets,b))
| _ -> assert false
let name_of_element_declaration elt = elt.elt_name
let name_of_simple_type_definition = function
| Primitive name -> name
......@@ -42,7 +104,7 @@ 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
| (Primitive name) as st -> Atomic (ref (Simple st))
| Derived (_, variety, _, _) -> variety
let simple_type_of_type = function
| Simple s -> s
......@@ -53,10 +115,7 @@ let complex_type_of_type = function
let content_type_of_type = function
| AnyType -> assert false
| Complex { ct_content = ct } -> ct
| Simple st -> CT_simple st
let facets_of_simple_type_definition = function
| Primitive _ -> no_facets
| Derived (_, _, facets, _) -> facets
| Simple st -> CT_simple (ref (Simple st))
let iter_types schema f = List.iter f schema.types
let iter_attributes schema f = List.iter f schema.attributes
......@@ -109,17 +168,18 @@ let get_interval facets =
* Value.t is an integer! (no other intervals are actually supported
* by the CDuce type system)
*)
let getint f = Value.get_integer (Lazy.force f) in
let min =
match facets.minInclusive, facets.minExclusive with
| Some (Value.Integer i, _), None -> Some i
| None, Some (Value.Integer i, _) -> Some (Intervals.V.succ i)
| Some (i, _), None -> Some (getint i)
| None, Some (i, _) -> Some (Intervals.V.succ (getint i))
| None, None -> None
| _ -> assert false
in
let max =
match facets.maxInclusive, facets.maxExclusive with
| Some (Value.Integer i, _), None -> Some i
| None, Some (Value.Integer i, _) -> Some (Intervals.V.pred i)
| Some (i, _), None -> Some (getint i)
| None, Some (i, _) -> Some (Intervals.V.pred (getint i))
| None, None -> None
| _ -> assert false
in
......@@ -129,6 +189,7 @@ let get_interval facets =
| None, Some max -> Intervals.left max
| None, None -> Intervals.any
let print_simple_type fmt = function
| Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
| Derived (Some name, _, _, _) ->
......@@ -144,7 +205,8 @@ let print_type fmt = function
| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
let print_attribute fmt { attr_name = name; attr_typdef = t } =
Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type
(get_simple_type t)
let print_element fmt { elt_uid = id; elt_name = name } =
Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
......@@ -189,51 +251,6 @@ let print_schema fmt schema =
Format.fprintf fmt "\n"
end
(** 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;
}
let restrict base new_facets new_name =
let variety = variety_of_simple_type_definition base in
let facets =
merge_facets (facets_of_simple_type_definition base) new_facets
in
Derived (new_name, variety, facets, base)
let get_type name schema =
List.find
......
schema/schema_common.mli
View file @ 76416684
......@@ -23,6 +23,8 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
val get_simple_type: type_ref -> simple_type_definition
val name_of_element_declaration : element_declaration -> Utf8.t
val name_of_type_definition : type_definition -> Utf8.t
val name_of_simple_type_definition : simple_type_definition -> Utf8.t
......@@ -65,10 +67,8 @@ val nullable: particle -> bool
val merge_facets: facets -> facets -> facets
(** restrict base new_facets new_name
* Implements simple type derivition by restriction *)
val restrict: simple_type_definition -> facets -> Utf8.t option ->
simple_type_definition
val normalize_simple_type: simple_type_definition -> simple_type_definition
(** {2 Miscellaneous} *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
......
schema/schema_parser.ml
View file @ 76416684
......@@ -9,8 +9,6 @@ open Schema_xml
let validation_error s = raise (XSD_validation_error s)
module NodeSet = Set.Make (Schema_xml.Node)
let fake_type_def =
Complex
{ ct_uid = -1;
......@@ -22,7 +20,7 @@ let fake_type_def =
let fake_elt_decl =
{ elt_uid = -2;
elt_name = Utf8.mk " FAKE ELT ";
elt_typdef = fake_type_def;
elt_typdef = ref fake_type_def;
elt_cstr = None }
let is_fake_type_def = (==) fake_type_def
let is_fake_elt_decl = (==) fake_elt_decl
......@@ -58,7 +56,8 @@ let hashtbl_deref tbl = Hashtbl.fold (fun _ v acc -> !v :: acc) tbl []
let hashtbl_values tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
let parse_facets base n =
let validate_base_type = Schema_validator.validate_simple_type base in
let validate_base_type v =
lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in
let validate_nonNegativeInteger =
Schema_builtin.validate_builtin (Utf8.mk "xsd:nonNegativeInteger")
in
......@@ -81,9 +80,9 @@ let parse_facets base n =
let value = Value.string_utf8 (_attr "value" n) in
let value = validate_base_type value in
let new_enumeration =
(match facets.enumeration with
| None -> Some (Value.ValueSet.singleton value)
| Some entries -> Some (Value.ValueSet.add value entries))
match facets.enumeration with
| None -> Some [ value ]
| Some entries -> Some (value :: entries)
in
{ facets with enumeration = new_enumeration }
| "xsd:whiteSpace" ->
......@@ -123,7 +122,8 @@ let default_fixed n f =
| None -> None
let parse_att_value_constraint stype_def n =
default_fixed n (validate_simple_type stype_def)
default_fixed n
(fun v -> lazy (validate_simple_type (get_simple_type stype_def) v))
let parse_min_max n =
(match _may_attr "minOccurs" n with
......@@ -199,106 +199,24 @@ let schema_of_node root =
validation_error ("Can't resolve: " ^ Utf8.get_str s))
in
let seen_nodes = ref NodeSet.empty in
let already_seen n = NodeSet.mem n !seen_nodes in
let see n =
if already_seen n
then validation_error (sprintf "Types/Elements loop (line: %d)" (_line n))
else seen_nodes := NodeSet.add n !seen_nodes in
let find_global_component tag_pred name =
let basename = Utf8.get_str (snd (Ns.split_qname name)) in
_find (fun n -> (_has_tag n tag_pred) && (_is_attr "name" n basename)) root
in
let rec register_typ name def =
let name = qualify name in
if (Hashtbl.mem typs name) &&
(not (is_fake_type_def !(Hashtbl.find typs name))) then
validation_error ("Redefinition of type: " ^ Utf8.get_str name);
let type_def_ref = resolve_typ ~fix_ns:false ~now:false name in
type_def_ref := def
and register_elt name decl =
let name = qualify name in
if (Hashtbl.mem elts name) &&
(not (is_fake_elt_decl !(Hashtbl.find elts name))) then
validation_error ("Redefinition of element: " ^ Utf8.get_str name);
let elt_decl_ref = resolve_elt ~fix_ns:false ~now:false name in
elt_decl_ref := decl
and register_att name decl =
let name = qualify name in
if Hashtbl.mem attrs name then
validation_error ("Redefinition of attribute: " ^ Utf8.get_str name);
Hashtbl.replace attrs name decl
and register_att_group name def =
let name = qualify name in
if Hashtbl.mem attr_groups name then
validation_error ("Redefinition of attribute group: " ^
Utf8.get_str name);
Hashtbl.replace attr_groups name def
and register_model_group name def =
let name = qualify name in
if Hashtbl.mem model_groups name then
validation_error ("Redefinition of model group: " ^ Utf8.get_str name);
Hashtbl.replace model_groups name def
and resolve_typ ?(fix_ns = true) ~now name =
let name = if fix_ns then fix_namespace name else name in
try Hashtbl.find typs name
with Not_found ->
let type_def =
if now then (* resolve now: look for global type definitions *)
let type_node =
try find_global_component
(fun tag -> (tag = "xsd:simpleType") || (tag = "xsd:complexType"))
name
with Not_found ->
validation_error ("Can't find definition of type: " ^
Utf8.get_str name)
in
if _tag type_node = "xsd:simpleType" then
Simple (parse_simple_type type_node)
else (* _tag_name type_node = "xsd:complexType" *)
Complex (parse_complex_type type_node)
else (* resolve later: return a fake type ref *)
fake_type_def
in
let type_def_ref = ref type_def in
Hashtbl.replace typs name type_def_ref;
type_def_ref
and resolve_simple_typ ?(fix_ns = true) name =
match !(resolve_typ ~fix_ns ~now:true name) with
| AnyType -> Primitive (Utf8.mk "xsd:anySimpleType")
| Simple st -> st
| Complex _ -> assert false
and resolve_elt ?(fix_ns = true) ~now name =
let name = if fix_ns then fix_namespace name else name in
try Hashtbl.find elts name
with Not_found ->
let elt_decl =
if now then (* resolve now: look for global element declarations *)
let elt_node =
try find_global_component ((=) "xsd:element") name
with Not_found ->
validation_error ("Can't find declaration of element: " ^
Utf8.get_str name)
in
parse_elt_decl elt_node
else (* resolve later: return a fake element declaration *)
fake_elt_decl
in
let elt_decl_ref = ref elt_decl in
Hashtbl.replace elts name elt_decl_ref;
elt_decl_ref
let rec resolve_typ name =
try Hashtbl.find typs (fix_namespace name)
with Not_found -> assert false
and resolve_simple_typ name =
resolve_typ name
and resolve_elt name =
try Hashtbl.find elts (fix_namespace name)
with Not_found -> assert false
and resolve_att ?(fix_ns = true) name =
let name = if fix_ns then fix_namespace name else name in
and resolve_att name =
let name = fix_namespace name in
try Hashtbl.find attrs name
with Not_found ->
let node =
......@@ -311,8 +229,8 @@ let schema_of_node root =
Hashtbl.replace attrs name att_decl;
att_decl
and resolve_att_group ?(fix_ns = true) name =
let name = if fix_ns then fix_namespace name else name in
and resolve_att_group name =
let name = fix_namespace name in
try Hashtbl.find attr_groups name
with Not_found ->
let node =
......@@ -325,8 +243,8 @@ let schema_of_node root =
Hashtbl.replace attr_groups name att_group_decl;
att_group_decl
and resolve_model_group ?(fix_ns = true) name =
let name = if fix_ns then fix_namespace name else name in
and resolve_model_group name =
let name = fix_namespace name in
try Hashtbl.find model_groups name
with Not_found ->
let node =
......@@ -341,29 +259,28 @@ let schema_of_node root =
(* parse an xsd:simpleType element *)
and parse_simple_type n =
see n;
let name = _may_attr "name" n in
match _may_elem "xsd:restriction" n with
| Some restriction ->
let base = find_base_simple_type restriction in
let facets = parse_facets base restriction in
restrict base facets name
ref (Simple (Derived (name, Restrict, facets, base)))
| None ->
match _may_elem "xsd:list" n with
| Some list ->
let items = find_item_type list in
Derived (name, List items, no_facets, anySimpleType)
ref (Simple (Derived (name, List items, no_facets, ref (Simple anySimpleType))))
| None ->
match _may_elem "xsd:union" n with
| Some union ->
let members = find_member_types union in
Derived (name, Union members, no_facets, anySimpleType)
ref (Simple (Derived (name, Union members, no_facets, ref (Simple anySimpleType))))
| None ->
assert false
(* look for a simple type def: try attribute "base", try "simpleType" child,
* fail *)
and find_base_simple_type n =
and find_base_simple_type n : Schema_types.type_ref=
match _may_attr "base" n with
| Some v -> resolve_simple_typ v
| None ->
......@@ -398,13 +315,15 @@ let schema_of_node root =
| members -> members
and parse_elt_value_constraint type_def n =
let validate_value v = match type_def with
| Simple st_def
| Complex { ct_content = CT_simple st_def } ->
validate_simple_type st_def v
| _ ->
validate_simple_type (Primitive (Utf8.mk "xsd:string")) v
and parse_elt_value_constraint (type_def: type_ref) n =
let validate_value v =
lazy (match (!type_def : type_definition) with
| Simple st_def
| Complex { ct_content = CT_simple { contents = Simple st_def } } ->
validate_simple_type st_def v
| _ ->
validate_simple_type (Primitive (Utf8.mk "xsd:string")) v
)
in
default_fixed n validate_value
......@@ -416,10 +335,9 @@ let schema_of_node root =
| None ->
match _may_attr "type" n with
| Some v -> resolve_simple_typ v
| None -> anySimpleType
| None -> ref (Simple anySimpleType)
and parse_att_decl n =
see n;
let typdef = find_simple_type n in
{ attr_name = _attr "name" n;
attr_typdef = typdef;
......@@ -483,12 +401,11 @@ let schema_of_node root =
match _may_elem "xsd:extension" content with
| Some v -> (v, `Extension)
| None -> assert false in
let base = resolve_typ ~now:true (_attr "base" derivation) in
let base = resolve_typ (_attr "base" derivation) in
let uses = parse_attribute_uses derivation_type !base derivation in
(derivation,derivation_type,!base,uses)
and parse_complex_type n =
see n;
and parse_complex_type n : type_ref =
let name = _may_attr "name" n in
let (base,derivation_type,uses,content_type) =
match _may_elem "xsd:simpleContent" n with
......@@ -498,7 +415,7 @@ let schema_of_node root =
| Some c -> parse_complex_content n c
| None -> parse_other_content n
in
complex name base derivation_type uses content_type
ref (Complex (complex name base derivation_type uses content_type))
and parse_simple_content n content =
let derivation,derivation_type,base,uses = get_derivation content in
......@@ -509,18 +426,10 @@ let schema_of_node root =
match _may_elem "xsd:simpleType" derivation with
| Some s -> parse_simple_type s
| None -> base in
let new_facets = merge_facets' base (parse_facets base n) in
let restricted_simple_type_def =
match base with
| Primitive name ->
Derived (None, variety_of_simple_type_definition base,
new_facets, base)
| Derived (_, variety, _, _) ->
Derived (None, variety, new_facets, base)
in
CT_simple restricted_simple_type_def
| `Extension, Complex { ct_content = CT_simple base } -> CT_simple base
| `Extension, Simple simple_type_def -> CT_simple simple_type_def
CT_simple (ref (Simple (Derived (None, Restrict, parse_facets base n, base))))
| `Extension, Complex { ct_content = CT_simple base } ->
CT_simple base
| `Extension, (Simple _ as st) -> CT_simple (ref st)
| _ -> assert false
in
base,derivation_type,uses,content_type
......@@ -569,7 +478,6 @@ let schema_of_node root =
and parse_elt_decl n: element_declaration =
see n;
match _may_attr "name" n with
| None -> validation_error "missing element name"
| Some name ->
......@@ -581,14 +489,14 @@ let schema_of_node root =
* child, try "type" attribute, return anyType *)
and find_element_type n =
match _may_elem "xsd:simpleType" n with
| Some n -> Simple (parse_simple_type n)
| Some n -> parse_simple_type n
| None ->
match _may_elem "xsd:complexType" n with
| Some n -> Complex (parse_complex_type n)
| Some n -> parse_complex_type n
| None ->
match _may_attr "type" n with
| Some v -> !(resolve_typ ~now:true v)
| None -> AnyType
| Some v -> resolve_typ v
| None -> ref AnyType