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

[r2003-06-15 21:46:12 by cvscast] - added support for xsd:all term

- bugfix: empty content model now supported

- bugfix: reference to global attributes works zack

Original author: cvscast
Date: 2003-06-15 21:46:12+00:00
parent 70ffb472
...@@ -44,6 +44,21 @@ let content_type_of_def = function ...@@ -44,6 +44,21 @@ let content_type_of_def = function
| C (CBuilt_in _) -> assert false | C (CBuilt_in _) -> assert false
| C (CUser_defined (_, _, _, _, _, ct)) -> ct | C (CUser_defined (_, _, _, _, _, ct)) -> ct
(* check xsd:all constraints *)
let check_all_particle = function
| 1, Some 1, All particles ->
List.iter
(function
| _, Some 0, _ | _, Some 1, _ -> ()
| _, _, _ ->
raise (XSD_validation_error "all particles contained in a xsd:all
term must have maxOccurs = {0, 1}"))
particles
| _, _, All _ ->
raise (XSD_validation_error "xsd:all particles must have \
minOccurs = maxOccurs = 1")
| _, _, _ -> ()
let parse_facet (resolver: resolver) base_type_def n = let parse_facet (resolver: resolver) base_type_def n =
debug_print "Schema_parser.parse_facet"; debug_print "Schema_parser.parse_facet";
let validate_base_type = let validate_base_type =
...@@ -168,7 +183,7 @@ let parse_att_decl (resolver: resolver) n = ...@@ -168,7 +183,7 @@ let parse_att_decl (resolver: resolver) n =
name, simple_type_def, constr name, simple_type_def, constr
| _ -> assert false (* you have to use parse_attribute_use *) | _ -> assert false (* you have to use parse_attribute_use *)
(** @return an attribute_use option. None means that the attribute is (** @return a attribute_use option. None means that the attribute is
prohibited *) prohibited *)
let parse_attribute_use (resolver: resolver) n = let parse_attribute_use (resolver: resolver) n =
debug_print "Schema_parser.parse_attribute_use"; debug_print "Schema_parser.parse_attribute_use";
...@@ -212,13 +227,21 @@ let parse_attribute_use (resolver: resolver) n = ...@@ -212,13 +227,21 @@ let parse_attribute_use (resolver: resolver) n =
(** @return a list of attribute uses from a xsd:restriction node wrt a base (** @return a list of attribute uses from a xsd:restriction node wrt a base
type definition *) type definition *)
let attribute_uses_of_restriction ~(resolver: resolver) ~n ~base = let attribute_uses_of_restriction ~(resolver: resolver) ~n ~base =
(* BUG HERE *)
let embedded = (* associative list <name, attribute_use option> *) let embedded = (* associative list <name, attribute_use option> *)
List.map List.map
(fun n -> (fun n ->
let use = parse_attribute_use resolver n in let use = parse_attribute_use resolver n in
n#extension#name, use) let name =
if n#extension#has_attribute "ref" then
n#extension#ref
else (* if n#extension#has_attribute "name" then *)
n#extension#name
in
name, use)
n#extension#find_attributes n#extension#find_attributes
in in
(* /BUG HERE *)
let from_base = let from_base =
match base with match base with
| C (CUser_defined (_, _, _, _, attribute_uses, _)) -> | C (CUser_defined (_, _, _, _, attribute_uses, _)) ->
...@@ -314,8 +337,11 @@ let rec parse_complex_type (resolver: resolver) n = ...@@ -314,8 +337,11 @@ let rec parse_complex_type (resolver: resolver) n =
(try restriction#extension#mixed with Not_found -> false)) (try restriction#extension#mixed with Not_found -> false))
in in
(try (try
CT_model let particle =
(parse_particle resolver restriction#extension#find_term, mixed) parse_particle resolver restriction#extension#find_term
in
check_all_particle particle;
CT_model (particle, mixed)
with Not_found -> raise (XSD_validation_error "Can't find term")) with Not_found -> raise (XSD_validation_error "Can't find term"))
end end
in in
...@@ -343,12 +369,17 @@ let rec parse_complex_type (resolver: resolver) n = ...@@ -343,12 +369,17 @@ let rec parse_complex_type (resolver: resolver) n =
) in ) in
match base_ct with match base_ct with
| CT_empty -> | CT_empty ->
CT_model (parse_particle resolver (Lazy.force term), mixed) let particle = parse_particle resolver (Lazy.force term) in
check_all_particle particle;
CT_model (particle, mixed)
| CT_model (p, _) -> | CT_model (p, _) ->
CT_model let base_particle = parse_particle resolver (Lazy.force term) in
((1, Some 1, (match base_particle with
Sequence (p :: [parse_particle resolver (Lazy.force term)])), | _, _, All _ ->
mixed) raise (XSD_validation_error ("Can't extend a content model, \
with an xsd:all particle"))
| _ -> ());
CT_model ((1, Some 1, Sequence (p :: [base_particle])), mixed)
| CT_simple _ -> assert false | CT_simple _ -> assert false
in in
cuser_defined name !base Extension attribute_uses content_type cuser_defined name !base Extension attribute_uses content_type
...@@ -368,7 +399,9 @@ let rec parse_complex_type (resolver: resolver) n = ...@@ -368,7 +399,9 @@ let rec parse_complex_type (resolver: resolver) n =
CT_empty CT_empty
end else begin end else begin
let mixed = false in let mixed = false in
CT_model (parse_particle resolver n#extension#find_term, mixed) let particle = parse_particle resolver n#extension#find_term in
check_all_particle particle;
CT_model (particle, mixed)
end end
in in
cuser_defined name !base Restriction attribute_uses content_type cuser_defined name !base Restriction attribute_uses content_type
...@@ -415,15 +448,25 @@ and parse_particle (resolver: resolver) n = ...@@ -415,15 +448,25 @@ and parse_particle (resolver: resolver) n =
minOccurs, maxOccurs, (Elt elt_decl) minOccurs, maxOccurs, (Elt elt_decl)
| T_element "xsd:all" -> | T_element "xsd:all" ->
minOccurs, maxOccurs, minOccurs, maxOccurs,
All (List.map (parse_particle resolver) n#extension#find_terms) All (parse_particles resolver n#extension#find_terms)
| T_element "xsd:sequence" -> | T_element "xsd:sequence" ->
minOccurs, maxOccurs, minOccurs, maxOccurs,
Sequence (List.map (parse_particle resolver) n#extension#find_terms) Sequence (parse_particles resolver n#extension#find_terms)
| T_element "xsd:choice" -> | T_element "xsd:choice" ->
minOccurs, maxOccurs, minOccurs, maxOccurs,
Choice (List.map (parse_particle resolver) n#extension#find_terms) Choice (parse_particles resolver n#extension#find_terms)
| _ -> assert false | _ -> assert false
(* as above but used for "embedded" particle lists; it additionally check that
the returned particle isn't an All one *)
and parse_particles (resolver: resolver) nodes =
List.map
(fun n ->
match parse_particle resolver n with
| _, _, All _ ->
raise (XSD_validation_error "xsd:all particle can't appear here")
| p -> p)
nodes
module OrderedNode = module OrderedNode =
struct struct
......
...@@ -15,12 +15,24 @@ module OrderedStringOption = ...@@ -15,12 +15,24 @@ module OrderedStringOption =
(* used to encode content model's "first". None value encode "epsilon" *) (* used to encode content model's "first". None value encode "epsilon" *)
module First = Set.Make (OrderedStringOption) module First = Set.Make (OrderedStringOption)
(* a pair: validation function from stream to CDuce values, a first (usual
FIRST construction on start tag names) *)
type validator = (Pxp_yacc.event Stream.t -> Value.t) * First.t type validator = (Pxp_yacc.event Stream.t -> Value.t) * First.t
let fake_ct_validator: (((string * string) list -> Value.t) * validator) = let fake_ct_validator: (((string * string) list -> Value.t) * validator) =
((fun _ -> assert false), ((fun _ -> assert false), First.empty)) ((fun _ -> assert false), ((fun _ -> assert false), First.empty))
let validate ~validator:(validate_fun, _) = validate_fun let validate ~validator:(validate_fun, _) = validate_fun
let ct_validators = Hashtbl.create 17 (* complex type validators *) let ct_validators = Hashtbl.create 17 (* complex type validators *)
module OrderedValidator =
struct
type t = bool * int * validator (* required, index, validator *)
let compare (_, _, (_, f1)) (_, _, (_, f2)) = First.compare f1 f2
end
(* used to perform xsd:all validation *)
module ValidatorSet = Set.Make (OrderedValidator)
let empty_validator = (fun _ -> Value.sequence []), First.singleton (None)
(* wrap a function validating a string with a validator *) (* wrap a function validating a string with a validator *)
let pcdata_wrapper f = (fun stream -> f (Schema_xml.collect_pcdata stream)) let pcdata_wrapper f = (fun stream -> f (Schema_xml.collect_pcdata stream))
...@@ -160,10 +172,7 @@ let string_of_first ?(show_epsilon = false) first = ...@@ -160,10 +172,7 @@ let string_of_first ?(show_epsilon = false) first =
String.concat ", " elts String.concat ", " elts
let rec validator_of_particle (min, max, (term: term)) = let rec validator_of_particle (min, max, (term: term)) =
assert (not ((min = 0) && (max = Some 0))); (* TODO empty CM *) assert ((min >= 0) && (max >>= min));
assert (min >= 0);
assert (match max with Some n -> (n >= 0) | _ -> true);
assert (max >>= min);
let validator = validator_of_term term in let validator = validator_of_term term in
let term_first = snd validator in let term_first = snd validator in
let first = let first =
...@@ -171,6 +180,7 @@ let rec validator_of_particle (min, max, (term: term)) = ...@@ -171,6 +180,7 @@ let rec validator_of_particle (min, max, (term: term)) =
if min = 0 then First.add None old_first else old_first if min = 0 then First.add None old_first else old_first
in in
match (min, max) with match (min, max) with
| (0, Some 0) -> empty_validator
| (min, Some max) -> | (min, Some max) ->
(fun stream -> (fun stream ->
let content = ref [] in let content = ref [] in
...@@ -206,10 +216,61 @@ let rec validator_of_particle (min, max, (term: term)) = ...@@ -206,10 +216,61 @@ let rec validator_of_particle (min, max, (term: term)) =
Value.sequence (List.rev !content)), Value.sequence (List.rev !content)),
first first
and validator_of_term = function and validator_of_term =
| All [] | Choice [] | Sequence [] -> assert false (* TODO empty CM *) let error first found =
| All _ -> assert false (* TODO xsd:all *) raise (XSI_validation_error (sprintf "Expected one of: %s; found %s"
| Choice particles -> (* TODO UPA *) (string_of_first first) found))
in
function
| All [] | Choice [] | Sequence [] -> empty_validator
| All particles -> (* assumption: maxOccurs = {0,1} *)
let validators =
snd (List.fold_left
(fun (idx, acc) p ->
match p with
| 0, Some 1, _ | 0, Some 0, _ ->
(idx + 1,
ValidatorSet.add (false, idx, validator_of_particle p) acc)
| 1, Some 1, _ ->
(idx + 1,
ValidatorSet.add (true, idx, validator_of_particle p) acc)
| _ -> assert false)
(0, ValidatorSet.empty) particles)
in
let len = ValidatorSet.cardinal validators in
let first =
ValidatorSet.fold (fun (_, _, (_, f)) acc -> First.union f acc)
validators First.empty
in
(fun stream ->
let values = Array.make len Value.Absent in
let validators = ref validators in
(try
while true do
let next = peek_start_tag stream in
let (_, idx, validator) as elt = (* assumption: UPA *)
ValidatorSet.choose (ValidatorSet.filter
(fun (_, _, (_, f)) -> First.mem (Some next) f) !validators)
in
validators := ValidatorSet.remove elt !validators;
values.(idx) <- validate ~validator stream
done
with
| Not_found (* raised by "choose" *) | Not_a_start_tag _ -> ());
let missing =
ValidatorSet.filter (fun (req, _, _) -> req) !validators
in
if not (ValidatorSet.is_empty missing) then
raise (XSI_validation_error ("incomplete xsd:all particle content, \
expected (at least): " ^
(string_of_first (match ValidatorSet.choose !validators with
| _, _, (_, f) -> f))));
Value.sequence (List.filter ((<>) Value.Absent)
(Array.to_list values))),
first
| Choice particles ->
(* TODO UPA *)
let p_validators = List.map validator_of_particle particles in let p_validators = List.map validator_of_particle particles in
let find_validator name = (* find the validation function for a given let find_validator name = (* find the validation function for a given
element *) element *)
...@@ -225,16 +286,15 @@ and validator_of_term = function ...@@ -225,16 +286,15 @@ and validator_of_term = function
p_validators p_validators
in in
(fun stream -> (fun stream ->
let error found =
raise (XSI_validation_error (sprintf "Expected one of: %s; \
found %s" (string_of_first first) found))
in
let next = let next =
try try
peek_start_tag stream peek_start_tag stream
with Not_a_start_tag ev -> error (Schema_xml.string_of_pxp_event ev) with Not_a_start_tag ev ->
error first (Schema_xml.string_of_pxp_event ev)
in
let validator =
try find_validator next with Not_found -> error first next
in in
let validator = try find_validator next with Not_found -> error next in
validate ~validator stream), validate ~validator stream),
first first
| Sequence particles -> | Sequence particles ->
......
...@@ -1030,14 +1030,12 @@ module Schema_converter = ...@@ -1030,14 +1030,12 @@ module Schema_converter =
let complex_memo = Hashtbl.create 213 let complex_memo = Hashtbl.create 213
let rec regexp_of_term = function let rec regexp_of_term = function
| All _ -> assert false | All [] | Choice [] | Sequence [] -> PEpsilon
| Choice [] -> PEpsilon
| Choice (hd :: tl) -> | Choice (hd :: tl) ->
List.fold_left List.fold_left
(fun acc particle -> PAlt (acc, regexp_of_particle particle)) (fun acc particle -> PAlt (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl (regexp_of_particle hd) tl
| Sequence [] -> PEpsilon | All (hd :: tl) | Sequence (hd :: tl) ->
| Sequence (hd :: tl) ->
List.fold_left List.fold_left
(fun acc particle -> PSeq (acc, regexp_of_particle particle)) (fun acc particle -> PSeq (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl (regexp_of_particle hd) tl
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment