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

Original author: afrisch
Date: 2005-02-17 13:35:50+00:00

schema/schema_builtin.mli

-
 open Encodings
 
 (** all schema simple type names used in this API are prefixed with

schema/schema_common.ml

@@ -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
 

schema/schema_parser.ml

@@ -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 =

schema/schema_validator.ml

-
 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 =

schema/schema_validator.mli

-
 open Schema_types