[r2003-06-15 21:46:12 by cvscast] - added support for xsd:all term

- bugfix: empty content model now supported

- bugfix: reference to global attributes works zack

Original author: cvscast
Date: 2003-06-15 21:46:12+00:00

schema/schema_parser.ml

@@ -44,6 +44,21 @@ let content_type_of_def = function
   | C (CBuilt_in _) -> assert false
   | C (CUser_defined (_, _, _, _, _, ct)) -> ct
 
+  (* check xsd:all constraints *)
+let check_all_particle = function
+  | 1, Some 1, All particles ->
+      List.iter
+        (function
+          | _, Some 0, _ | _, Some 1, _ -> ()
+          | _, _, _ ->
+              raise (XSD_validation_error "all particles contained in a xsd:all
+                term must have maxOccurs = {0, 1}"))
+        particles
+  | _, _, All _ ->
+      raise (XSD_validation_error "xsd:all particles must have \
+        minOccurs = maxOccurs = 1")
+  | _, _, _ -> ()
+
 let parse_facet (resolver: resolver) base_type_def n =
   debug_print "Schema_parser.parse_facet"; 
   let validate_base_type =
@@ -168,7 +183,7 @@ let parse_att_decl (resolver: resolver) n =
       name, simple_type_def, constr
   | _ -> assert false (* you have to use parse_attribute_use *)
 
-  (** @return an attribute_use option. None means that the attribute is
+  (** @return a attribute_use option. None means that the attribute is
   prohibited *)
 let parse_attribute_use (resolver: resolver) n =
   debug_print "Schema_parser.parse_attribute_use"; 
@@ -212,13 +227,21 @@ let parse_attribute_use (resolver: resolver) n =
   (** @return a list of attribute uses from a xsd:restriction node wrt a base
   type definition *)
 let attribute_uses_of_restriction ~(resolver: resolver) ~n ~base =
+  (* BUG HERE *)
   let embedded =  (* associative list <name, attribute_use option> *)
     List.map
       (fun n ->
         let use = parse_attribute_use resolver n in
-        n#extension#name, use)
+        let name =
+          if n#extension#has_attribute "ref" then
+            n#extension#ref
+          else (* if n#extension#has_attribute "name" then *)
+            n#extension#name
+        in
+        name, use)
       n#extension#find_attributes
   in
+  (* /BUG HERE *)
   let from_base =
     match base with
     | C (CUser_defined (_, _, _, _, attribute_uses, _)) ->
@@ -314,8 +337,11 @@ let rec parse_complex_type (resolver: resolver) n =
               (try restriction#extension#mixed with Not_found -> false))
           in
           (try
-            CT_model
-              (parse_particle resolver restriction#extension#find_term, mixed)
+            let particle =
+              parse_particle resolver restriction#extension#find_term
+            in
+            check_all_particle particle;
+            CT_model (particle, mixed)
           with Not_found -> raise (XSD_validation_error "Can't find term"))
         end
       in
@@ -343,12 +369,17 @@ let rec parse_complex_type (resolver: resolver) n =
           ) in
           match base_ct with
           | CT_empty ->
-              CT_model (parse_particle resolver (Lazy.force term), mixed)
+              let particle = parse_particle resolver (Lazy.force term) in
+              check_all_particle particle;
+              CT_model (particle, mixed)
           | CT_model (p, _) ->
-              CT_model
-                ((1, Some 1,
-                  Sequence (p :: [parse_particle resolver (Lazy.force term)])),
-                mixed)
+              let base_particle = parse_particle resolver (Lazy.force term) in
+              (match base_particle with
+              | _, _, All _ ->
+                  raise (XSD_validation_error ("Can't extend a content model, \
+                    with an xsd:all particle"))
+              | _ -> ());
+              CT_model ((1, Some 1, Sequence (p :: [base_particle])), mixed)
           | CT_simple _ -> assert false
       in
       cuser_defined name !base Extension attribute_uses content_type
@@ -368,7 +399,9 @@ let rec parse_complex_type (resolver: resolver) n =
         CT_empty
       end else begin
         let mixed = false in
-        CT_model (parse_particle resolver n#extension#find_term, mixed)
+        let particle = parse_particle resolver n#extension#find_term in
+        check_all_particle particle;
+        CT_model (particle, mixed)
       end
     in
     cuser_defined name !base Restriction attribute_uses content_type
@@ -415,15 +448,25 @@ and parse_particle (resolver: resolver) n =
       minOccurs, maxOccurs, (Elt elt_decl)
   | T_element "xsd:all" ->
       minOccurs, maxOccurs,
-      All (List.map (parse_particle resolver) n#extension#find_terms)
+      All (parse_particles resolver n#extension#find_terms)
   | T_element "xsd:sequence" ->
       minOccurs, maxOccurs,
-      Sequence (List.map (parse_particle resolver) n#extension#find_terms)
+      Sequence (parse_particles resolver n#extension#find_terms)
   | T_element "xsd:choice" ->
       minOccurs, maxOccurs,
-      Choice (List.map (parse_particle resolver) n#extension#find_terms)
+      Choice (parse_particles resolver n#extension#find_terms)
   | _ -> assert false
 
+  (* as above but used for "embedded" particle lists; it additionally check that
+  the returned particle isn't an All one *)
+and parse_particles (resolver: resolver) nodes =
+  List.map
+    (fun n ->
+      match parse_particle resolver n with
+      | _, _, All _ ->
+          raise (XSD_validation_error "xsd:all particle can't appear here")
+      | p -> p)
+    nodes
 
 module OrderedNode =
   struct

schema/schema_validator.ml

@@ -15,12 +15,24 @@ module OrderedStringOption =
   (* used to encode content model's "first". None value encode "epsilon" *)
 module First = Set.Make (OrderedStringOption)
 
+  (* a pair: validation function from stream to CDuce values, a first (usual
+  FIRST construction on start tag names) *)
 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 *)
 
+module OrderedValidator =
+  struct
+    type t = bool * int * validator (* required, index, validator *)
+    let compare (_, _, (_, f1)) (_, _, (_, f2)) = First.compare f1 f2
+  end
+  (* used to perform xsd:all validation *)
+module ValidatorSet = Set.Make (OrderedValidator)
+
+let empty_validator = (fun _ -> Value.sequence []), First.singleton (None)
+
   (* wrap a function validating a string with a validator *)
 let pcdata_wrapper f = (fun stream -> f (Schema_xml.collect_pcdata stream))
 
@@ -160,10 +172,7 @@ let string_of_first ?(show_epsilon = false) first =
   String.concat ", " elts
 
 let rec validator_of_particle (min, max, (term: term)) =
-  assert (not ((min = 0) && (max = Some 0))); (* TODO empty CM *)
-  assert (min >= 0);
-  assert (match max with Some n -> (n >= 0) | _ -> true);
-  assert (max >>= min);
+  assert ((min >= 0) && (max >>= min));
   let validator = validator_of_term term in
   let term_first = snd validator in
   let first =
@@ -171,6 +180,7 @@ let rec validator_of_particle (min, max, (term: term)) =
     if min = 0 then First.add None old_first else old_first
   in
   match (min, max) with
+  | (0, Some 0) -> empty_validator
   | (min, Some max) ->
       (fun stream ->
         let content = ref [] in
@@ -206,10 +216,61 @@ let rec validator_of_particle (min, max, (term: term)) =
         Value.sequence (List.rev !content)),
       first
 
-and validator_of_term = function
-  | All [] | Choice [] | Sequence [] -> assert false  (* TODO empty CM *)
-  | All _ -> assert false (* TODO xsd:all *)
-  | Choice particles -> (* TODO UPA *)
+and validator_of_term =
+  let error first found =
+    raise (XSI_validation_error (sprintf "Expected one of: %s; found %s"
+      (string_of_first first) found))
+  in
+  function
+  | All [] | Choice [] | Sequence [] -> empty_validator
+  | All particles ->  (* assumption: maxOccurs = {0,1} *)
+      let validators =
+        snd (List.fold_left
+          (fun (idx, acc) p ->
+            match p with
+            | 0, Some 1, _ | 0, Some 0, _ ->
+                (idx + 1,
+                ValidatorSet.add (false, idx, validator_of_particle p) acc)
+            | 1, Some 1, _ ->
+                (idx + 1,
+                ValidatorSet.add (true, idx, validator_of_particle p) acc)
+            | _ -> assert false)
+          (0, ValidatorSet.empty) particles)
+      in
+      let len = ValidatorSet.cardinal validators in
+      let first =
+        ValidatorSet.fold (fun (_, _, (_, f)) acc -> First.union f acc)
+          validators First.empty
+      in
+      (fun stream ->
+        let values = Array.make len Value.Absent in
+        let validators = ref validators in
+        (try
+          while true do
+            let next = peek_start_tag stream in
+            let (_, idx, validator) as elt = (* assumption: UPA *)
+              ValidatorSet.choose (ValidatorSet.filter
+                (fun (_, _, (_, f)) -> First.mem (Some next) f) !validators)
+            in
+            validators := ValidatorSet.remove elt !validators;
+            values.(idx) <- validate ~validator stream
+          done
+        with
+        | Not_found (* raised by "choose" *) | Not_a_start_tag _ -> ());
+        let missing =
+          ValidatorSet.filter (fun (req, _, _) -> req) !validators
+        in
+        if not (ValidatorSet.is_empty missing) then
+          raise (XSI_validation_error ("incomplete xsd:all particle content, \
+            expected (at least): " ^
+            (string_of_first (match ValidatorSet.choose !validators with
+            | _, _, (_, f) -> f))));
+        Value.sequence (List.filter ((<>) Value.Absent)
+          (Array.to_list values))),
+      first
+
+  | Choice particles ->
+      (* TODO UPA *)
       let p_validators = List.map validator_of_particle particles in
       let find_validator name = (* find the validation function for a given
                                 element *)
@@ -225,16 +286,15 @@ and validator_of_term = function
           p_validators
       in
       (fun stream ->
-        let error found =
-          raise (XSI_validation_error (sprintf "Expected one of: %s; \
-            found %s" (string_of_first first) found))
-        in
         let next =
           try
             peek_start_tag stream
-          with Not_a_start_tag ev -> error (Schema_xml.string_of_pxp_event ev)
+          with Not_a_start_tag ev ->
+            error first (Schema_xml.string_of_pxp_event ev)
+        in
+        let validator =
+          try find_validator next with Not_found -> error first next
         in
-        let validator = try find_validator next with Not_found -> error next in
         validate ~validator stream),
       first
   | Sequence particles ->

typing/typer.ml

@@ -1030,14 +1030,12 @@ module Schema_converter =
     let complex_memo = Hashtbl.create 213
 
     let rec regexp_of_term = function
-      | All _ -> assert false
-      | Choice [] -> PEpsilon
+      | All [] | Choice [] | Sequence [] -> PEpsilon
       | Choice (hd :: tl) ->
           List.fold_left
             (fun acc particle -> PAlt (acc, regexp_of_particle particle))
             (regexp_of_particle hd) tl
-      | Sequence [] -> PEpsilon
-      | Sequence (hd :: tl) ->
+      | All (hd :: tl) | Sequence (hd :: tl) ->
           List.fold_left
             (fun acc particle -> PSeq (acc, regexp_of_particle particle))
             (regexp_of_particle hd) tl