Skip to content

GitLab

Commit 740fcb51 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-06-13 16:12:26 by cvscast] added support for recursive schema types 

Original author: cvscast
Date: 2003-06-13 16:12:26+00:00
parent ad912f77
Hide whitespace changes
Inline Side-by-side
schema/schema_parser.ml
View file @ 740fcb51
......@@ -7,9 +7,18 @@ open Schema_types
actually is possible that both more of them are provided.
IDEA: validate schema document using DTD for Schemas? *)
class type resolver =
object
method see : Schema_xml.schema_extension node -> unit
method resolve_att : string -> att_decl
method resolve_elt : now:bool -> string -> elt_decl ref
method resolve_typ : now:bool -> string -> type_def ref
end
exception Not_implemented of string
let debug = true
let debug = false
let debug_print s = if debug then prerr_endline s
let hashtbl_values tbl = Hashtbl.fold (fun _ valu acc -> valu :: acc) tbl []
let rec filter_out_none = function (* not tail recursive *)
......@@ -35,7 +44,8 @@ let content_type_of_def = function
| C (CBuilt_in _) -> assert false
| C (CUser_defined (_, _, _, _, _, ct)) -> ct
let parse_facet resolver base_type_def n =
let parse_facet (resolver: resolver) base_type_def n =
debug_print "Schema_parser.parse_facet";
let validate_base_type =
Schema_validator.validate_simple_type base_type_def
in
......@@ -107,7 +117,10 @@ let parse_facet resolver base_type_def n =
unexpected))
| _ -> assert false
let parse_simple_type resolver n =
let parse_simple_type (resolver: resolver) n =
debug_print "Schema_parser.parse_simple_type";
if n#parent#node_type = T_element "xsd:schema" then
resolver#see n;
assert (n#node_type = T_element "xsd:simpleType");
SBuilt_in "FAKE" (* TODO facets *)
(* FINQUI *)
......@@ -130,16 +143,18 @@ let constr_of_attr_node n validate =
raise (XSD_validation_error ("Invalid value for constraint on \
attribute " ^ n#extension#name))
let parse_att_decl resolver n =
let parse_att_decl (resolver: resolver) n =
debug_print "Schema_parser.parse_att_decl";
let name = n#extension#name in
match n#parent#node_type with
| T_element "xsd:schema" -> (* global element *)
| T_element "xsd:schema" -> (* global attribute *)
resolver#see n;
let simple_type_def =
(try
parse_simple_type resolver (find_element "xsd:simpleType" n)
with Not_found ->
(try
(match !(resolver#resolve_typ n#extension#typ) with
(match !(resolver#resolve_typ ~now:true n#extension#typ) with
| S st -> st
| C _ ->
raise (XSD_validation_error
......@@ -155,9 +170,9 @@ let parse_att_decl resolver n =
(** @return an attribute_use option. None means that the attribute is
prohibited *)
let parse_attribute_use resolver n =
assert
(match n#node_type with T_element "xsd:attribute" -> true | _ -> false);
let parse_attribute_use (resolver: resolver) n =
debug_print "Schema_parser.parse_attribute_use";
assert (n#node_type = T_element "xsd:attribute");
let prohibited = try n#extension#prohibited with Not_found -> false in
if prohibited then (* attribute prohibited *)
None
......@@ -178,7 +193,7 @@ let parse_attribute_use resolver n =
parse_simple_type resolver (find_element "xsd:simpleType" n)
with Not_found ->
(try
(match !(resolver#resolve_typ n#extension#typ) with
(match !(resolver#resolve_typ ~now:true n#extension#typ) with
| S st -> st
| C _ ->
raise (XSD_validation_error
......@@ -196,7 +211,7 @@ let parse_attribute_use resolver n =
(** @return a list of attribute uses from a xsd:restriction node wrt a base
type definition *)
let attribute_uses_of_restriction ~resolver ~n ~base =
let attribute_uses_of_restriction ~(resolver: resolver) ~n ~base =
let embedded = (* associative list <name, attribute_use option> *)
List.map
(fun n ->
......@@ -219,7 +234,7 @@ let attribute_uses_of_restriction ~resolver ~n ~base =
(** @return a list of attribute uses from a xsd:extension node wrt a base type
definition *)
let attribute_uses_of_extension ~resolver ~n ~base =
let attribute_uses_of_extension ~(resolver: resolver) ~n ~base =
let embedded = (* attribute_use option list *)
List.map (parse_attribute_use resolver) n#extension#find_attributes
in
......@@ -235,16 +250,18 @@ let counter = ref 0
let cuser_defined name base derivation attribute_uses ct =
incr counter;
CUser_defined (!counter, name, base, derivation, attribute_uses, ct)
let rec parse_complex_type resolver n =
let rec parse_complex_type (resolver: resolver) n =
debug_print "Schema_parser.parse_complex_type";
if n#parent#node_type = T_element "xsd:schema" then
resolver#see n;
let name = try Some n#extension#name with Not_found -> None in
if n#extension#has_element "xsd:simpleContent" then begin
let content = find_element "xsd:simpleContent" n in
if content#extension#has_element "xsd:restriction" then begin
(* simpleContent, restriction *)
let restriction = find_element "xsd:restriction" content in
let base = resolver#resolve_typ restriction#extension#base in
let base = resolver#resolve_typ ~now:true restriction#extension#base in
let attribute_uses =
attribute_uses_of_restriction ~resolver ~n:restriction ~base:!base
in
......@@ -264,7 +281,7 @@ let rec parse_complex_type resolver n =
end else if content#extension#has_element "xsd:extension" then begin
(* simpleContent, extension *)
let extension = find_element "xsd:extension" content in
let base = resolver#resolve_typ extension#extension#base in
let base = resolver#resolve_typ ~now:true extension#extension#base in
let attribute_uses =
attribute_uses_of_extension ~resolver ~n:extension ~base:!base
in
......@@ -284,7 +301,7 @@ let rec parse_complex_type resolver n =
if content#extension#has_element "xsd:restriction" then begin
(* complexContent, restriction *)
let restriction = find_element "xsd:restriction" content in
let base = resolver#resolve_typ restriction#extension#base in
let base = resolver#resolve_typ ~now:true restriction#extension#base in
let attribute_uses =
attribute_uses_of_restriction ~resolver ~n:restriction ~base:!base
in
......@@ -306,7 +323,7 @@ let rec parse_complex_type resolver n =
end else if content#extension#has_element "xsd:extension" then begin
(* complexContent, extension *)
let extension = find_element "xsd:extension" content in
let base = resolver#resolve_typ extension#extension#base in
let base = resolver#resolve_typ ~now:true extension#extension#base in
let attribute_uses =
attribute_uses_of_extension ~resolver ~n:extension ~base:!base
in
......@@ -342,7 +359,7 @@ let rec parse_complex_type resolver n =
end else begin
(* neither simpleContent nor simpleContent, therefore ... *)
(* ... complexContent, restriction: shortcut *)
let base = resolver#resolve_typ "xsd:anyType" in
let base = resolver#resolve_typ ~now:true "xsd:anyType" in
let attribute_uses =
attribute_uses_of_restriction ~resolver ~n ~base:!base
in
......@@ -357,39 +374,44 @@ let rec parse_complex_type resolver n =
cuser_defined name !base Restriction attribute_uses content_type
end
and parse_elt_decl resolver n =
and parse_elt_decl (resolver: resolver) n =
debug_print "Schema_parser.parse_elt_decl";
match n#parent#node_type with
| T_element "xsd:schema" -> (* global element *)
resolver#see n;
let name = n#extension#name in
let type_def =
let type_def_ref =
(try
S (parse_simple_type resolver (find_element "xsd:simpleType" n))
ref (S (parse_simple_type resolver (find_element "xsd:simpleType" n)))
with Not_found ->
(try
C (parse_complex_type resolver (find_element "xsd:complexType" n))
ref (C (parse_complex_type resolver
(find_element "xsd:complexType" n)))
with Not_found ->
!(resolver#resolve_typ n#extension#typ)))
resolver#resolve_typ ~now:false n#extension#typ))
in
name, ref type_def, None
name, type_def_ref, None
| _ -> assert false (* you have to use parse_particle *)
and parse_particle resolver n =
and parse_particle (resolver: resolver) n =
debug_print "Schema_parser.parse_particle";
let (minOccurs, maxOccurs) = (get_minOccurs n, get_maxOccurs n) in
match n#node_type with
| T_element "xsd:element" when not (n#extension#has_attribute "ref") ->
let name = n#extension#name in
let type_def =
let type_def_ref =
(try
S (parse_simple_type resolver (find_element "xsd:simpleType" n))
ref (S (parse_simple_type resolver (find_element "xsd:simpleType" n)))
with Not_found ->
(try
C (parse_complex_type resolver (find_element "xsd:complexType" n))
ref (C (parse_complex_type resolver
(find_element "xsd:complexType" n)))
with Not_found ->
!(resolver#resolve_typ n#extension#typ)))
resolver#resolve_typ ~now:false n#extension#typ))
in
minOccurs, maxOccurs, Elt (ref (name, ref type_def, None))
minOccurs, maxOccurs, Elt (ref (name, type_def_ref, None))
| T_element "xsd:element" (* when n#extension#has_attribute "ref" *)->
let elt_decl = resolver#resolve_elt n#extension#ref in
let elt_decl = resolver#resolve_elt ~now:false n#extension#ref in
minOccurs, maxOccurs, (Elt elt_decl)
| T_element "xsd:all" ->
minOccurs, maxOccurs,
......@@ -410,55 +432,77 @@ module OrderedNode =
end
module NodeSet = Set.Make (OrderedNode)
(* lazy resolver: resolve types/elements/attributes as soon as it encounter
references to them. DOESN'T WORK WITH RECURSIVE ENTITIES [ probably it loops ]
@param node schema document root node
*)
(* @param root schema document root node *)
class lazy_resolver =
let fake_type_def = C (CBuilt_in " FAKE TYP ") in
let fake_elt_decl = " FAKE ELT ", ref fake_type_def, None in
let is_fake_type_def = (=) fake_type_def in
let is_fake_elt_decl = (=) fake_elt_decl in
fun node ->
let error_no_type_def name =
raise (XSD_validation_error ("Can't find definition of type: " ^ name))
in
let error_no_elt_decl name =
raise (XSD_validation_error ("Can't find declaration of element: " ^ name))
in
let error_no_att_decl name =
raise (XSD_validation_error
("Can't find declaration of attribute: " ^ name))
in
fun root ->
object (self)
val typs = Hashtbl.create 17
val attrs = Hashtbl.create 17
val elts = Hashtbl.create 17
val mutable seen_nodes = NodeSet.empty
initializer (* register built-in types *)
(* register built-in types *)
initializer
List.iter (fun name -> Hashtbl.add typs name (ref (S (SBuilt_in name))))
Schema_builtin.names
method already_seen n = NodeSet.mem n seen_nodes
(** seen nodes accounting *)
method private register_typ' node name def =
if Hashtbl.mem typs name then
val mutable seen_nodes = NodeSet.empty
method already_seen n = NodeSet.mem n seen_nodes
method see (n: Schema_xml.schema_extension node) =
debug_print "lazy_resolver.see";
if NodeSet.mem n seen_nodes then
raise (XSD_validation_error "Types/Elements loop")
else
seen_nodes <- NodeSet.add n seen_nodes
(** registration of global entities *)
method register_typ name def =
debug_print "lazy_resolver.register_typ";
if (Hashtbl.mem typs name) &&
(not (is_fake_type_def !(Hashtbl.find typs name)))
then
raise (XSD_validation_error ("Redefinition of type: " ^ name));
if debug then
(Format.fprintf Format.std_formatter
"\nSchema_parser: registering TYPE %s:\n%a\n"
name print_type !def;
name print_type def;
Format.pp_print_flush Format.std_formatter ());
Hashtbl.add typs name def;
seen_nodes <- NodeSet.add node seen_nodes
method private register_elt' node name decl =
if Hashtbl.mem elts name then
let type_def_ref = self#resolve_typ ~now:false name in
type_def_ref := def
method register_elt name decl =
debug_print "lazy_resolver.register_elt";
if (Hashtbl.mem elts name) &&
(not (is_fake_elt_decl !(Hashtbl.find elts name)))
then
raise (XSD_validation_error ("Redefinition of element: " ^ name));
if debug then
(Format.fprintf Format.std_formatter
"\nSchema_parser: registering ELEMENT %s:\n%a\n"
name print_elt_decl !decl;
name print_elt_decl decl;
Format.pp_print_flush Format.std_formatter ());
Hashtbl.add elts name decl;
seen_nodes <- NodeSet.add node seen_nodes
let elt_decl_ref = self#resolve_elt ~now:false name in
elt_decl_ref := decl
method private register_att' node name decl =
method register_att name decl =
debug_print "lazy_resolver.register_att";
if Hashtbl.mem attrs name then
raise (XSD_validation_error ("Redefinition of attribute: " ^ name));
if debug then
......@@ -466,71 +510,85 @@ class lazy_resolver =
"\nSchema_parser: registering ATTRIBUTE %s:\n%a\n"
name print_att_decl decl;
Format.pp_print_flush Format.std_formatter ());
Hashtbl.add attrs name decl;
seen_nodes <- NodeSet.add node seen_nodes
method register_simple_type n =
let st_def = parse_simple_type (self :> resolver) n in
self#register_typ' n n#extension#name (ref (S st_def))
Hashtbl.add attrs name decl
method register_complex_type n =
let ct_def = parse_complex_type (self :> resolver) n in
self#register_typ' n n#extension#name (ref (C ct_def))
(** entities lookup *)
method register_elt n =
let elt_decl = parse_elt_decl (self :> resolver) n in
self#register_elt' n n#extension#name (ref elt_decl)
method att_decls = hashtbl_values attrs
method elt_decls = List.map (!) (hashtbl_values elts)
method type_defs = List.map (!) (hashtbl_values typs)
method resolve_typ name =
(try
method resolve_typ ~now name =
debug_print "lazy_resolver.resolve_typ";
try
Hashtbl.find typs name
with Not_found ->
(try
let node = node#extension#find_simpleType name in
let typ_def = ref (S (parse_simple_type (self :> resolver) node)) in
self#register_typ' node name typ_def;
typ_def
with Not_found ->
(try
let node = node#extension#find_complexType name in
let typ_def =
ref (C (parse_complex_type (self :> resolver) node))
in
self#register_typ' node name typ_def;
typ_def
with Not_found ->
raise (XSD_validation_error ("Can't find definition of type: " ^
name)))))
if now then begin (* resolve now: look for global type definitions *)
let node = root#extension#find_simpleType name in
let typ_def =
(try
let node = node#extension#find_simpleType name in
S (parse_simple_type (self :> resolver) node)
with Not_found ->
(try
let node = node#extension#find_complexType name in
C (parse_complex_type (self :> resolver) node)
with Not_found -> error_no_type_def name))
in
Hashtbl.add typs name (ref typ_def)
end else begin (* resolve later: return a fake type ref *)
Hashtbl.add typs name (ref fake_type_def)
end;
Hashtbl.find typs name
method resolve_elt name =
(try
method resolve_elt ~now name =
debug_print "lazy_resolver.resolve_elt";
try
Hashtbl.find elts name
with Not_found ->
(try
let node = node#extension#find_global_element name in
let elt_decl = ref (parse_elt_decl (self :> resolver) node) in
self#register_elt' node name elt_decl;
elt_decl
with Not_found ->
raise (XSD_validation_error ("Can't find declaration of element: " ^
name))))
if now then begin (* resolve now: look for global element decls *)
let node =
try
root#extension#find_global_element name
with Not_found ->
error_no_elt_decl name
in
let elt_decl = parse_elt_decl (self :> resolver) node in
Hashtbl.add elts name (ref elt_decl)
end else begin (* resolve later: return fake element ref *)
Hashtbl.add elts name (ref fake_elt_decl)
end;
Hashtbl.find elts name
method resolve_att name =
(try
debug_print "lazy_resolver.resolve_att";
try
Hashtbl.find attrs name
with Not_found ->
(try
let node = node#extension#find_global_attribute name in
let att_decl = parse_att_decl (self :> resolver) node in
self#register_att' node name att_decl;
att_decl
with Not_found ->
raise (XSD_validation_error ("Can't find declaration of attribute: " ^
name))))
let node =
try
root#extension#find_global_attribute name
with Not_found -> error_no_att_decl name
in
let att_decl = parse_att_decl (self :> resolver) node in
Hashtbl.add attrs name att_decl;
att_decl
(** acces to registered global entities *)
method att_decls = hashtbl_values attrs
method elt_decls =
Hashtbl.fold
(fun name decl acc -> (* check that all referenced elts are defined *)
if is_fake_elt_decl !decl then
error_no_elt_decl name
else
!decl :: acc)
elts []
method type_defs =
Hashtbl.fold
(fun name def acc -> (* check that all referenced types are defined *)
if is_fake_type_def !def then
error_no_type_def name
else
!def :: acc)
typs []
end
......@@ -540,9 +598,18 @@ let parse_schema doc =
root#iter_nodes (fun n ->
if not (resolver#already_seen n) then
(match n#node_type with
| T_element "xsd:element" -> resolver#register_elt n
| T_element "xsd:simpleType" -> resolver#register_simple_type n
| T_element "xsd:complexType" -> resolver#register_complex_type n
| T_element "xsd:element" ->
resolver#register_elt n#extension#name
(parse_elt_decl (resolver :> resolver) n)
| T_element "xsd:simpleType" ->
resolver#register_typ n#extension#name
(S (parse_simple_type (resolver :> resolver) n))
| T_element "xsd:complexType" ->
resolver#register_typ n#extension#name
(C (parse_complex_type (resolver :> resolver) n))
| T_element "xsd:attribute" ->
resolver#register_att n#extension#name
(parse_att_decl (resolver :> resolver) n)
| T_element e ->
raise (XSD_validation_error ("Unexpected root element " ^ e))
| _ -> ()));
......
schema/schema_types.ml
View file @ 740fcb51
......@@ -3,13 +3,6 @@ open Printf
module StringMap = Map.Make (String)
module ValueSet = Set.Make (Value)
module OrderedStringOption =
struct
type t = string option
let compare = Pervasives.compare
end
module First = Set.Make (OrderedStringOption)
exception XSI_validation_error of string
exception XSD_validation_error of string
......@@ -82,13 +75,6 @@ let name_of_type_def = function
let name_of_attribute_use (_, (n, _, _), _) = n
let name_of_att_decl (n, _, _) = n
class type resolver =
object
method resolve_att: string -> att_decl
method resolve_elt: string -> elt_decl ref
method resolve_typ: string -> type_def ref
end
(* pretty printing *)
open Format
......
schema/schema_types.mli
View file @ 740fcb51
......@@ -15,9 +15,6 @@ module StringMap : Map.S with type key = string
(* used to encode enumeration facet *)
module ValueSet : Set.S with type elt = Value.t
(* used to encode content model's "first". None value encode "epsilon" *)
module First : Set.S with type elt = string option
(** {2 XSD representation} *)
type derivation = Extension | Restriction
......@@ -88,7 +85,7 @@ and elt_decl =
and complex_type_def =
| CBuilt_in of string
| CUser_defined of
int * (* unique ID *)
int * (* unique id *)
string option * (* name *)
type_def * (* base *)
derivation *
......@@ -123,13 +120,6 @@ val name_of_type_def : type_def -> string
val name_of_att_decl : att_decl -> string
val name_of_attribute_use : attribute_use -> string
class type resolver =
object
method resolve_att : string -> att_decl
method resolve_elt : string -> elt_decl ref
method resolve_typ : string -> type_def ref
end
(** perform white space normalization according to a white space facet *)
val normalize_ws: ws_handling -> string -> string
schema/schema_validator.ml
View file @ 740fcb51
......@@ -7,9 +7,19 @@ open Schema_types
exception Stop ;; (* internal *)
type validator = (Pxp_yacc.event Stream.t -> Value.t) * First.t
module OrderedStringOption =
struct
type t = string option
let compare = Pervasives.compare
end
(* used to encode content model's "first". None value encode "epsilon" *)
module First = Set.Make (OrderedStringOption)
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 *)
(* wrap a function validating a string with a validator *)
let pcdata_wrapper f = (fun stream -> f (Schema_xml.collect_pcdata stream))
......@@ -200,7 +210,7 @@ and validator_of_term = function
| All [] | Choice [] | Sequence [] -> assert false (* TODO empty CM *)
| All _ -> assert false (* TODO xsd:all *)
| Choice particles -> (* TODO UPA *)
let 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
element *)
let rec aux = function
......@@ -208,11 +218,11 @@ and validator_of_term = function
| ((_, first) as v) :: tl when (First.mem (Some name) first) -> v
| _ :: tl -> aux tl
in
aux validators
aux p_validators
in
let first = (* union of choices' firsts *)
List.fold_left (fun acc (_, f) -> First.union f acc) First.empty
validators
p_validators
in
(fun stream ->
let error found =
......@@ -228,7 +238,7 @@ and validator_of_term = function
validate ~validator stream),
first
| Sequence particles ->
let validators = List.map validator_of_particle particles in
let p_validators = List.map validator_of_particle particles in
let first = (* union of first until epsilon is in one of them *)
let rec aux acc = function
| [] -> acc
......@@ -236,33 +246,39 @@ and validator_of_term = function
let next_first = First.union acc first in
if First.mem None first then aux next_first tl else next_first
in
aux First.empty validators
aux First.empty p_validators
in
(fun stream ->
let values = ref [] in
List.iter
(fun v -> values := validate ~validator:v stream :: !values)
validators;
p_validators;
Value.sequence (List.rev !values)),
first
| Elt decl -> validator_of_elt_decl !decl
and validator_of_complex_type = function
and validator_of_complex_type' = function
| CBuilt_in s -> (* TODO uhm .... is this useful? *)
((fun _ -> assert false),
(pcdata_wrapper (Schema_builtin.__validate_fun_of_builtin s),