Commit 253d89fd authored by Jérôme Maloberti's avatar Jérôme Maloberti

Add load_xml_subst and print_xml_subst for namespaces substitution.

parent c5e3c464
......@@ -31,6 +31,7 @@ let xml_ns = Uri.mk (U.mk xml_ns_str)
let xsd_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema")
let xsi_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
module H = Hashtbl.Make(Uri)
......@@ -67,7 +68,6 @@ module Printer = struct
type slot = Hint of U.t list | Set of U.t
module H = Hashtbl.Make(Uri)
type printer = {
ns_to_prefix : slot ref H.t;
......@@ -282,6 +282,26 @@ let process_start_tag table tag attrs =
aux table ((x,U.mk v)::attrs) rest in
aux table [] attrs
let process_start_tag_subst table tag attrs subst_hash =
let real_ns ns =
if H.mem subst_hash ns then H.find subst_hash ns
else ns in
let rec aux (table : table) (attrs : ((string * U.t) * U.t) list) = function
| [] -> (table, map_tag table (U.mk tag), List.rev_map (att table) attrs)
| ("xmlns",uri)::rest ->
let table = add_prefix empty_str (real_ns (Uri.mk (U.mk uri)))
table in
aux table attrs rest
| (n,v)::rest ->
match split_qname (U.mk n) with
| ("xmlns",pr) ->
let table = add_prefix pr (real_ns (Uri.mk (U.mk v)))
table in
aux table attrs rest
| x ->
aux table ((x,U.mk v)::attrs) rest in
aux table [] attrs
......
......@@ -56,6 +56,10 @@ val process_start_tag:
table -> string -> (string * string) list ->
table * QName.t * (Label.t * Utf8.t) list
val process_start_tag_subst:
table -> string -> (string * string) list ->
Uri.t Hashtbl.Make(Uri).t -> table * QName.t * (Label.t * Utf8.t) list
val map_tag: table -> Utf8.t -> QName.t
val map_attr: table -> Utf8.t -> QName.t
val map_prefix: table -> Utf8.t -> Uri.t
......
......@@ -5,6 +5,8 @@ open Ident
open Encodings
let keep_ns = ref true
module H = Hashtbl.Make(Ns.Uri)
let subst_ns = H.create 10
type buf =
{ mutable buffer : string;
......@@ -73,7 +75,8 @@ let start_element_handler name att =
stack := String (String.sub txt.buffer 0 txt.pos, !stack);
txt.pos <- 0;
let (table,name,att) = Ns.process_start_tag !ns_table name att in
let (table,name,att) = Ns.process_start_tag_subst !ns_table name
att subst_ns in
stack := Start (table,Atoms.V.mk name,att,!ns_table, !stack);
ns_table := table
......@@ -92,6 +95,22 @@ let xml_parser = ref (fun s -> failwith "No XML parser available")
let load_xml ?(ns=false) s =
try
H.clear subst_ns;
keep_ns := ns;
!xml_parser s;
match !stack with
| Element (x,Empty) -> stack := Empty; x
| _ -> Value.failwith' "No XML stream to parse"
with e -> stack := Empty; txt.pos <-0;
match e with
| Ns.UnknownPrefix n -> Value.failwith'
("Unknown namespace prefix: " ^ (U.get_str n))
| e -> raise e
let load_xml_subst ?(ns=false) s subst =
H.clear subst_ns;
List.iter (fun (k,v) -> H.replace subst_ns k v) subst;
try
keep_ns := ns;
!xml_parser s;
......
val load_xml: ?ns:bool -> string -> Value.t
val load_xml_subst: ?ns:bool -> string ->
(Ns.Uri.t * Ns.Uri.t) list -> Value.t
val load_html: string -> Value.t
......
......@@ -55,6 +55,7 @@ let write_data_string ~to_enc buf s =
open Value
open Ident
module U = Encodings.Utf8
module H = Hashtbl.Make(Ns.Uri)
let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.V.mk_ascii "Invalid_argument"),
......@@ -94,7 +95,7 @@ and schema_values ~wds ~wcs v =
schema_values ~wds ~wcs tl
| _ -> raise exn_print_xml
let to_buf ~utf8 buffer ns_table v =
let to_buf ~utf8 buffer ns_table v subst =
let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
let printer = Ns.Printer.printer ns_table in
......@@ -183,15 +184,29 @@ let to_buf ~utf8 buffer ns_table v =
| Atom a when a = Sequence.nil_atom -> ()
| v -> schema_value ~wds ~wcs v
in
let uri_subst prefixes replace =
let h = H.create 10 in
List.iter (fun (k,v) -> H.replace h k v) replace;
List.map (fun (pr,ns) -> if H.mem h ns then (pr,H.find h ns) else
(pr,ns)) prefixes
in
document_start ();
print_elt (Ns.Printer.prefixes printer) v
match subst with
[] -> print_elt (Ns.Printer.prefixes printer) v
| _ -> print_elt (uri_subst (Ns.Printer.prefixes printer) subst) v
let print_xml ~utf8 ns_table s =
let buf = Buffer.create 32 in
to_buf ~utf8 (Buffer.add_string buf) ns_table s;
to_buf ~utf8 (Buffer.add_string buf) ns_table s [];
let s = Buffer.contents buf in
if utf8 then string_utf8 (U.mk s) else string_latin1 s
let print_xml_subst ~utf8 ns_table s subst =
let buf = Buffer.create 32 in
to_buf ~utf8 (Buffer.add_string buf) ns_table s subst;
let s = Buffer.contents buf in
if utf8 then string_utf8 (U.mk s) else string_latin1 s
let dump_xml ~utf8 ns_table s =
to_buf ~utf8 print_string ns_table s;
to_buf ~utf8 print_string ns_table s [];
Value.nil
val print_xml: utf8:bool -> Ns.table -> Value.t -> Value.t
val dump_xml: utf8:bool -> Ns.table -> Value.t -> Value.t
val print_xml_subst: utf8:bool -> Ns.table -> Value.t ->
(Ns.Uri.t * Ns.Uri.t) list -> Value.t
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