Commit b5a60dcc authored by Pietro Abate's avatar Pietro Abate

[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
| C (CBuilt_in _) -> assert false
| 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 =
debug_print "Schema_parser.parse_facet";
let validate_base_type =
......@@ -168,7 +183,7 @@ let parse_att_decl (resolver: resolver) n =
name, simple_type_def, constr
| _ -> 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 *)
let parse_attribute_use (resolver: resolver) n =
debug_print "Schema_parser.parse_attribute_use";
......@@ -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
type definition *)
let attribute_uses_of_restriction ~(resolver: resolver) ~n ~base =
(* BUG HERE *)
let embedded = (* associative list <name, attribute_use option> *)
List.map
(fun n ->
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
in
(* /BUG HERE *)
let from_base =
match base with
| C (CUser_defined (_, _, _, _, attribute_uses, _)) ->
......@@ -314,8 +337,11 @@ let rec parse_complex_type (resolver: resolver) n =
(try restriction#extension#mixed with Not_found -> false))
in
(try
CT_model
(parse_particle resolver restriction#extension#find_term, mixed)
let particle =
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"))
end
in
......@@ -343,12 +369,17 @@ let rec parse_complex_type (resolver: resolver) n =
) in
match base_ct with
| 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
((1, Some 1,
Sequence (p :: [parse_particle resolver (Lazy.force term)])),
mixed)
let base_particle = parse_particle resolver (Lazy.force term) in
(match base_particle with
| _, _, All _ ->
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
in
cuser_defined name !base Extension attribute_uses content_type
......@@ -368,7 +399,9 @@ let rec parse_complex_type (resolver: resolver) n =
CT_empty
end else begin
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
in
cuser_defined name !base Restriction attribute_uses content_type
......@@ -415,15 +448,25 @@ and parse_particle (resolver: resolver) n =
minOccurs, maxOccurs, (Elt elt_decl)
| T_element "xsd:all" ->
minOccurs, maxOccurs,
All (List.map (parse_particle resolver) n#extension#find_terms)
All (parse_particles resolver n#extension#find_terms)
| T_element "xsd:sequence" ->
minOccurs, maxOccurs,
Sequence (List.map (parse_particle resolver) n#extension#find_terms)
Sequence (parse_particles resolver n#extension#find_terms)
| T_element "xsd:choice" ->
minOccurs, maxOccurs,
Choice (List.map (parse_particle resolver) n#extension#find_terms)
Choice (parse_particles resolver n#extension#find_terms)
| _ -> 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 =
struct
......
......@@ -15,12 +15,24 @@ module OrderedStringOption =
(* used to encode content model's "first". None value encode "epsilon" *)
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
let fake_ct_validator: (((string * string) list -> Value.t) * validator) =
((fun _ -> assert false), ((fun _ -> assert false), First.empty))
let validate ~validator:(validate_fun, _) = validate_fun
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 *)
let pcdata_wrapper f = (fun stream -> f (Schema_xml.collect_pcdata stream))
......@@ -160,10 +172,7 @@ let string_of_first ?(show_epsilon = false) first =
String.concat ", " elts
let rec validator_of_particle (min, max, (term: term)) =
assert (not ((min = 0) && (max = Some 0))); (* TODO empty CM *)
assert (min >= 0);
assert (match max with Some n -> (n >= 0) | _ -> true);
assert (max >>= min);
assert ((min >= 0) && (max >>= min));
let validator = validator_of_term term in
let term_first = snd validator in
let first =
......@@ -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
in
match (min, max) with
| (0, Some 0) -> empty_validator
| (min, Some max) ->
(fun stream ->
let content = ref [] in
......@@ -206,10 +216,61 @@ let rec validator_of_particle (min, max, (term: term)) =
Value.sequence (List.rev !content)),
first
and validator_of_term = function
| All [] | Choice [] | Sequence [] -> assert false (* TODO empty CM *)
| All _ -> assert false (* TODO xsd:all *)
| Choice particles -> (* TODO UPA *)
and validator_of_term =
let error first found =
raise (XSI_validation_error (sprintf "Expected one of: %s; found %s"
(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 find_validator name = (* find the validation function for a given
element *)
......@@ -225,16 +286,15 @@ and validator_of_term = function
p_validators
in
(fun stream ->
let error found =
raise (XSI_validation_error (sprintf "Expected one of: %s; \
found %s" (string_of_first first) found))
in
let next =
try
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
let validator = try find_validator next with Not_found -> error next in
validate ~validator stream),
first
| Sequence particles ->
......
......@@ -1030,14 +1030,12 @@ module Schema_converter =
let complex_memo = Hashtbl.create 213
let rec regexp_of_term = function
| All _ -> assert false
| Choice [] -> PEpsilon
| All [] | Choice [] | Sequence [] -> PEpsilon
| Choice (hd :: tl) ->
List.fold_left
(fun acc particle -> PAlt (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl
| Sequence [] -> PEpsilon
| Sequence (hd :: tl) ->
| All (hd :: tl) | Sequence (hd :: tl) ->
List.fold_left
(fun acc particle -> PSeq (acc, regexp_of_particle particle))
(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