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

[r2005-02-25 13:23:48 by afrisch] xsi:nil

Original author: afrisch
Date: 2005-02-25 13:23:49+00:00
parent 463363bd
...@@ -92,48 +92,46 @@ parser/url.cmo: parser/location.cmi parser/url.cmi ...@@ -92,48 +92,46 @@ parser/url.cmo: parser/location.cmi parser/url.cmi
parser/url.cmx: parser/location.cmx parser/url.cmi parser/url.cmx: parser/location.cmx parser/url.cmi
schema/schema_pcre.cmo: misc/encodings.cmi schema/schema_pcre.cmi schema/schema_pcre.cmo: misc/encodings.cmi schema/schema_pcre.cmi
schema/schema_pcre.cmx: misc/encodings.cmx schema/schema_pcre.cmi schema/schema_pcre.cmx: misc/encodings.cmx schema/schema_pcre.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \ schema/schema_types.cmo: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \ schema/schema_types.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
runtime/value.cmx schema/schema_types.cmi runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/encodings.cmi parser/location.cmi \ schema/schema_xml.cmo: misc/encodings.cmi parser/location.cmi misc/ns.cmi \
schema/schema_pcre.cmi parser/url.cmi schema/schema_xml.cmi schema/schema_pcre.cmi parser/url.cmi schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx parser/location.cmx \ schema/schema_xml.cmx: misc/encodings.cmx parser/location.cmx misc/ns.cmx \
schema/schema_pcre.cmx parser/url.cmx schema/schema_xml.cmi schema/schema_pcre.cmx parser/url.cmx schema/schema_xml.cmi
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi \ schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi \
types/intervals.cmi misc/ns.cmi schema/schema_pcre.cmi \ types/intervals.cmi misc/ns.cmi schema/schema_pcre.cmi \
schema/schema_types.cmi schema/schema_xml.cmi runtime/value.cmi \ schema/schema_types.cmi schema/schema_xml.cmi types/types.cmi \
schema/schema_common.cmi runtime/value.cmi schema/schema_common.cmi
schema/schema_common.cmx: types/atoms.cmx misc/encodings.cmx \ schema/schema_common.cmx: types/atoms.cmx misc/encodings.cmx \
types/intervals.cmx misc/ns.cmx schema/schema_pcre.cmx \ types/intervals.cmx misc/ns.cmx schema/schema_pcre.cmx \
schema/schema_types.cmx schema/schema_xml.cmx runtime/value.cmx \ schema/schema_types.cmx schema/schema_xml.cmx types/types.cmx \
schema/schema_common.cmi runtime/value.cmx schema/schema_common.cmi
schema/schema_builtin.cmo: types/atoms.cmi types/builtin_defs.cmi \ schema/schema_builtin.cmo: types/atoms.cmi types/builtin_defs.cmi \
misc/encodings.cmi types/intervals.cmi misc/ns.cmi \ misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
schema/schema_common.cmi schema/schema_pcre.cmi schema/schema_types.cmi \ schema/schema_common.cmi schema/schema_pcre.cmi schema/schema_types.cmi \
types/sequence.cmi types/types.cmi runtime/value.cmi \ schema/schema_xml.cmi types/sequence.cmi types/types.cmi \
schema/schema_builtin.cmi runtime/value.cmi schema/schema_builtin.cmi
schema/schema_builtin.cmx: types/atoms.cmx types/builtin_defs.cmx \ schema/schema_builtin.cmx: types/atoms.cmx types/builtin_defs.cmx \
misc/encodings.cmx types/intervals.cmx misc/ns.cmx \ misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
schema/schema_common.cmx schema/schema_pcre.cmx schema/schema_types.cmx \ schema/schema_common.cmx schema/schema_pcre.cmx schema/schema_types.cmx \
types/sequence.cmx types/types.cmx runtime/value.cmx \ schema/schema_xml.cmx types/sequence.cmx types/types.cmx \
schema/schema_builtin.cmi runtime/value.cmx schema/schema_builtin.cmi
schema/schema_validator.cmo: types/atoms.cmi misc/encodings.cmi \ schema/schema_validator.cmo: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
types/intervals.cmi misc/ns.cmi schema/schema_builtin.cmi \ schema/schema_builtin.cmi schema/schema_common.cmi schema/schema_pcre.cmi \
schema/schema_common.cmi schema/schema_pcre.cmi schema/schema_types.cmi \ schema/schema_types.cmi runtime/value.cmi schema/schema_validator.cmi
runtime/value.cmi schema/schema_validator.cmi schema/schema_validator.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
schema/schema_validator.cmx: types/atoms.cmx misc/encodings.cmx \ schema/schema_builtin.cmx schema/schema_common.cmx schema/schema_pcre.cmx \
types/intervals.cmx misc/ns.cmx schema/schema_builtin.cmx \ schema/schema_types.cmx runtime/value.cmx schema/schema_validator.cmi
schema/schema_common.cmx schema/schema_pcre.cmx schema/schema_types.cmx \ schema/schema_parser.cmo: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmx schema/schema_validator.cmi
schema/schema_parser.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi schema/schema_pcre.cmi \ schema/schema_builtin.cmi schema/schema_common.cmi schema/schema_pcre.cmi \
schema/schema_types.cmi schema/schema_validator.cmi schema/schema_xml.cmi \ schema/schema_types.cmi schema/schema_validator.cmi schema/schema_xml.cmi \
parser/url.cmi runtime/value.cmi schema/schema_parser.cmi parser/url.cmi schema/schema_parser.cmi
schema/schema_parser.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \ schema/schema_parser.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx schema/schema_pcre.cmx \ schema/schema_builtin.cmx schema/schema_common.cmx schema/schema_pcre.cmx \
schema/schema_types.cmx schema/schema_validator.cmx schema/schema_xml.cmx \ schema/schema_types.cmx schema/schema_validator.cmx schema/schema_xml.cmx \
parser/url.cmx runtime/value.cmx schema/schema_parser.cmi parser/url.cmx schema/schema_parser.cmi
parser/ulexer.cmo: parser/ulexer.cmi parser/ulexer.cmo: parser/ulexer.cmi
parser/ulexer.cmx: parser/ulexer.cmi parser/ulexer.cmx: parser/ulexer.cmi
parser/ast.cmo: types/builtin_defs.cmi types/chars.cmi types/ident.cmo \ parser/ast.cmo: types/builtin_defs.cmi types/chars.cmi types/ident.cmo \
...@@ -157,19 +155,19 @@ typing/typed.cmo: types/ident.cmo parser/location.cmi misc/ns.cmi \ ...@@ -157,19 +155,19 @@ typing/typed.cmo: types/ident.cmo parser/location.cmi misc/ns.cmi \
typing/typed.cmx: types/ident.cmx parser/location.cmx misc/ns.cmx \ typing/typed.cmx: types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx schema/schema_types.cmx types/types.cmx types/patterns.cmx schema/schema_types.cmx types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \ typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/externals.cmi misc/html.cmi types/ident.cmo \ types/chars.cmi misc/encodings.cmi types/externals.cmi misc/html.cmi \
types/intervals.cmi parser/location.cmi misc/ns.cmi types/patterns.cmi \ types/ident.cmo parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi \ schema/schema_builtin.cmi schema/schema_common.cmi \
schema/schema_parser.cmi schema/schema_types.cmi types/sequence.cmi \ schema/schema_parser.cmi schema/schema_types.cmi schema/schema_xml.cmi \
misc/serialize.cmi misc/state.cmi misc/stats.cmi typing/typed.cmo \ types/sequence.cmi misc/serialize.cmi misc/state.cmi typing/typed.cmo \
types/types.cmi parser/url.cmi runtime/value.cmi typing/typer.cmi types/types.cmi runtime/value.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \ typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/externals.cmx misc/html.cmx types/ident.cmx \ types/chars.cmx misc/encodings.cmx types/externals.cmx misc/html.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \ types/ident.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx \ schema/schema_builtin.cmx schema/schema_common.cmx \
schema/schema_parser.cmx schema/schema_types.cmx types/sequence.cmx \ schema/schema_parser.cmx schema/schema_types.cmx schema/schema_xml.cmx \
misc/serialize.cmx misc/state.cmx misc/stats.cmx typing/typed.cmx \ types/sequence.cmx misc/serialize.cmx misc/state.cmx typing/typed.cmx \
types/types.cmx parser/url.cmx runtime/value.cmx typing/typer.cmi types/types.cmx runtime/value.cmx typing/typer.cmi
runtime/load_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \ runtime/load_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi parser/url.cmi runtime/value.cmi \ parser/location.cmi misc/ns.cmi parser/url.cmi runtime/value.cmi \
runtime/load_xml.cmi runtime/load_xml.cmi
...@@ -375,14 +373,16 @@ runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \ ...@@ -375,14 +373,16 @@ runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/types.cmi types/types.cmi
parser/location.cmi: misc/html.cmi parser/location.cmi: misc/html.cmi
schema/schema_pcre.cmi: misc/encodings.cmi schema/schema_pcre.cmi: misc/encodings.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \ schema/schema_types.cmi: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
schema/schema_common.cmi: types/atoms.cmi misc/encodings.cmi \
types/intervals.cmi misc/ns.cmi schema/schema_types.cmi types/types.cmi \
runtime/value.cmi runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi
schema/schema_common.cmi: misc/encodings.cmi types/intervals.cmi \
schema/schema_types.cmi runtime/value.cmi
schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \ schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \
schema/schema_types.cmi types/types.cmi runtime/value.cmi schema/schema_types.cmi types/types.cmi runtime/value.cmi
schema/schema_validator.cmi: schema/schema_types.cmi runtime/value.cmi schema/schema_validator.cmi: misc/encodings.cmi schema/schema_types.cmi \
runtime/value.cmi
schema/schema_parser.cmi: schema/schema_types.cmi schema/schema_parser.cmi: schema/schema_types.cmi
parser/parser.cmi: parser/ast.cmo parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi types/externals.cmi: types/types.cmi
...@@ -406,5 +406,5 @@ driver/cduce.cmi: misc/encodings.cmi runtime/value.cmi ...@@ -406,5 +406,5 @@ driver/cduce.cmi: misc/encodings.cmi runtime/value.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
query/query.cmi: parser/ast.cmo query/query.cmi: parser/ast.cmo
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \ schema/schema_types.cmi: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi runtime/value.cmi
...@@ -423,3 +423,8 @@ let simple_union name members = ...@@ -423,3 +423,8 @@ let simple_union name members =
st_facets = no_facets; st_facets = no_facets;
st_base = None } st_base = None }
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
...@@ -110,3 +110,8 @@ val simple_list: ...@@ -110,3 +110,8 @@ val simple_list:
val simple_union: val simple_union:
Ns.qname option -> simple_type_definition list -> simple_type_definition Ns.qname option -> simple_type_definition list -> simple_type_definition
val xsi_nil_type: Types.t
val xsi_nil_qname: Ns.qname
val xsi_nil_atom: Atoms.V.t
val xsi_nil_label: Ident.label
...@@ -29,15 +29,25 @@ let check_force v = ...@@ -29,15 +29,25 @@ let check_force v =
with Lazy.Undefined -> failwith "Cyclic type definition" with Lazy.Undefined -> failwith "Cyclic type definition"
let bool_attr attr n =
(* todo: normalization of whitespace ? *)
match _may_attr attr n with
| None -> false
| Some v -> (match Utf8.get_str v with
| "true" | "1" -> true
| "false" | "0" -> false
| _ -> failwith "Invalid boolean value")
(* element and complex type constructors which take cares of unique id *) (* element and complex type constructors which take cares of unique id *)
let element, complex = let element, complex =
let counter = ref 0 in let counter = ref 0 in
let element name type_def constr = let element name type_def constr nillable =
incr counter; incr counter;
{ elt_uid = !counter; { elt_uid = !counter;
elt_name = name; elt_name = name;
elt_typdef = type_def; elt_typdef = type_def;
elt_cstr = constr } elt_cstr = constr;
elt_nillable = nillable }
in in
let complex name (type_def: type_definition) deriv attrs ct = let complex name (type_def: type_definition) deriv attrs ct =
incr counter; incr counter;
...@@ -70,7 +80,7 @@ let parse_facets base n = ...@@ -70,7 +80,7 @@ let parse_facets base n =
i i
in in
let aux facets n tag = let aux facets n tag =
let fixed = _is_attr "fixed" n "true" in let fixed = bool_attr "fixed" n in
match tag with match tag with
| "xsd:length" -> | "xsd:length" ->
let length = parse_nonneg n in let length = parse_nonneg n in
...@@ -427,7 +437,7 @@ let schema_of_uri uri = ...@@ -427,7 +437,7 @@ let schema_of_uri uri =
and parse_complex_content n content = and parse_complex_content n content =
let derivation,derivation_type,base,uses = get_derivation content in let derivation,derivation_type,base,uses = get_derivation content in
let mixed = _is_attr "mixed" content "true" || _is_attr "mixed" n "true" in let mixed = bool_attr "mixed" content || bool_attr "mixed" n in
let particle_node = find_particle derivation in let particle_node = find_particle derivation in
let content_type = let content_type =
match derivation_type, particle_node with match derivation_type, particle_node with
...@@ -454,7 +464,7 @@ let schema_of_uri uri = ...@@ -454,7 +464,7 @@ let schema_of_uri uri =
and parse_other_content n = and parse_other_content n =
let uses = parse_attribute_uses `Restriction AnyType n in let uses = parse_attribute_uses `Restriction AnyType n in
let mixed = _is_attr "mixed" n "true" in let mixed = bool_attr "mixed" n in
let content_type = let content_type =
match find_particle n with match find_particle n with
| None -> CT_empty | None -> CT_empty
...@@ -476,7 +486,8 @@ let schema_of_uri uri = ...@@ -476,7 +486,8 @@ let schema_of_uri uri =
in in
let type_def = find_element_type n in let type_def = find_element_type n in
let value_constr = parse_elt_value_constraint type_def n in let value_constr = parse_elt_value_constraint type_def n in
element (ns,local) type_def value_constr let nillable = bool_attr "nillable" n in
element (ns,local) type_def value_constr nillable
(* look for a type definition, try "simpleType" child, try "complexType" (* look for a type definition, try "simpleType" child, try "complexType"
* child, try "type" attribute, return anyType *) * child, try "type" attribute, return anyType *)
......
...@@ -89,7 +89,8 @@ and element_declaration = ...@@ -89,7 +89,8 @@ and element_declaration =
{ elt_uid: int; { elt_uid: int;
elt_name: Ns.qname; elt_name: Ns.qname;
elt_typdef: type_ref; elt_typdef: type_ref;
elt_cstr: value_constraint option } elt_cstr: value_constraint option;
elt_nillable: bool }
and complex_type_definition = and complex_type_definition =
{ ct_uid: int; { ct_uid: int;
......
...@@ -89,7 +89,8 @@ and element_declaration = ...@@ -89,7 +89,8 @@ and element_declaration =
{ elt_uid: int; { elt_uid: int;
elt_name: Ns.qname; elt_name: Ns.qname;
elt_typdef: type_ref; elt_typdef: type_ref;
elt_cstr: value_constraint option } elt_cstr: value_constraint option;
elt_nillable: bool }
and complex_type_definition = and complex_type_definition =
{ ct_uid: int; { ct_uid: int;
......
...@@ -114,6 +114,12 @@ let expect_end_tag ctx = ...@@ -114,6 +114,12 @@ let expect_end_tag ctx =
| E_end_tag _ -> () | E_end_tag _ -> ()
| ev -> error (sprintf "Expected end tag, found %s" (string_of_event ev)) | ev -> error (sprintf "Expected end tag, found %s" (string_of_event ev))
let check_nil ctx =
match peek ctx with
| E_end_tag _ -> ()
| ev -> error (sprintf "Non-empty content with xsi:nil set : %s"
(string_of_event ev))
let expect_start_tag ctx tag = let expect_start_tag ctx tag =
match next ctx with match next ctx with
| E_start_tag t when Ns.QName.equal t tag -> () | E_start_tag t when Ns.QName.equal t tag -> ()
...@@ -127,15 +133,29 @@ let expect_any_start_tag ctx = ...@@ -127,15 +133,29 @@ let expect_any_start_tag ctx =
| ev -> error (sprintf "Expected start tag, found %s" | ev -> error (sprintf "Expected start tag, found %s"
(string_of_event ev)) (string_of_event ev))
type attrs = {
xsi_nil: bool;
attrs: (Ns.qname * Utf8.t) list
}
let get_bool v =
match Utf8.get_str v with
| "true" | "1" -> true
| "false" | "0" -> false
| _ -> failwith "Invalid boolean value"
let get_attributes ctx = let get_attributes ctx =
let rec aux attrs = let rec aux attrs nil =
match peek ctx with match peek ctx with
| E_attribute (qname, value) -> | E_attribute (qname,value) when Ns.QName.equal qname xsi_nil_qname ->
junk ctx; junk ctx;
aux ((qname,value)::attrs) aux attrs (get_bool value)
| _ -> attrs | E_attribute (qname, value) ->
junk ctx;
aux ((qname,value)::attrs) nil
| _ -> { attrs = attrs; xsi_nil = nil }
in in
aux [] aux [] false
let rec tries funs arg = let rec tries funs arg =
match funs with match funs with
...@@ -273,7 +293,7 @@ let validate_simple_type_wrapper ctx st_def = ...@@ -273,7 +293,7 @@ let validate_simple_type_wrapper ctx st_def =
let rec validate_any_type ctx = let rec validate_any_type ctx =
(* assumption: attribute events (if any) come first *) (* assumption: attribute events (if any) come first *)
let attrs = get_attributes ctx in let attrs = get_attributes ctx in
let attrs = List.map (fun (n,v) -> (n,Value.string_utf8 v)) attrs in let attrs = List.map (fun (n,v) -> (n,Value.string_utf8 v)) attrs.attrs in
let ctx = subctx true ctx in let ctx = subctx true ctx in
let rec aux attrs = let rec aux attrs =
...@@ -300,9 +320,9 @@ let validate_wildcard ctx w = ...@@ -300,9 +320,9 @@ let validate_wildcard ctx w =
expect_end_tag ctx; expect_end_tag ctx;
xml qname attrs content xml qname attrs content
let check_fixed ~ctx fixed value = let check_fixed fixed value =
if not (Value.equal fixed value) then if not (Value.equal fixed value) then
error ~ctx (sprintf "Expected fixed value: %s; found %s" error (sprintf "Expected fixed value: %s; found %s"
(string_of_value fixed) (string_of_value value)) (string_of_value fixed) (string_of_value value))
...@@ -312,30 +332,30 @@ let next_tag ctx = ...@@ -312,30 +332,30 @@ let next_tag ctx =
| E_start_tag qname -> qname | E_start_tag qname -> qname
| _ -> raise Not_found | _ -> raise Not_found
let validate_attribute_uses ctx attr_uses = let validate_attribute_uses attrs attr_uses =
let tbl = QTable.create 11 in let tbl = QTable.create 11 in
List.iter List.iter
(fun use -> QTable.add tbl (name_of_attribute_use use) use) (fun use -> QTable.add tbl (name_of_attribute_use use) use)
attr_uses; attr_uses;
let attrs = let attribs = ref [] in
List.map List.iter
(fun (qname, value) -> (fun (qname, value) ->
let { attr_decl = { attr_typdef = st_def }; let { attr_decl = { attr_typdef = st_def };
attr_use_cstr = constr } = attr_use_cstr = constr } =
try QTable.find tbl qname try QTable.find tbl qname
with Not_found -> with Not_found ->
error (sprintf "Unexpected attribute: %s" error (sprintf "Unexpected attribute: %s"
(Ns.QName.to_string qname)) (Ns.QName.to_string qname))
in in
let value = validate_simple_type st_def value in let value = validate_simple_type st_def value in
(match constr with (* check fixed constraint *) (match constr with (* check fixed constraint *)
| Some (`Fixed v) -> check_fixed ~ctx v value | Some (`Fixed v) -> check_fixed v value
| _ -> ()); | _ -> ());
QTable.remove tbl qname; QTable.remove tbl qname;
(qname, value) attribs := (qname, value) :: !attribs
) (get_attributes ctx); ) attrs.attrs;
in if attrs.xsi_nil then
let attrs = ref attrs in attribs := (xsi_nil_qname, Value.vtrue) :: !attribs;
QTable.iter QTable.iter
(fun qname at -> (fun qname at ->
if at.attr_required then (* check for missing required attributes *) if at.attr_required then (* check for missing required attributes *)
...@@ -343,36 +363,45 @@ let validate_attribute_uses ctx attr_uses = ...@@ -343,36 +363,45 @@ let validate_attribute_uses ctx attr_uses =
(Ns.QName.to_string qname)) (Ns.QName.to_string qname))
else (* add default values *) else (* add default values *)
match at.attr_use_cstr with match at.attr_use_cstr with
| Some (`Default v) -> attrs := (qname, v) :: !attrs | Some (`Default v) -> attribs := (qname, v) :: !attribs
| _ -> ()) | _ -> ())
tbl; tbl;
Value.vrecord !attrs Value.vrecord !attribs
let rec validate_element ctx elt = let rec validate_element ctx elt =
expect_start_tag ctx elt.elt_name; expect_start_tag ctx elt.elt_name;
let (attrs, content) = validate_type_ref ctx elt.elt_typdef in let attrs = get_attributes ctx in
if (attrs.xsi_nil && not elt.elt_nillable) then
error "xsi:nil attribute on non-nillable element";
let (attrs, content) = validate_type_ref ctx attrs elt.elt_typdef in
let content = (* use default if needed and check fixed constraints *) let content = (* use default if needed and check fixed constraints *)
match elt.elt_cstr with match elt.elt_cstr with
| Some (`Default v) when Value.equal content empty_string -> v | Some (`Default v) when Value.equal content empty_string -> v
| Some (`Fixed v) -> | Some (`Fixed v) -> check_fixed v content; content
check_fixed ~ctx v content;
content
| _ -> content | _ -> content
in in
expect_end_tag ctx; expect_end_tag ctx;
xml elt.elt_name attrs content xml elt.elt_name attrs content
and validate_type ctx = function and validate_type ctx attrs = function
| AnyType -> validate_any_type ctx | AnyType -> validate_any_type ctx
| Simple st_def -> (empty_record, validate_simple_type_wrapper ctx st_def) | Simple st_def ->
| Complex ct_def -> validate_complex_type ctx ct_def if (List.length attrs.attrs > 0) then
error "attribute on element with simple content";
and validate_type_ref ctx x = if attrs.xsi_nil then (check_nil ctx;
validate_type ctx (Lazy.force x) Value.vrecord [xsi_nil_qname,Value.vtrue],
Value.nil)
and validate_complex_type ctx ct = else (empty_record, validate_simple_type_wrapper ctx st_def)
let attrs = validate_attribute_uses ctx ct.ct_attrs in | Complex ct_def -> validate_complex_type ctx attrs ct_def
let content = validate_content_type ctx ct.ct_content in
and validate_type_ref ctx attrs x =
validate_type ctx attrs (Lazy.force x)
and validate_complex_type ctx attrs ct =
let content =
if attrs.xsi_nil then (check_nil ctx; Value.nil)
else validate_content_type ctx ct.ct_content in
let attrs = validate_attribute_uses attrs ct.ct_attrs in
(attrs, content) (attrs, content)
and validate_content_type ctx content_type = and validate_content_type ctx content_type =
...@@ -515,7 +544,8 @@ let validate_type def schema value = ...@@ -515,7 +544,8 @@ let validate_type def schema value =
| Complex ct_def -> | Complex ct_def ->
let ctx = ctx (stream_of_value value) schema in let ctx = ctx (stream_of_value value) schema in
let start_tag = expect_any_start_tag ctx in let start_tag = expect_any_start_tag ctx in
let (attrs, content) = validate_complex_type ctx ct_def in let attrs = get_attributes ctx in
let (attrs, content) = validate_complex_type ctx attrs ct_def in
expect_end_tag ctx; expect_end_tag ctx;
Value.Xml (Value.Atom (Atoms.V.of_qname start_tag), attrs, content) Value.Xml (Value.Atom (Atoms.V.of_qname start_tag), attrs, content)
...@@ -568,7 +598,9 @@ let validate_attribute_group { ag_def = attr_uses } schema value = ...@@ -568,7 +598,9 @@ let validate_attribute_group { ag_def = attr_uses } schema value =
error error
"Only record values could be validated against attribute groups" "Only record values could be validated against attribute groups"
in in
validate_attribute_uses (ctx stream schema) attr_uses let ctx = ctx stream schema in
let attrs = get_attributes ctx in
validate_attribute_uses attrs attr_uses
let validate_model_group { mg_def = mg } schema value = let validate_model_group { mg_def = mg } schema value =
......
...@@ -138,3 +138,4 @@ let _qname_attr name n = ...@@ -138,3 +138,4 @@ let _qname_attr name n =
let xsd = Ns.mk xsd_namespace let xsd = Ns.mk xsd_namespace
let xsi = Ns.mk xsi_namespace
...@@ -32,3 +32,4 @@ val _may_qname_attr: string -> node -> Ns.qname option ...@@ -32,3 +32,4 @@ val _may_qname_attr: string -> node -> Ns.qname option
val _qname_attr: string -> node -> Ns.qname val _qname_attr: string -> node -> Ns.qname
val xsd: Ns.t val xsd: Ns.t
val xsi: Ns.t
<person>
<name>John</name>
<height xmlns:xsi= "http://www.w3.org/2001/XMLSchema-instance"
xsi:nil="true" />
</person>
<xs:schema xmlns:xs= "http://www.w3.org/2001/XMLSchema">
<xs:element name="person" type="Person" nillable="true" />
<xs:complexType name="Person">
<xs:sequence>
<xs:element name= "name" type="xs:string"/>
<xs:element name= "height" type="xs:integer" nillable="true" />
</xs:sequence>
</xs:complexType>
</xs:schema>
...@@ -1563,7 +1563,7 @@ struct ...@@ -1563,7 +1563,7 @@ struct
Format.fprintf ppf "<%a%a>%a" Format.fprintf ppf "<%a%a>%a"
do_print_tag tag do_print_tag tag
do_print_attr attr do_print_attr attr
(do_print_slot 0) t (do_print_slot 2) t
| Record (r,some,none) -> | Record (r,some,none) ->