Commit 6773b2fd authored by Pietro Abate's avatar Pietro Abate

[r2005-02-25 00:59:40 by afrisch] Schema element wildcards

Original author: afrisch
Date: 2005-02-25 00:59:41+00:00
parent 9f9b54bf
......@@ -147,14 +147,21 @@ let anyType = AnyType
let first_of_particle p = p.part_first
let nullable p = p.part_nullable
let first_of_wildcard_constraint = function
| WAny -> Atoms.any
| WNot ns -> Atoms.diff Atoms.any (Atoms.any_in_ns ns)
| WOne l ->
List.fold_left (fun acc ns -> Atoms.cup acc (Atoms.any_in_ns ns))
Atoms.empty l
let first_of_model_group = function
| All particles | Choice particles ->
List.concat (List.map first_of_particle particles)
List.fold_left (fun acc p -> Atoms.cup acc (first_of_particle p))
Atoms.empty particles
| Sequence particles ->
let rec aux = function
| hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
| hd :: tl -> first_of_particle hd
| [] -> []
| hd::tl when nullable hd -> Atoms.cup (first_of_particle hd) (aux tl)
| hd::tl -> first_of_particle hd
| [] -> Atoms.empty
in
aux particles
......@@ -394,6 +401,7 @@ and print_particle ppf p =
and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" e.elt_uid
| Model m -> print_model_group ppf m
| Wildcard _ -> Format.fprintf ppf "Wildcard"
......
......@@ -62,9 +62,11 @@ val iter_attribute_groups:
schema -> (attribute_group_definition -> unit) -> unit
val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
val first_of_particle: particle -> Ns.qname list
val first_of_wildcard_constraint: wildcard_constraint -> Atoms.t
val first_of_particle: particle -> Atoms.t
val first_of_model_group: model_group -> Atoms.t
val nullable: particle -> bool
val first_of_model_group: model_group -> Ns.qname list
val nullable_of_model_group: model_group -> bool
(** {2 Facets} *)
......
......@@ -53,7 +53,7 @@ let element, complex =
let space_RE = pcre_regexp " "
let split s = pcre_split ~rex:space_RE s
let unqualify s = snd (Ns.split_qname s)
(*let unqualify s = snd (Ns.split_qname s)*)
let hashtbl_deref tbl =
QTable.fold (fun _ v acc -> (check_force v) :: acc) tbl []
......@@ -144,7 +144,8 @@ let rec first n f = function
| x::l -> match f x n with None -> first n f l | x -> x
let find_particles n =
_filter_elems ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence"] n
_filter_elems ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence";
"xsd:any" ] n
let find_particle n =
first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"]
......@@ -493,7 +494,8 @@ let schema_of_uri uri =
and parse_particle n =
let min, max = parse_min_max n in
let model mg = particle_model min max mg in
let elt e n = particle min max (Elt e) [ n ] (min = 0) in
let elt e n = particle min max (Elt e) (Atoms.atom (Atoms.V.of_qname n ))
(min = 0) in
match _tag n with
| "xsd:element" ->
(match _may_qname_attr "ref" n with
......@@ -504,8 +506,35 @@ let schema_of_uri uri =
| "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
| "xsd:all" | "xsd:sequence" | "xsd:choice" ->
model (parse_model_group n)
| "xsd:any" ->
let w = parse_wildcard n in
particle min max (Wildcard w) w.wild_first (min = 0)
| _ -> assert false
and parse_wildcard n =
let c = parse_wildcard_cstr n in
{ wild_cstr = c;
wild_process = parse_wildcard_process n;
wild_first = first_of_wildcard_constraint c }
and parse_wildcard_process n = match _may_attr "processContents" n with
| Some t when Utf8.get_str t = "lax" -> `Lax
| Some t when Utf8.get_str t = "skip" -> `Skip
| Some t when Utf8.get_str t = "strict" -> `Strict
| None -> `Strict
| _ -> failwith "Wildcard processContents attribute not recognized"
and parse_wildcard_cstr n = match _may_attr "namespace" n with
| None -> WAny
| Some ns when Utf8.get_str ns = "##any" -> WAny
| Some ns when Utf8.get_str ns = "##other" -> WNot targetNamespace
| Some ns -> WOne (List.map parse_wildcard_ns (split ns))
and parse_wildcard_ns = function
| ns when Utf8.get_str ns = "##targetNamespace" -> targetNamespace
| ns when Utf8.get_str ns = "##local" -> Ns.empty
| ns -> Ns.mk ns
and parse_model_group n =
match _tag n with
| "xsd:all" ->
......
......@@ -66,6 +66,7 @@ and attribute_use =
and term =
| Elt of element_declaration
| Model of model_group
| Wildcard of wildcard
and model_group =
| All of particle list
......@@ -81,7 +82,7 @@ and particle =
{ part_min: int;
part_max: int option; (* None = unbounded *)
part_term: term;
part_first: Ns.qname list;
part_first: Atoms.t;
part_nullable: bool }
and element_declaration =
......@@ -103,6 +104,17 @@ and type_definition =
| Simple of simple_type_definition
| Complex of complex_type_definition
and wildcard_constraint =
| WAny
| WNot of Ns.t
| WOne of Ns.t list
and wildcard = {
wild_cstr: wildcard_constraint;
wild_process: [`Lax | `Skip | `Strict];
wild_first: Atoms.t;
}
type model_group_definition =
{ mg_name : Ns.qname;
mg_def : model_group }
......
......@@ -66,6 +66,7 @@ and attribute_use =
and term =
| Elt of element_declaration
| Model of model_group
| Wildcard of wildcard
and model_group =
| All of particle list
......@@ -81,7 +82,7 @@ and particle =
{ part_min: int;
part_max: int option; (* None = unbounded *)
part_term: term;
part_first: Ns.qname list;
part_first: Atoms.t;
part_nullable: bool }
and element_declaration =
......@@ -103,6 +104,17 @@ and type_definition =
| Simple of simple_type_definition
| Complex of complex_type_definition
and wildcard_constraint =
| WAny
| WNot of Ns.t
| WOne of Ns.t list
and wildcard = {
wild_cstr: wildcard_constraint;
wild_process: [`Lax | `Skip | `Strict];
wild_first: Atoms.t;
}
type model_group_definition =
{ mg_name : Ns.qname;
mg_def : model_group }
......
......@@ -120,6 +120,7 @@ let expect_start_tag ctx tag =
| ev -> error (sprintf "Expected tag %s, found %s"
(Ns.QName.to_string tag) (string_of_event ev))
let expect_any_start_tag ctx =
match next ctx with
| E_start_tag t -> t
......@@ -290,6 +291,15 @@ let rec validate_any_type ctx =
aux ();
(Value.vrecord attrs, get ctx)
let validate_wildcard ctx w =
let qname = expect_any_start_tag ctx in
if Atoms.contains (Atoms.V.of_qname qname) w.wild_first
then error (sprintf "Tag %s is not accepted by the wildcard"
(Ns.QName.to_string qname));
let (attrs, content) = validate_any_type ctx in
expect_end_tag ctx;
xml qname attrs content
let check_fixed ~ctx fixed value =
if not (Value.equal fixed value) then
error ~ctx (sprintf "Expected fixed value: %s; found %s"
......@@ -389,7 +399,7 @@ and validate_particle ctx particle =
do_pcdata ctx;
match peek ctx with
| E_start_tag qname
when List.exists (Ns.QName.equal qname) particle.part_first ->
when Atoms.contains (Atoms.V.of_qname qname) particle.part_first ->
validate_term ctx particle.part_term;
cont_ok ()
| ev ->
......@@ -426,21 +436,19 @@ and validate_particle ctx particle =
and validate_term ctx term =
match term with
| Elt elt_decl_ref -> append ctx (validate_element ctx elt_decl_ref)
| Model model_group -> validate_model_group ctx model_group
| Elt elt -> append ctx (validate_element ctx elt)
| Model mg -> validate_model_group ctx mg
| Wildcard w -> append ctx (validate_wildcard ctx w)
and validate_choice ctx particles =
(* TODO: Handle case when one of the choices is nullable *)
let tbl = QTable.create 20 in
List.iter
(fun p ->
List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
particles;
let tbl = Atoms.mk_map
(List.map (fun p -> first_of_particle p, p) particles) in
do_pcdata ctx;
try
(match peek ctx with
| E_start_tag qname ->
let particle = QTable.find tbl qname in
let particle = Atoms.get_map (Atoms.V.of_qname qname) tbl in
validate_particle ctx particle
| _ -> raise Not_found)
with Not_found ->
......@@ -448,21 +456,16 @@ and validate_choice ctx particles =
and validate_all_group ctx particles =
let tbl = QTable.create 20 in
let slots =
List.map
(fun p ->
let slot = ref None in
let first = first_of_particle p in
List.iter (fun tag -> QTable.add tbl tag (p,slot)) first;
(nullable p, slot)
) particles in
let slots = List.map (fun p -> (p, ref None)) particles in
let tbl = Atoms.mk_map
(List.map (fun (p,slot) -> first_of_particle p, (p,slot)) slots) in
let contents = ref Value.nil in
let rec aux () =
match peek ctx with
| E_start_tag qname ->
let qname = next_tag ctx in
let p,slot = QTable.find tbl qname in
let p,slot = Atoms.get_map (Atoms.V.of_qname qname) tbl in
(match !slot with
| Some x -> ()
| None ->
......@@ -474,10 +477,10 @@ and validate_all_group ctx particles =
do_pcdata ctx;
aux ();
List.iter
(fun (nullable,slot) ->
(fun (p,slot) ->
match !slot with
| Some x -> concat ctx x
| None when nullable -> ()
| None when nullable p -> ()
| None -> error "One particle of the all group is missing"
) slots
......
......@@ -71,16 +71,18 @@ let float_abs =
let float =
Types.abstract (Types.Abstract.atom float_abs)
let any_xml =
let any_attr_node = Types.cons (Types.record' (true,LabelMap.empty))
let any_xml,any_xml_seq,any_xml_content =
let elt = Types.make () in
let seq = Types.make () in
let elt_d = Types.xml
(Types.cons atom)
(Types.cons (Types.times
(Types.cons (Types.record' (true,LabelMap.empty)))
seq)) in
let any_xml_content = Types.cons (Types.times any_attr_node seq) in
let elt_d = Types.xml (Types.cons atom) any_xml_content in
let elt_char_d = Types.cup elt_d char in
let seq_d = Types.cup nil (Types.times (Types.cons elt_char_d) seq) in
Types.define elt elt_d;
Types.define seq seq_d;
elt_d
elt_d,seq_d,any_xml_content
let any_xml_with_tag t =
Types.xml (Types.cons (Types.atom t)) any_xml_content
......@@ -43,3 +43,5 @@ val float: Types.t
val float_abs: Types.Abstract.abs
val any_xml : Types.t
val any_xml_with_tag: Atoms.t -> Types.t
......@@ -1636,6 +1636,10 @@ module Schema_converter =
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> PElem (elt_decl decl)
| Wildcard w -> PElem (wildcard w)
and wildcard w =
itype (Builtin_defs.any_xml_with_tag w.wild_first)
and regexp_of_model_group = function
| Choice l ->
......
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