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

[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 ...@@ -147,14 +147,21 @@ let anyType = AnyType
let first_of_particle p = p.part_first let first_of_particle p = p.part_first
let nullable p = p.part_nullable 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 let first_of_model_group = function
| All particles | Choice particles -> | 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 -> | Sequence particles ->
let rec aux = function let rec aux = function
| hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl) | hd::tl when nullable hd -> Atoms.cup (first_of_particle hd) (aux tl)
| hd :: tl -> first_of_particle hd | hd::tl -> first_of_particle hd
| [] -> [] | [] -> Atoms.empty
in in
aux particles aux particles
...@@ -394,6 +401,7 @@ and print_particle ppf p = ...@@ -394,6 +401,7 @@ and print_particle ppf p =
and print_term ppf = function and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" e.elt_uid | Elt e -> Format.fprintf ppf "E%i" e.elt_uid
| Model m -> print_model_group ppf m | Model m -> print_model_group ppf m
| Wildcard _ -> Format.fprintf ppf "Wildcard"
......
...@@ -62,9 +62,11 @@ val iter_attribute_groups: ...@@ -62,9 +62,11 @@ val iter_attribute_groups:
schema -> (attribute_group_definition -> unit) -> unit schema -> (attribute_group_definition -> unit) -> unit
val iter_model_groups: schema -> (model_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 nullable: particle -> bool
val first_of_model_group: model_group -> Ns.qname list
val nullable_of_model_group: model_group -> bool val nullable_of_model_group: model_group -> bool
(** {2 Facets} *) (** {2 Facets} *)
......
...@@ -53,7 +53,7 @@ let element, complex = ...@@ -53,7 +53,7 @@ let element, complex =
let space_RE = pcre_regexp " " let space_RE = pcre_regexp " "
let split s = pcre_split ~rex:space_RE s 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 = let hashtbl_deref tbl =
QTable.fold (fun _ v acc -> (check_force v) :: acc) tbl [] QTable.fold (fun _ v acc -> (check_force v) :: acc) tbl []
...@@ -144,7 +144,8 @@ let rec first n f = function ...@@ -144,7 +144,8 @@ let rec first n f = function
| x::l -> match f x n with None -> first n f l | x -> x | x::l -> match f x n with None -> first n f l | x -> x
let find_particles n = 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 = let find_particle n =
first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"] first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"]
...@@ -493,7 +494,8 @@ let schema_of_uri uri = ...@@ -493,7 +494,8 @@ let schema_of_uri uri =
and parse_particle n = and parse_particle n =
let min, max = parse_min_max n in let min, max = parse_min_max n in
let model mg = particle_model min max mg 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 match _tag n with
| "xsd:element" -> | "xsd:element" ->
(match _may_qname_attr "ref" n with (match _may_qname_attr "ref" n with
...@@ -504,8 +506,35 @@ let schema_of_uri uri = ...@@ -504,8 +506,35 @@ let schema_of_uri uri =
| "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def | "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
| "xsd:all" | "xsd:sequence" | "xsd:choice" -> | "xsd:all" | "xsd:sequence" | "xsd:choice" ->
model (parse_model_group n) 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 | _ -> 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 = and parse_model_group n =
match _tag n with match _tag n with
| "xsd:all" -> | "xsd:all" ->
......
...@@ -66,6 +66,7 @@ and attribute_use = ...@@ -66,6 +66,7 @@ and attribute_use =
and term = and term =
| Elt of element_declaration | Elt of element_declaration
| Model of model_group | Model of model_group
| Wildcard of wildcard
and model_group = and model_group =
| All of particle list | All of particle list
...@@ -81,7 +82,7 @@ and particle = ...@@ -81,7 +82,7 @@ and particle =
{ part_min: int; { part_min: int;
part_max: int option; (* None = unbounded *) part_max: int option; (* None = unbounded *)
part_term: term; part_term: term;
part_first: Ns.qname list; part_first: Atoms.t;
part_nullable: bool } part_nullable: bool }
and element_declaration = and element_declaration =
...@@ -103,6 +104,17 @@ and type_definition = ...@@ -103,6 +104,17 @@ and type_definition =
| Simple of simple_type_definition | Simple of simple_type_definition
| Complex of complex_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 = type model_group_definition =
{ mg_name : Ns.qname; { mg_name : Ns.qname;
mg_def : model_group } mg_def : model_group }
......
...@@ -66,6 +66,7 @@ and attribute_use = ...@@ -66,6 +66,7 @@ and attribute_use =
and term = and term =
| Elt of element_declaration | Elt of element_declaration
| Model of model_group | Model of model_group
| Wildcard of wildcard
and model_group = and model_group =
| All of particle list | All of particle list
...@@ -81,7 +82,7 @@ and particle = ...@@ -81,7 +82,7 @@ and particle =
{ part_min: int; { part_min: int;
part_max: int option; (* None = unbounded *) part_max: int option; (* None = unbounded *)
part_term: term; part_term: term;
part_first: Ns.qname list; part_first: Atoms.t;
part_nullable: bool } part_nullable: bool }
and element_declaration = and element_declaration =
...@@ -103,6 +104,17 @@ and type_definition = ...@@ -103,6 +104,17 @@ and type_definition =
| Simple of simple_type_definition | Simple of simple_type_definition
| Complex of complex_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 = type model_group_definition =
{ mg_name : Ns.qname; { mg_name : Ns.qname;
mg_def : model_group } mg_def : model_group }
......
...@@ -120,6 +120,7 @@ let expect_start_tag ctx tag = ...@@ -120,6 +120,7 @@ let expect_start_tag ctx tag =
| ev -> error (sprintf "Expected tag %s, found %s" | ev -> error (sprintf "Expected tag %s, found %s"
(Ns.QName.to_string tag) (string_of_event ev)) (Ns.QName.to_string tag) (string_of_event ev))
let expect_any_start_tag ctx = let expect_any_start_tag ctx =
match next ctx with match next ctx with
| E_start_tag t -> t | E_start_tag t -> t
...@@ -290,6 +291,15 @@ let rec validate_any_type ctx = ...@@ -290,6 +291,15 @@ let rec validate_any_type ctx =
aux (); aux ();
(Value.vrecord attrs, get ctx) (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 = let check_fixed ~ctx 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 ~ctx (sprintf "Expected fixed value: %s; found %s"
...@@ -389,7 +399,7 @@ and validate_particle ctx particle = ...@@ -389,7 +399,7 @@ and validate_particle ctx particle =
do_pcdata ctx; do_pcdata ctx;
match peek ctx with match peek ctx with
| E_start_tag qname | 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; validate_term ctx particle.part_term;
cont_ok () cont_ok ()
| ev -> | ev ->
...@@ -426,21 +436,19 @@ and validate_particle ctx particle = ...@@ -426,21 +436,19 @@ and validate_particle ctx particle =
and validate_term ctx term = and validate_term ctx term =
match term with match term with
| Elt elt_decl_ref -> append ctx (validate_element ctx elt_decl_ref) | Elt elt -> append ctx (validate_element ctx elt)
| Model model_group -> validate_model_group ctx model_group | Model mg -> validate_model_group ctx mg
| Wildcard w -> append ctx (validate_wildcard ctx w)
and validate_choice ctx particles = and validate_choice ctx particles =
(* TODO: Handle case when one of the choices is nullable *) (* TODO: Handle case when one of the choices is nullable *)
let tbl = QTable.create 20 in let tbl = Atoms.mk_map
List.iter (List.map (fun p -> first_of_particle p, p) particles) in
(fun p ->
List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
particles;
do_pcdata ctx; do_pcdata ctx;
try try
(match peek ctx with (match peek ctx with
| E_start_tag qname -> | 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 validate_particle ctx particle
| _ -> raise Not_found) | _ -> raise Not_found)
with Not_found -> with Not_found ->
...@@ -448,21 +456,16 @@ and validate_choice ctx particles = ...@@ -448,21 +456,16 @@ and validate_choice ctx particles =
and validate_all_group ctx particles = and validate_all_group ctx particles =
let tbl = QTable.create 20 in let tbl = QTable.create 20 in
let slots = let slots = List.map (fun p -> (p, ref None)) particles in
List.map let tbl = Atoms.mk_map
(fun p -> (List.map (fun (p,slot) -> first_of_particle p, (p,slot)) slots) in
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 contents = ref Value.nil in let contents = ref Value.nil in
let rec aux () = let rec aux () =
match peek ctx with match peek ctx with
| E_start_tag qname -> | E_start_tag qname ->
let qname = next_tag ctx in 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 (match !slot with
| Some x -> () | Some x -> ()
| None -> | None ->
...@@ -474,10 +477,10 @@ and validate_all_group ctx particles = ...@@ -474,10 +477,10 @@ and validate_all_group ctx particles =
do_pcdata ctx; do_pcdata ctx;
aux (); aux ();
List.iter List.iter
(fun (nullable,slot) -> (fun (p,slot) ->
match !slot with match !slot with
| Some x -> concat ctx x | Some x -> concat ctx x
| None when nullable -> () | None when nullable p -> ()
| None -> error "One particle of the all group is missing" | None -> error "One particle of the all group is missing"
) slots ) slots
......
...@@ -71,16 +71,18 @@ let float_abs = ...@@ -71,16 +71,18 @@ let float_abs =
let float = let float =
Types.abstract (Types.Abstract.atom float_abs) 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 elt = Types.make () in
let seq = Types.make () in let seq = Types.make () in
let elt_d = Types.xml let any_xml_content = Types.cons (Types.times any_attr_node seq) in
(Types.cons atom) let elt_d = Types.xml (Types.cons atom) any_xml_content in
(Types.cons (Types.times
(Types.cons (Types.record' (true,LabelMap.empty)))
seq)) in
let elt_char_d = Types.cup elt_d char 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 let seq_d = Types.cup nil (Types.times (Types.cons elt_char_d) seq) in
Types.define elt elt_d; Types.define elt elt_d;
Types.define seq seq_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 ...@@ -43,3 +43,5 @@ val float: Types.t
val float_abs: Types.Abstract.abs val float_abs: Types.Abstract.abs
val any_xml : Types.t val any_xml : Types.t
val any_xml_with_tag: Atoms.t -> Types.t
...@@ -1636,6 +1636,10 @@ module Schema_converter = ...@@ -1636,6 +1636,10 @@ module Schema_converter =
let rec regexp_of_term = function let rec regexp_of_term = function
| Model group -> regexp_of_model_group group | Model group -> regexp_of_model_group group
| Elt decl -> PElem (elt_decl decl) | 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 and regexp_of_model_group = function
| Choice l -> | 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