ns.ml 5.44 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
module U = Encodings.Utf8
let empty_str = U.mk ""

let split_qname s =
  let s = U.get_str s in
  try
    let i = String.index s ':' in
    let ns = String.sub s 0 i in
    let s = String.sub s (i + 1) (String.length s - i - 1) in
    (ns, U.mk s)
  with Not_found -> 
    ("", U.mk s)


include Pool.Make(U)
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")

module Table = Map.Make(U)

type table = t Table.t

(* TODO: avoid re-inserting the same hint for the same
   namespace ==> otherwise memory leak with load_xml ... *)
let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)

let empty_table =
  Table.add empty_str empty (Table.add (U.mk "xml") xml_ns Table.empty)
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

type qname = t * U.t

exception UnknownPrefix of U.t
let map_prefix table pr =
  try Table.find pr table 
  with Not_found -> raise (UnknownPrefix pr)

let map_tag table tag =
  let pr, local = split_qname tag in
  map_prefix table (U.mk pr), local

let map_attr table n =
  let (pr,local) = split_qname n in
  (if pr="" then empty else map_prefix table (U.mk pr)), local

let att table ((pr,local),v) = 
  ((if pr="" then empty else map_prefix table (U.mk pr)), local), v

let process_start_tag table tag attrs =
  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 (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 (mk (U.mk v)) table in
	      aux table attrs rest
	  | x ->
	      aux table ((x,U.mk v)::attrs) rest in
  aux table [] attrs



(* TODO: harmonize pretty-printing of values and of XML documents *)

  let prefixes_to_ns = State.ref "Ns.prefixes" (Hashtbl.create 63)
  let ns_to_prefixes = State.ref "Ns.prefixes" (Hashtbl.create 63)

  let register_prefix p ns =
    if (Hashtbl.mem !prefixes_to_ns p) || 
       (Hashtbl.mem !ns_to_prefixes ns) 
    then ()
    else ( Hashtbl.add !ns_to_prefixes ns p;
	   Hashtbl.add !prefixes_to_ns p ns )

  let counter = State.ref "Ns.prefixes" 0

  let rec fresh_prefix () =
    incr counter;
    let s = U.mk (Printf.sprintf "ns%i" !counter) in
    if (Hashtbl.mem !prefixes_to_ns s) then fresh_prefix () else s

  let prefix ns =
    try Hashtbl.find !ns_to_prefixes ns
    with Not_found ->
      let p = fresh_prefix () in
      register_prefix p ns;
      p

  let dump_prefix_table ppf =
    Hashtbl.iter
      (fun ns p ->
	 Format.fprintf ppf "%a=>%a@." U.print p U.print (value ns))
      !ns_to_prefixes

  let _ = register_prefix empty_str empty


let print_prefix ppf ns =
  if ns == empty then () else
    Format.fprintf ppf "%a:" U.print (prefix ns)

let print_qname ppf (ns,x)  = 
  Format.fprintf ppf "%a%a" print_prefix ns U.print x


module Printer = struct
(* TODO: detect the case when there is no unqualified tag.
   In this case, it is possible to use a default namespace for
   the whole document... *)


  type slot = Hint of U.t list | Set of U.t

  type printer = {
    mutable ns_to_prefix : slot array;
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

  let ensure p ns =
    let l = Array.length p.ns_to_prefix in
    if ns >= l then
      let a = Array.create (ns + 1 + 2 * l) (Hint []) in
      Array.blit p.ns_to_prefix 0 a 0 l;
      p.ns_to_prefix <- a
 
  let printer table =
    let p = 
      { ns_to_prefix = [| |];
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
    ensure p empty;
    p.ns_to_prefix.(empty) <- Set empty_str;
    Table.iter 
      (fun pr ns ->
	 ensure p ns;
	 if (U.get_str pr <> "") then
	   match p.ns_to_prefix.(ns) with
	     | Hint l -> p.hints <- pr::p.hints; p.ns_to_prefix.(ns) <- Hint (pr::l)
	     | _ -> assert false)  table;
    p


  let is_prefix_free p pr =
    not (List.exists (fun (pr',_) -> U.equal pr pr') p.prefixes)

  let is_really_free p pr =
    (is_prefix_free p pr) &&
     not (List.exists (fun pr' -> U.equal pr pr') p.hints)

  let rec fresh_prefix p =
    p.counter <- succ p.counter;
    let s = U.mk (Printf.sprintf "ns%i" p.counter) in
    if (is_really_free p s) then s else fresh_prefix p

  let gen = ref 0
  let find_good_prefix p ns hint =
    try List.find (is_prefix_free p) hint
    with Not_found -> 
      try List.find (is_really_free p) (Hashtbl.find_all !global_hints ns)
      with Not_found -> fresh_prefix p

  let add_prefix p pr ns =
    if (ns != empty) || (U.get_str pr <> "")
    then p.prefixes <- (pr, ns) :: p.prefixes

  let register_tag p (ns,_) =
     ensure p ns;
    match p.ns_to_prefix.(ns) with
      | Hint l ->
	  let pr = find_good_prefix p ns l in
	  p.ns_to_prefix.(ns) <- Set pr;
	  add_prefix p pr ns
      | Set _ -> ()

  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
    match p.ns_to_prefix.(ns) with
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then (U.get_str l)
          else pr ^ ":" ^ (U.get_str l)
      | _ -> assert false

  let attr p (ns,l) =
    if ns == empty then (U.get_str l)
    else
      match p.ns_to_prefix.(ns) with
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
end