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

[r2005-02-17 13:35:50 by afrisch] Clean schema

Original author: afrisch
Date: 2005-02-17 13:35:50+00:00
parent fc00b73a
open Encodings open Encodings
(** all schema simple type names used in this API are prefixed with (** all schema simple type names used in this API are prefixed with
......
...@@ -343,7 +343,8 @@ let stream_of_value v = ...@@ -343,7 +343,8 @@ let stream_of_value v =
stack := tl; stack := tl;
Some (E_char_data v) Some (E_char_data v)
| [] -> None | [] -> None
| _ -> assert false | _ ->
failwith "Non XML element"
in in
Stream.from f Stream.from f
......
...@@ -7,6 +7,8 @@ open Schema_types ...@@ -7,6 +7,8 @@ open Schema_types
open Schema_validator open Schema_validator
open Schema_xml open Schema_xml
let validation_error s = raise (XSD_validation_error s)
let debug = false let debug = false
let debug_print ?(n: node option) s = let debug_print ?(n: node option) s =
if debug then if debug then
...@@ -163,7 +165,7 @@ and find_base_simple_type (resolver: resolver) n = ...@@ -163,7 +165,7 @@ and find_base_simple_type (resolver: resolver) n =
| None -> | None ->
match _may_elem "xsd:simpleType" n with match _may_elem "xsd:simpleType" n with
| Some v -> parse_simple_type resolver v | Some v -> parse_simple_type resolver v
| None ->raise (XSD_validation_error "no base simple type specified") | None -> validation_error "no base simple type specified"
(* look for a simple type def: try attribute "itemType", try "simpleType" (* look for a simple type def: try attribute "itemType", try "simpleType"
* child, fail *) * child, fail *)
...@@ -173,7 +175,7 @@ and find_item_type (resolver: resolver) n = ...@@ -173,7 +175,7 @@ and find_item_type (resolver: resolver) n =
| None -> | None ->
match _may_elem "xsd:simpleType" n with match _may_elem "xsd:simpleType" n with
| Some v -> parse_simple_type resolver v | Some v -> parse_simple_type resolver v
| None -> raise (XSD_validation_error "no itemType specified") | None -> validation_error "no itemType specified"
(* look for a list of simple type defs: try attribute "memberTypes", try (* look for a list of simple type defs: try attribute "memberTypes", try
* "simpleType" children, fail *) * "simpleType" children, fail *)
...@@ -188,7 +190,7 @@ and find_member_types (resolver: resolver) n = ...@@ -188,7 +190,7 @@ and find_member_types (resolver: resolver) n =
List.map (parse_simple_type resolver) nodes List.map (parse_simple_type resolver) nodes
in in
(match members1 @ members2 with (match members1 @ members2 with
| [] -> raise (XSD_validation_error "no member types specified") | [] -> validation_error "no member types specified"
| members -> members) | members -> members)
let default_fixed n f = let default_fixed n f =
...@@ -403,7 +405,7 @@ and parse_elt_decl (resolver: resolver) n: element_declaration = ...@@ -403,7 +405,7 @@ and parse_elt_decl (resolver: resolver) n: element_declaration =
debug_print ~n "Schema_parser.parse_elt_decl"; debug_print ~n "Schema_parser.parse_elt_decl";
resolver#see n; resolver#see n;
match _may_attr "name" n with match _may_attr "name" n with
| None -> raise (XSD_validation_error "missing element name") | None -> validation_error "missing element name"
| Some name -> | Some name ->
let type_def = find_element_type resolver n in let type_def = find_element_type resolver n in
let value_constr = parse_elt_value_constraint type_def n in let value_constr = parse_elt_value_constraint type_def n in
...@@ -480,120 +482,113 @@ let parse_model_group_def (resolver: resolver) n = ...@@ -480,120 +482,113 @@ let parse_model_group_def (resolver: resolver) n =
let model_group = parse_model_group resolver model_group_node in let model_group = parse_model_group resolver model_group_node in
{ mg_name = name; mg_def = model_group } { mg_name = name; mg_def = model_group }
let fake_type_def =
Complex
{ ct_uid = -1;
ct_name = Some (Utf8.mk " FAKE TYP ");
ct_typdef = AnyType;
ct_deriv = `Restriction;
ct_attrs = [];
ct_content = CT_empty }
let fake_elt_decl =
{ elt_uid = -2;
elt_name = Utf8.mk " FAKE ELT ";
elt_typdef = fake_type_def;
elt_cstr = None }
let is_fake_type_def = (==) fake_type_def
let is_fake_elt_decl = (==) fake_elt_decl
let (^^) x y = Utf8.concat x y
(** @param root schema document root node *) (** @param root schema document root node *)
class lazy_resolver = class lazy_resolver root = object (self)
let fake_type_def = val typs: (Utf8.t, type_definition ref) Hashtbl.t = Hashtbl.create 17
Complex val attrs: (Utf8.t, attribute_declaration) Hashtbl.t = Hashtbl.create 17
{ ct_uid = -1; val elts: (Utf8.t, element_declaration ref) Hashtbl.t = Hashtbl.create 17
ct_name = Some (Utf8.mk " FAKE TYP "); val attr_groups: (Utf8.t, attribute_group_definition) Hashtbl.t =
ct_typdef = AnyType; Hashtbl.create 17
ct_deriv = `Restriction; val model_groups: (Utf8.t, model_group_definition) Hashtbl.t =
ct_attrs = []; Hashtbl.create 17
ct_content = CT_empty }
in val mutable seen_nodes = NodeSet.empty
let fake_elt_decl =
{ elt_uid = -2; val mutable targetNamespace = None
elt_name = Utf8.mk " FAKE ELT "; val mutable targetNamespace_prefix = "0TARGET0"
elt_typdef = fake_type_def; val namespace_manager = new Pxp_dtd.namespace_manager
elt_cstr = None } val orig_ns_prefixes = Hashtbl.create 17
in
let is_fake_type_def = (==) fake_type_def in initializer
let is_fake_elt_decl = (==) fake_elt_decl in (* register built-in types *)
let validation_error s = raise (XSD_validation_error s) in Schema_builtin.iter_builtin
let (^^) x y = Utf8.concat x y in (fun st_def ->
fun root -> let type_def = Simple st_def in
object (self) let name = name_of_type_definition type_def in
Hashtbl.replace typs name (ref type_def));
val typs: (Utf8.t, type_definition ref) Hashtbl.t = Hashtbl.replace typs (Utf8.mk "xsd:anyType") (ref AnyType);
Hashtbl.create 17
val attrs: (Utf8.t, attribute_declaration) Hashtbl.t = (* fill namespace manager *)
Hashtbl.create 17 List.iter
val elts: (Utf8.t, element_declaration ref) Hashtbl.t = (fun (p, ns) ->
Hashtbl.create 17 namespace_manager#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
val attr_groups: (Utf8.t, attribute_group_definition) Hashtbl.t = Schema_xml.schema_ns_prefixes;
Hashtbl.create 17
val model_groups: (Utf8.t, model_group_definition) Hashtbl.t = List.iter
Hashtbl.create 17 (fun (prefix,uri) ->
if prefix <> "" then begin
val mutable seen_nodes = NodeSet.empty Hashtbl.add orig_ns_prefixes prefix uri;
ignore (namespace_manager#lookup_or_add_namespace prefix uri)
val mutable targetNamespace = None end)
val mutable targetNamespace_prefix = "0TARGET0" (_namespaces root);
val namespace_manager = new Pxp_dtd.namespace_manager
val orig_ns_prefixes = Hashtbl.create 17 match _may_attr "targetNamespace" root with
| Some ns ->
initializer targetNamespace <- Some ns;
Schema_builtin.iter_builtin (* register built-in types *) targetNamespace_prefix <-
(fun st_def -> namespace_manager#lookup_or_add_namespace
let type_def = Simple st_def in targetNamespace_prefix (Utf8.get_str ns)
let name = name_of_type_definition type_def in | None -> ()
Hashtbl.replace typs name (ref type_def));
Hashtbl.replace typs (Utf8.mk "xsd:anyType") (ref AnyType); (** schemas namespaces handling *)
List.iter (* fill namespace manager *)
(fun (p, ns) -> method targetNamespace = match targetNamespace with
namespace_manager#add_namespace (Utf8.get_str p) (Utf8.get_str ns)) | None -> Ns.empty
Schema_xml.schema_ns_prefixes; | Some s -> Ns.mk s
List.iter (* qualify names of entities before registering them with defined
(fun (prefix,uri) -> * targetNamespace, if any *)
if prefix <> "" then begin method private qualify_name name =
Hashtbl.add orig_ns_prefixes prefix uri; match targetNamespace with
ignore (namespace_manager#lookup_or_add_namespace prefix uri)
end)
(_namespaces root);
match _may_attr "targetNamespace" root with
| Some ns ->
targetNamespace <- Some ns;
targetNamespace_prefix <-
namespace_manager#lookup_or_add_namespace
targetNamespace_prefix (Utf8.get_str ns)
| None -> ()
(** schemas namespaces handling *)
method targetNamespace =
match targetNamespace with
| None -> Ns.empty
| Some s -> Ns.mk s
(* qualify names of entities before registering them with defined
* targetNamespace, if any *)
method private qualify_name name =
match targetNamespace with
| None -> name | None -> name
| Some _ -> (Utf8.mk (targetNamespace_prefix ^ ":")) ^^ name | Some _ -> (Utf8.mk (targetNamespace_prefix ^ ":")) ^^ name
(* resolve user references using our namespace manager *) (* resolve user references using our namespace manager *)
method private fix_namespace s = method private fix_namespace s =
match Ns.split_qname s with match Ns.split_qname s with
| "", base -> | "", base ->
(match targetNamespace with (match targetNamespace with
| None -> base | None -> base
| Some _ -> (Utf8.mk targetNamespace_prefix) ^^ (Utf8.mk ":") ^^ base) | Some _ -> (Utf8.mk targetNamespace_prefix) ^^ (Utf8.mk ":") ^^ base)
| prefix, base -> | prefix, base ->
(try (try
let orig_uri = Hashtbl.find orig_ns_prefixes prefix in let orig_uri = Hashtbl.find orig_ns_prefixes prefix in
let new_prefix = namespace_manager#get_normprefix orig_uri in let new_prefix = namespace_manager#get_normprefix orig_uri in
(Utf8.mk new_prefix) ^^ (Utf8.mk ":") ^^ base (Utf8.mk new_prefix) ^^ (Utf8.mk ":") ^^ base
with Not_found -> with Not_found ->
validation_error ("Can't resolve: " ^ Utf8.get_str s)) validation_error ("Can't resolve: " ^ Utf8.get_str s))
(** seen nodes accounting *) (** seen nodes accounting *)
method already_seen n = NodeSet.mem n seen_nodes method already_seen n = NodeSet.mem n seen_nodes
method see (n: node) = method see (n: node) =
debug_print "lazy_resolver.see"; debug_print "lazy_resolver.see";
if NodeSet.mem n seen_nodes then if NodeSet.mem n seen_nodes then
validation_error (sprintf "Types/Elements loop (line: %d)" (_line n)) validation_error (sprintf "Types/Elements loop (line: %d)" (_line n))
else else
seen_nodes <- NodeSet.add n seen_nodes seen_nodes <- NodeSet.add n seen_nodes
method private find_global_component tag_pred name = method private find_global_component tag_pred name =
let basename = Utf8.get_str (snd (Ns.split_qname name)) in let basename = Utf8.get_str (snd (Ns.split_qname name)) in
_find (fun n -> (_has_tag n tag_pred) && (_is_attr "name" n basename) _find (fun n -> (_has_tag n tag_pred) && (_is_attr "name" n basename)) root
) root
(** registration of global entities *) (** registration of global entities *)
method register_typ name def = method register_typ name def =
......
let debug = false let debug = false
open Printf open Printf
...@@ -11,17 +10,14 @@ open Value ...@@ -11,17 +10,14 @@ open Value
(** {2 Misc} *) (** {2 Misc} *)
let empty_string = Value.string_utf8 (Utf8.mk "") let empty_string = string_utf8 (Utf8.mk "")
let empty_record = Value.vrecord [] let empty_record = Value.vrecord []
let foo_atom = Value.Atom (Atoms.V.mk_ascii "foo") let foo_atom = Value.Atom (Atoms.V.mk_ascii "foo")
let foo_event = E_char_data (Utf8.mk "") let foo_event = E_char_data (Utf8.mk "")
let hashtbl_is_empty tbl = let hashtbl_is_empty tbl =
let empty = ref true in try Hashtbl.iter (fun _ _ -> raise Exit) tbl; true
(try with Exit -> false
Hashtbl.iter (fun _ _ -> empty := false; raise Exit) tbl
with Exit -> ());
!empty
let string_of_value value = let string_of_value value =
let buf = Buffer.create 1024 in let buf = Buffer.create 1024 in
...@@ -192,38 +188,33 @@ let rec validate_simple_type def v = ...@@ -192,38 +188,33 @@ let rec validate_simple_type def v =
validation_error (sprintf "%s isn't a valid %s" validation_error (sprintf "%s isn't a valid %s"
(Utf8.to_string s) (Utf8.to_string name))) (Utf8.to_string s) (Utf8.to_string name)))
| Primitive _ -> assert false | Primitive _ -> assert false
| Derived (_, variety, facets, _) -> | Derived (_, variety, facets, base) ->
(match variety with (match variety with
| Atomic primitive -> | Atomic primitive ->
let validate_base = validate_simple_type primitive in
let literal = normalize_white_space (fst facets.whiteSpace) s in let literal = normalize_white_space (fst facets.whiteSpace) s in
(* pattern_valid facets.pattern literal; *) let value = validate_simple_type base(*primitive*)(*???*)
let value = validate_base (Value.string_utf8 literal) in (string_utf8 literal) in
Schema_facets.facets_valid facets value; Schema_facets.facets_valid facets value;
value value
| List item -> | List item ->
let validate_base = validate_simple_type item in
let literal = normalize_white_space (fst facets.whiteSpace) s in let literal = normalize_white_space (fst facets.whiteSpace) s in
(* pattern_valid facets.pattern literal; *)
let items = let items =
List.map validate_base List.map (validate_simple_type item)
(List.map Value.string_utf8 (split literal)) (List.map string_utf8 (split literal))
in in
let value = Value.sequence items in let value = Value.sequence items in
Schema_facets.facets_valid facets value; Schema_facets.facets_valid facets value;
value value
| Union members -> | Union members ->
let validate_members = let value = tries (List.map validate_simple_type members)
tries (List.map validate_simple_type members) validation_error_exemplar
validation_error_exemplar (string_utf8 s) in
in
let value = validate_members (Value.string_utf8 s) in
Schema_facets.facets_valid facets value; Schema_facets.facets_valid facets value;
value) value)
(* wrapper for validate_simple_type which works on contexts *) (* wrapper for validate_simple_type which works on contexts *)
let validate_simple_type_wrapper context st_def = let validate_simple_type_wrapper context st_def =
validate_simple_type st_def (Value.string_utf8 context#get_string) validate_simple_type st_def (string_utf8 context#get_string)
(** {2 Complex type validation} *) (** {2 Complex type validation} *)
...@@ -317,10 +308,9 @@ let rec validate_element (context: validation_context) elt = ...@@ -317,10 +308,9 @@ let rec validate_element (context: validation_context) elt =
element element
and validate_type context = function and validate_type context = function
| AnyType -> validate_any_type (context :> validation_context) | AnyType -> validate_any_type context
| Simple st_def -> (empty_record, validate_simple_type_wrapper context st_def) | Simple st_def -> (empty_record, validate_simple_type_wrapper context st_def)
| Complex ct_def -> | Complex ct_def -> validate_complex_type context ct_def
validate_complex_type (context :> validation_context) ct_def
(** @return Value.t * Value.t (* attrs, content *) *) (** @return Value.t * Value.t (* attrs, content *) *)
and validate_complex_type context ct = and validate_complex_type context ct =
......
open Schema_types open Schema_types
......
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