Commit 3e3d3a2a authored by Pietro Abate's avatar Pietro Abate

- experimental support for cdata sections

parent 9a5ab37e
......@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *)
let rec schema_value ?(recurs=true) ~wds v = match v with
| Abstract ("float",f) ->
wds (U.mk (string_of_float (Obj.magic f : float)))
let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
| Abstract ("float",o) ->
wds (U.mk (string_of_float (Obj.magic o : float)))
| Abstract ("cdata",o) ->
wcs (U.mk "<![CDATA[");
wcs (U.mk (U.get_str (Obj.magic o : U.t)));
wcs (U.mk "]]>")
| Record _ as v ->
(try
wds (Schema_builtin.string_of_time_type (Value.get_fields v))
......@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
| Integer i -> wds (U.mk (Intervals.V.to_string i))
| v when Value.equal v Value.vtrue -> wds true_literal
| v when Value.equal v Value.vfalse -> wds false_literal
| Pair _ as v when recurs -> schema_values ~wds v
| Pair _ as v when recurs -> schema_values ~wds ~wcs v
| String_utf8 _ | String_latin1 _ as v -> wds (fst (get_string_utf8 v))
| _ -> raise exn_print_xml
and schema_values ~wds v =
and schema_values ~wds ~wcs v =
match v with
| Pair (hd, Atom a) when a = Sequence.nil_atom ->
schema_value ~recurs:false ~wds hd
schema_value ~recurs:false ~wds ~wcs hd
| Pair (hd, tl) ->
schema_value ~recurs:false ~wds hd;
schema_value ~recurs:false ~wds ~wcs hd;
wds blank;
schema_values ~wds tl
schema_values ~wds ~wcs tl
| _ -> raise exn_print_xml
let to_buf ~utf8 buffer ns_table v =
......@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
let wms = write_markup_string ~to_enc buffer
and wds s = write_data_string ~to_enc buffer (U.get_str s)
and wcs s = buffer (U.get_str s) in
in
let write_att (n,v) =
wms (" " ^ (Ns.Printer.attr printer (Label.value n)) ^ "=\""); wds v; wms "\"" in
......@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
end else begin
let buf = Buffer.create 20 in
let wds s = Buffer.add_string buf (U.get_str s) in
schema_value ~wds v;
schema_value ~wds ~wcs:wds v;
(Label.from_int n, U.mk (Buffer.contents buf))
end
) attrs in
......@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
match q with
| Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> ()
| v -> schema_value ~wds v
| v -> schema_value ~wds ~wcs v
in
document_start ();
print_elt (Ns.Printer.prefixes printer) v
......
......@@ -284,6 +284,11 @@ let rec print ppf v =
Format.fprintf ppf "<concat:%a;%a>" print x print y
| Abstract ("float",o) ->
Format.fprintf ppf "%f" (Obj.magic o : float)
| Abstract ("cdata",o) ->
let s = Utf8.get_str (Obj.magic o : Utf8.t) in
Format.fprintf ppf "'%s'" s
(* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
* Encodings.Utf8.t)) *)
| Abstract (s,_) ->
Format.fprintf ppf "<abstract=%s>" s
| Absent ->
......@@ -417,8 +422,12 @@ let rec compare x y =
raise (CDuceExn (string_latin1 "comparing functional values"))
| Abstract (s1,v1), Abstract (s2,v2) ->
let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c
else Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
(* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
else begin
match s1 with
|"float" -> Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
|"cdata" -> Pervasives.compare (Obj.magic v1 : Encodings.Utf8.t) (Obj.magic v2 : Encodings.Utf8.t)
|_ -> raise (CDuceExn (string_latin1 "comparing abstract values"))
end
| Absent,_ | _,Absent ->
Format.fprintf Format.std_formatter
"ERR: Compare %a %a@." print x print y;
......@@ -713,6 +722,9 @@ let print_utf8 v =
let float n =
Abstract ("float", Obj.repr n)
let cdata n =
Abstract ("cdata", Obj.repr n)
let cduce2ocaml_option f v =
match normalize v with
| Pair (x,y) -> Some (f x)
......
......@@ -83,6 +83,7 @@ val flatten : t -> t
val append : t -> t -> t
val float: float -> t
val cdata: string -> t
val get_string_latin1 : t -> string
val get_string_utf8 : t -> U.t * t
......
......@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
Value.string_latin1 "namespaces"))
)
let exn_cdata_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "cdata_of"))
)
let eval_load_file ~utf8 e =
Cduce_loc.protect_op "load_file";
......@@ -439,3 +445,11 @@ register_fun "float_of" string float
let (s,_) = Value.get_string_utf8 v in
try Value.float (float_of_string (U.get_str s))
with Failure _ -> raise (Lazy.force exn_float_of));;
(* cdata *)
register_fun "cdata_of" string string
(fun v ->
let (s,_) = Value.get_string_utf8 v in
try Value.cdata (U.get_str s)
with Failure _ -> raise (Lazy.force exn_cdata_of));;
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