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

[r2005-02-22 15:33:36 by afrisch] Clean

Original author: afrisch
Date: 2005-02-22 15:33:36+00:00
parent 075270bb
...@@ -103,7 +103,7 @@ let name_of_attribute_use { attr_decl = { attr_name = name } } = name ...@@ -103,7 +103,7 @@ let name_of_attribute_use { attr_decl = { attr_name = name } } = name
let name_of_attribute_group_definition ag = ag.ag_name let name_of_attribute_group_definition ag = ag.ag_name
let name_of_model_group_definition mg = mg.mg_name let name_of_model_group_definition mg = mg.mg_name
let name_of_particle = function let name_of_particle = function
| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration (Lazy.force elt_decl_ref) | { part_term = Elt e } -> name_of_element_declaration (Lazy.force e)
| _ -> assert false | _ -> assert false
let variety_of_simple_type_definition = function let variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic (lazy (Simple st)) | (Primitive name) as st -> Atomic (lazy (Simple st))
...@@ -146,8 +146,9 @@ let rec normalize_white_space = ...@@ -146,8 +146,9 @@ let rec normalize_white_space =
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType") let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
let anyType = AnyType let anyType = AnyType
let first_of_particle (_, _, _, first) = first let first_of_particle p = p.part_first
let nullable p = List.mem None (first_of_particle p) let nullable p = p.part_nullable
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.concat (List.map first_of_particle particles)
...@@ -158,10 +159,11 @@ let first_of_model_group = function ...@@ -158,10 +159,11 @@ let first_of_model_group = function
| [] -> [] | [] -> []
in in
aux particles aux particles
let rec is_in_first tag = function
| [] -> false let nullable_of_model_group = function
| Some tag' :: rest when Ns.QName.equal tag' tag -> true | All particles | Sequence particles -> List.for_all nullable particles
| _ :: rest -> is_in_first tag rest | Choice particles -> List.exists nullable particles
let get_interval facets = let get_interval facets =
(* ASSUMPTION: (* ASSUMPTION:
...@@ -430,8 +432,8 @@ and print_particle_list ppf = function ...@@ -430,8 +432,8 @@ and print_particle_list ppf = function
| [] -> () | [] -> ()
| [p] -> print_particle ppf p | [p] -> print_particle ppf p
| hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl | hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl
and print_particle ppf (min,max,term,_) = and print_particle ppf p =
print_term ppf term print_term ppf p.part_term
and print_term ppf = function and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid) | Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid)
| Model m -> print_model_group ppf m | Model m -> print_model_group ppf m
...@@ -61,10 +61,10 @@ val iter_attribute_groups: ...@@ -61,10 +61,10 @@ 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 -> first val first_of_particle: particle -> Ns.qname list
val first_of_model_group: model_group -> first
val is_in_first: Ns.qname -> first -> bool
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
(** {2 Facets} *) (** {2 Facets} *)
......
...@@ -11,6 +11,20 @@ module QTable = Hashtbl.Make(Ns.QName) ...@@ -11,6 +11,20 @@ module QTable = Hashtbl.Make(Ns.QName)
let validation_error s = raise (XSD_validation_error s) let validation_error s = raise (XSD_validation_error s)
let particle min max term first nullable =
{ part_min = min;
part_max = max;
part_term = term;
part_first = first;
part_nullable = nullable }
let particle_model min max mg =
particle min max
(Model mg)
(first_of_model_group mg)
(nullable_of_model_group mg)
let xsd = Schema_xml.xsd let xsd = Schema_xml.xsd
(* (*
...@@ -65,23 +79,23 @@ let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl [] ...@@ -65,23 +79,23 @@ let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
let parse_facets base n = let parse_facets base n =
let validate_base_type v = let validate_base_type v =
lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in
let validate_nonNegativeInteger = let parse_nonneg n =
Schema_builtin.validate_builtin (xsd, Utf8.mk "nonNegativeInteger") let s = Utf8.get_str (_attr "value" n) in
let i = int_of_string s in
if (i < 0) then failwith "Unexpected negative integer";
i
in in
let aux facets n tag = let aux facets n tag =
let fixed = _is_attr "fixed" n "true" in let fixed = _is_attr "fixed" n "true" in
match tag with match tag with
| "xsd:length" -> | "xsd:length" ->
let value = _attr "value" n in let length = parse_nonneg n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
{ facets with length = Some (length, fixed) } { facets with length = Some (length, fixed) }
| "xsd:minLength" -> | "xsd:minLength" ->
let value = _attr "value" n in let length = parse_nonneg n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
{ facets with minLength = Some (length, fixed) } { facets with minLength = Some (length, fixed) }
| "xsd:maxLength" -> | "xsd:maxLength" ->
let value = _attr "value" n in let length = parse_nonneg n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
{ facets with maxLength = Some (length, fixed) } { facets with maxLength = Some (length, fixed) }
| "xsd:enumeration" -> | "xsd:enumeration" ->
let value = Value.string_utf8 (_attr "value" n) in let value = Value.string_utf8 (_attr "value" n) in
...@@ -134,12 +148,14 @@ let parse_att_value_constraint stype_def n = ...@@ -134,12 +148,14 @@ let parse_att_value_constraint stype_def n =
let parse_min_max n = let parse_min_max n =
(match _may_attr "minOccurs" n with (match _may_attr "minOccurs" n with
| Some v -> Intervals.V.mk (Utf8.get_str v) | Some v -> int_of_string (Utf8.get_str v)
| None -> Intervals.V.one), | None -> 1),
(match _may_attr "maxOccurs" n with (match _may_attr "maxOccurs" n with
| Some v when Utf8.get_str v = "unbounded" -> None | Some v ->
| Some v -> Some (Intervals.V.mk (Utf8.get_str v)) (match Utf8.get_str v with
| None -> Some Intervals.V.one) | "unbounded" -> None
| v -> Some (int_of_string v))
| None -> Some 1)
let rec first n f = function let rec first n f = function
| [] -> None | [] -> None
...@@ -453,10 +469,7 @@ let schema_of_uri uri = ...@@ -453,10 +469,7 @@ let schema_of_uri uri =
CT_model (particle, mixed) CT_model (particle, mixed)
| CT_model (p, _) -> | CT_model (p, _) ->
let model = Sequence (p::[particle]) in let model = Sequence (p::[particle]) in
CT_model CT_model (particle_model 1 (Some 1) model, mixed)
((Intervals.V.one, Some (Intervals.V.one), Model model,
first_of_model_group model),
mixed)
| CT_simple _ -> assert false | CT_simple _ -> assert false
in in
base,derivation_type,uses,content_type base,derivation_type,uses,content_type
...@@ -502,22 +515,18 @@ let schema_of_uri uri = ...@@ -502,22 +515,18 @@ 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 elt e n = particle min max (Elt e) [ n ] false in
match _tag n with match _tag n with
| "xsd:element" -> | "xsd:element" ->
let elt_decl, first = (match _may_qname_attr "ref" n with
match _may_qname_attr "ref" n with | Some ref -> elt (resolve_elt ref) ref
| Some ref -> (resolve_elt ref, [ Some ref ]) | None ->
| None -> let decl = parse_elt_decl false n in
let decl = parse_elt_decl false n in elt (lazy decl) (name_of_element_declaration decl))
(lazy decl, [ Some (name_of_element_declaration decl) ]) | "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
in | "xsd:all" | "xsd:sequence" | "xsd:choice" ->
(min, max, Elt elt_decl, first) model (parse_model_group n)
| "xsd:group" ->
let mg = resolve_model_group (_qname_attr "ref" n) in
(min, max, Model mg.mg_def, first_of_model_group mg.mg_def)
| "xsd:all" | "xsd:sequence" | "xsd:choice" ->
let model_group = parse_model_group n in
(min, max, Model model_group, first_of_model_group model_group)
| _ -> assert false | _ -> assert false
and parse_model_group n = and parse_model_group n =
......
...@@ -16,16 +16,13 @@ open Encodings ...@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *) (** {2 XSD representation} *)
type xs_nonNegativeInteger = Intervals.V.t (* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type derivation_type = [ `Extension | `Restriction ] type derivation_type = [ `Extension | `Restriction ]
type white_space_handling = [ `Preserve | `Replace | `Collapse ] type white_space_handling = [ `Preserve | `Replace | `Collapse ]
type facets = { type facets = {
length: (xs_nonNegativeInteger * bool) option; (* length, fixed *) length: (int * bool) option; (* length, fixed *)
minLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *) minLength: (int * bool) option; (* length, fixed *)
maxLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *) maxLength: (int * bool) option; (* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *) (* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration: value_ref list option; enumeration: value_ref list option;
whiteSpace: white_space_handling * bool; (* handling, fixed *) whiteSpace: white_space_handling * bool; (* handling, fixed *)
...@@ -69,10 +66,6 @@ and attribute_use = ...@@ -69,10 +66,6 @@ and attribute_use =
attr_decl : attribute_declaration; attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option } attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Ns.QName.t option list
and term = and term =
| Elt of element_declaration Lazy.t | Elt of element_declaration Lazy.t
| Model of model_group | Model of model_group
...@@ -85,15 +78,14 @@ and model_group = ...@@ -85,15 +78,14 @@ and model_group =
and content_type = and content_type =
| CT_empty | CT_empty
| CT_simple of type_ref | CT_simple of type_ref
| CT_model of | CT_model of particle * bool (* mixed *)
particle *
bool (* mixed *)
and particle = and particle =
xs_nonNegativeInteger * (* minOccurs *) { part_min: int;
xs_nonNegativeInteger option * (* maxOccurs (None = "unbounded") *) part_max: int option; (* None = unbounded *)
term * part_term: term;
first part_first: Ns.qname list;
part_nullable: bool }
and element_declaration = and element_declaration =
{ elt_uid: int; { elt_uid: int;
......
...@@ -16,16 +16,13 @@ open Encodings ...@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *) (** {2 XSD representation} *)
type xs_nonNegativeInteger = Intervals.V.t (* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type derivation_type = [ `Extension | `Restriction ] type derivation_type = [ `Extension | `Restriction ]
type white_space_handling = [ `Preserve | `Replace | `Collapse ] type white_space_handling = [ `Preserve | `Replace | `Collapse ]
type facets = { type facets = {
length: (xs_nonNegativeInteger * bool) option; (* length, fixed *) length: (int * bool) option; (* length, fixed *)
minLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *) minLength: (int * bool) option; (* length, fixed *)
maxLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *) maxLength: (int * bool) option; (* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *) (* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration: value_ref list option; enumeration: value_ref list option;
whiteSpace: white_space_handling * bool; (* handling, fixed *) whiteSpace: white_space_handling * bool; (* handling, fixed *)
...@@ -69,10 +66,6 @@ and attribute_use = ...@@ -69,10 +66,6 @@ and attribute_use =
attr_decl : attribute_declaration; attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option } attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Ns.QName.t option list
and term = and term =
| Elt of element_declaration Lazy.t | Elt of element_declaration Lazy.t
| Model of model_group | Model of model_group
...@@ -85,15 +78,14 @@ and model_group = ...@@ -85,15 +78,14 @@ and model_group =
and content_type = and content_type =
| CT_empty | CT_empty
| CT_simple of type_ref | CT_simple of type_ref
| CT_model of | CT_model of particle * bool (* mixed *)
particle *
bool (* mixed *)
and particle = and particle =
xs_nonNegativeInteger * (* minOccurs *) { part_min: int;
xs_nonNegativeInteger option * (* maxOccurs (None = "unbounded") *) part_max: int option; (* None = unbounded *)
term * part_term: term;
first part_first: Ns.qname list;
part_nullable: bool }
and element_declaration = and element_declaration =
{ elt_uid: int; { elt_uid: int;
......
...@@ -33,10 +33,8 @@ let ptbl_of_particles particles = ...@@ -33,10 +33,8 @@ let ptbl_of_particles particles =
let tbl = QTable.create 20 in let tbl = QTable.create 20 in
List.iter (* fill table *) List.iter (* fill table *)
(* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *) (* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
(fun p -> (fun p ->
List.iter List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
(function None -> () | Some tag -> QTable.add tbl tag p)
(first_of_particle p))
particles; particles;
tbl tbl
...@@ -54,10 +52,6 @@ class type validation_context = ...@@ -54,10 +52,6 @@ class type validation_context =
method set_mixed: bool -> unit method set_mixed: bool -> unit
method mixed: bool method mixed: bool
(*
method ns: Ns.t
*)
end end
let validation_error ?context s = raise (XSI_validation_error s) let validation_error ?context s = raise (XSI_validation_error s)
...@@ -103,21 +97,20 @@ struct ...@@ -103,21 +97,20 @@ struct
* and no Concat, but just Pair *) * and no Concat, but just Pair *)
let length v = let length v =
let rec aux acc = function let rec aux acc = function
| Pair (_, rest) -> aux (Intervals.V.succ acc) rest | Pair (_, rest) -> aux (succ acc) rest
| v when v = Value.nil -> Intervals.V.zero | _ -> 0
| _ -> assert false
in in
aux Intervals.V.zero v aux 0 v
let length_valid len value = let length_valid len value =
if not (Intervals.V.equal (length value) len) then if (length value != len)
raise (Facet_error "length") then raise (Facet_error "length")
let minLength_valid min_len value = let minLength_valid min_len value =
if Intervals.V.lt (length value) min_len then if (length value < min_len)
raise (Facet_error "minLength") then raise (Facet_error "minLength")
let maxLength_valid max_len value = let maxLength_valid max_len value =
if Intervals.V.gt (length value) max_len then if (length value > max_len)
raise (Facet_error "maxLength") then raise (Facet_error "maxLength")
let enumeration_valid enum value = let enumeration_valid enum value =
if not (List.exists (fun x -> Value.equal value (Lazy.force x)) enum) if not (List.exists (fun x -> Value.equal value (Lazy.force x)) enum)
...@@ -341,13 +334,13 @@ and validate_content_type context content_type : Value.t = ...@@ -341,13 +334,13 @@ and validate_content_type context content_type : Value.t =
validate_particle context particle validate_particle context particle
and validate_particle context particle = and validate_particle context particle =
let (min, max, term, first) = particle in
let content = ref Value.nil in let content = ref Value.nil in
let concat v = content := Value.concat !content v in let concat v = content := Value.concat !content v in
let rec validate_once ~cont_ok ~cont_failure = let rec validate_once ~cont_ok ~cont_failure =
match context#peek with match context#peek with
| E_start_tag qname when is_in_first qname first -> | E_start_tag qname
concat (validate_term context term); when List.exists (Ns.QName.equal qname) particle.part_first ->
concat (validate_term context particle.part_term);
cont_ok () cont_ok ()
| E_char_data utf8_data when context#mixed -> | E_char_data utf8_data when context#mixed ->
concat (string_utf8 utf8_data); concat (string_utf8 utf8_data);
...@@ -356,10 +349,10 @@ and validate_particle context particle = ...@@ -356,10 +349,10 @@ and validate_particle context particle =
| ev -> cont_failure ev | ev -> cont_failure ev
in in
let rec required = function let rec required = function
| v when Intervals.V.equal v Intervals.V.zero -> () | 0 -> ()
| n (* when n > 0 *) -> | n ->
validate_once validate_once
~cont_ok:(fun () -> required (Intervals.V.pred n)) ~cont_ok:(fun () -> required (pred n))
~cont_failure:(fun event -> ~cont_failure:(fun event ->
validation_error ~context (sprintf "Unexpected content: %s" validation_error ~context (sprintf "Unexpected content: %s"
(string_of_event event))) (string_of_event event)))
...@@ -369,10 +362,10 @@ and validate_particle context particle = ...@@ -369,10 +362,10 @@ and validate_particle context particle =
validate_once validate_once
~cont_ok:(fun () -> optional None) ~cont_ok:(fun () -> optional None)
~cont_failure:(fun _ -> ()) ~cont_failure:(fun _ -> ())
| Some v when Intervals.V.equal v Intervals.V.zero -> () | Some 0 -> ()
| Some n (* when n > 0 *) -> | Some n ->
validate_once validate_once
~cont_ok:(fun () -> optional (Some (Intervals.V.pred n))) ~cont_ok:(fun () -> optional (Some (pred n)))
~cont_failure:(fun _ -> ()) ~cont_failure:(fun _ -> ())
in in
let rec trailing_cdata () = let rec trailing_cdata () =
...@@ -383,9 +376,11 @@ and validate_particle context particle = ...@@ -383,9 +376,11 @@ and validate_particle context particle =
trailing_cdata () trailing_cdata ()
| _ -> () | _ -> ()
in in
required min; required particle.part_min;
optional optional
(match max with None -> None | Some v -> Some (Intervals.V.sub v min)); (match particle.part_max with
| None -> None
| Some v -> Some (v - particle.part_min));
if context#mixed then trailing_cdata (); if context#mixed then trailing_cdata ();
!content !content
...@@ -518,10 +513,6 @@ class context ~stream ~schema = ...@@ -518,10 +513,6 @@ class context ~stream ~schema =
(string_of_event ev)); (string_of_event ev));
foo_qname (* useless *) foo_qname (* useless *)
(*
method ns = schema.targetNamespace
*)
end end
(** {2 API} *) (** {2 API} *)
......
...@@ -1508,22 +1508,19 @@ module Schema_converter = ...@@ -1508,22 +1508,19 @@ module Schema_converter =
let mk_len_regexp ?min ?max base = let mk_len_regexp ?min ?max base =
let rec repeat_regexp re = function let rec repeat_regexp re = function
| z when Intervals.V.is_zero z -> PEpsilon | 0 -> PEpsilon
| n when Intervals.V.gt n Intervals.V.zero -> | n -> seq re (repeat_regexp re (pred n))
seq re (repeat_regexp re (Intervals.V.pred n))
| _ -> assert false
in in
let min = match min with Some min -> min | _ -> Intervals.V.one in let min = match min with Some min -> min | _ -> 1 in
let min_regexp = repeat_regexp base min in let min_regexp = repeat_regexp base min in
match max with match max with
| Some max -> | Some max ->
(* assert (max >= min); Need to use Bigint comparison ! -- AF *) (* assert (max >= min); Need to use Bigint comparison ! -- AF *)
let rec aux acc = function let rec aux acc = function
| z when Intervals.V.is_zero z -> acc | 0 -> acc
| n -> | n -> aux (PAlt (PEpsilon, (seq base acc))) (pred n)
aux (PAlt (PEpsilon, (seq base acc))) (Intervals.V.pred n)
in in
seq min_regexp (aux PEpsilon (Intervals.V.sub max min)) seq min_regexp (aux PEpsilon (max-min))
| None -> seq min_regexp (PStar base) | None -> seq min_regexp (PStar base)
(* given a base derecurs create a derecurs value representing a sequence (* given a base derecurs create a derecurs value representing a sequence
...@@ -1621,8 +1618,9 @@ module Schema_converter = ...@@ -1621,8 +1618,9 @@ module Schema_converter =
seq acc (regexp_of_particle ~schema particle)) seq acc (regexp_of_particle ~schema particle))
(regexp_of_particle ~schema hd) tl (regexp_of_particle ~schema hd) tl
and regexp_of_particle ~schema (min, max, term, _) = and regexp_of_particle ~schema p =
mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term) mk_len_regexp ?min:(Some p.part_min) ?max:p.part_max
(regexp_of_term ~schema p.part_term)
(** @return a pair composed by a type for the attributes (a record) and a (** @return a pair composed by a type for the attributes (a record) and a
type for the content model (a sequence) *) type for the content model (a sequence) *)
......