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

[r2005-02-22 01:19:25 by afrisch] Use Char*, not String*

Original author: afrisch
Date: 2005-02-22 01:19:25+00:00
parent 6bc3c3fc
......@@ -62,6 +62,9 @@ let concat v1 v2 =
| (Atom _, v) | (v, Atom _) -> v
| (v1,v2) -> Concat (v1,v2)
let append v1 v2 =
concat v1 (Pair (v2,nil))
let failwith' s = raise (CDuceExn (string_latin1 s))
let raise' v = raise (CDuceExn v)
......
......@@ -78,6 +78,7 @@ val map_xml : (U.t -> U.t) -> (t -> t) -> t -> t
val concat : t -> t -> t
val flatten : t -> t
val append : t -> t -> t
val get_string_latin1 : t -> string
......
......@@ -232,7 +232,7 @@ let validate_simple_type_wrapper context st_def =
let rec validate_any_type (context: validation_context) =
(* assumption: attribute events (if any) come first *)
let attrs = ref [] in
let cont = ref [] in
let cont = ref Value.nil in
let rec aux () =
match context#peek with
| E_start_tag qname ->
......@@ -242,16 +242,16 @@ let rec validate_any_type (context: validation_context) =
Value.Xml (Value.Atom (Atoms.V.of_qname qname), attrs, content)
in
context#expect_end_tag qname;
cont := element :: !cont;
cont := Value.append !cont element;
aux ()
| E_end_tag _ -> (Value.vrecord !attrs, Value.sequence (List.rev !cont))
| E_end_tag _ -> (Value.vrecord !attrs, !cont)
| E_attribute (qname, value) ->
context#junk;
attrs := (qname, Value.string_utf8 value) :: !attrs;
aux ()
| E_char_data utf8_data ->
context#junk;
cont := Value.string_utf8 utf8_data :: !cont;
cont := Value.concat !cont (string_utf8 utf8_data);
aux ()
in
aux ()
......@@ -329,30 +329,28 @@ and validate_type_ref context x =
(** @return Value.t * Value.t (* attrs, content *) *)
and validate_complex_type context ct =
let attrs = validate_attribute_uses context ct.ct_attrs in
let content = Value.sequence (validate_content_type context ct.ct_content) in
let content = validate_content_type context ct.ct_content in
(attrs, content)
(** @return Value.t list *)
and validate_content_type context content_type =
and validate_content_type context content_type : Value.t =
match content_type with
| CT_empty -> []
| CT_simple st_def -> [ validate_simple_type_wrapper context (get_simple_type st_def) ]
| CT_empty -> Value.nil
| CT_simple st_def -> Value.sequence [ validate_simple_type_wrapper context (get_simple_type st_def) ]
| CT_model (particle, mixed) ->
context#set_mixed mixed;
validate_particle context particle
(** @return Value.t list *)
and validate_particle context particle =
let (min, max, term, first) = particle in
let content = ref [] in
let push v = content := v :: !content in
let content = ref Value.nil in
let concat v = content := Value.concat !content v in
let rec validate_once ~cont_ok ~cont_failure =
match context#peek with
| E_start_tag qname when is_in_first qname first ->
List.iter push (validate_term context term);
concat (validate_term context term);
cont_ok ()
| E_char_data utf8_data when context#mixed ->
push (Value.string_utf8 utf8_data);
concat (string_utf8 utf8_data);
context#junk;
validate_once ~cont_ok ~cont_failure
| ev -> cont_failure ev
......@@ -380,7 +378,7 @@ and validate_particle context particle =
let rec trailing_cdata () =
match context#peek with
| E_char_data utf8_data ->
push (Value.string_utf8 utf8_data);
concat (string_utf8 utf8_data);
context#junk;
trailing_cdata ()
| _ -> ()
......@@ -389,24 +387,25 @@ and validate_particle context particle =
optional
(match max with None -> None | Some v -> Some (Intervals.V.sub v min));
if context#mixed then trailing_cdata ();
List.rev !content
!content
(** @return Value.t list *)
and validate_term context term =
match term with
| Elt elt_decl_ref -> [ validate_element context (Lazy.force elt_decl_ref) ]
| Model model_group -> validate_model_group context model_group
| Elt elt_decl_ref ->
sequence [ validate_element context (Lazy.force elt_decl_ref) ]
| Model model_group ->
validate_model_group context model_group
(** @return (Value.t list * Utf8.t)
(** @return (Value.t * Utf8.t)
* 2nd value is the key for tbl that return the particle effectively used for
* validation *)
and validate_choice context tbl =
let backlog = ref [] in
let push v = backlog := v :: !backlog in
let backlog = ref Value.nil in
let concat v = backlog := Value.concat !backlog v in
let rec next_tag () =
match context#peek with
| E_char_data utf8_data when context#mixed ->
push (Value.string_utf8 utf8_data);
concat (string_utf8 utf8_data);
context#junk;
next_tag ()
| E_char_data utf8_data (* when not context#mixed *) ->
......@@ -421,23 +420,23 @@ and validate_choice context tbl =
let qname = next_tag () in
try
let particle = QTable.find tbl qname in
((List.rev !backlog) @ (validate_particle context particle), qname)
(* BUG: should put the backlog back !!! *)
Value.concat !backlog (validate_particle context particle), qname
with Not_found ->
validation_error ~context (sprintf "Unexpected element %s"
(Ns.QName.to_string qname))
(** @return Value.t list *)
and validate_model_group context model_group =
match model_group with
| All particles ->
(* BUG: reorder ! *)
let tbl = ptbl_of_particles particles in
let contents = ref [] in
let contents = ref Value.nil in
let rec aux () =
if qtable_is_empty tbl then
List.concat (List.rev !contents)
if qtable_is_empty tbl then !contents
else begin
let (content, key) = validate_choice context tbl in
contents := content :: !contents;
contents := Value.concat !contents content;
QTable.remove tbl key;
aux ()
end
......@@ -446,7 +445,7 @@ and validate_model_group context model_group =
| Choice particles ->
fst (validate_choice context (ptbl_of_particles particles))
| Sequence particles ->
List.concat (List.map (validate_particle context) particles)
flatten (sequence (List.map (validate_particle context) particles))
(** {2 Context implementation} *)
......@@ -602,5 +601,5 @@ let validate_model_group { mg_def = mg } schema value =
"Only sequence values could be validated against model groups";
let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value)) in
Stream.junk stream;
Value.sequence (validate_model_group (new context ~stream ~schema) mg)
validate_model_group (new context ~stream ~schema) mg
......@@ -3,4 +3,5 @@
<elt1/>
<elt4/>
<elt3/>
<elt2/>
</all>
......@@ -1538,7 +1538,7 @@ module Schema_converter =
rexp (mk_len_regexp ~max:v base)
| _ -> rexp base
let pcdata = PStar (PElem (itype Builtin_defs.string))
let pcdata = PStar (PElem (itype (Types.char Chars.any)))
let mix_regexp regexp =
let rec aux = function
| PEpsilon -> PEpsilon
......
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