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