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