Add load_xml_subst and print_xml_subst for namespaces substitution.

misc/ns.ml

@@ -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
+
 
 
 

misc/ns.mli

@@ -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

runtime/load_xml.ml

@@ -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;

runtime/load_xml.mli

 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
 
 

runtime/print_xml.ml

@@ -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

runtime/print_xml.mli

 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