ns.ml 5.15 KB
Newer Older
1 2 3
(* TODO:
   special treatment of prefixes xml and xmlns *)

4 5 6 7 8 9 10 11 12 13 14 15 16 17
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)


18 19
module P = Pool.Make(U)
include P
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
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

37 38 39 40 41 42 43
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

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


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
85
  module H = Hashtbl.Make(P)
86 87

  type printer = {
88
    ns_to_prefix : slot ref H.t;
89 90 91 92 93 94
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

95 96 97 98 99 100 101
  let get_prefix p ns =
    try H.find p.ns_to_prefix ns
    with Not_found ->
      let r = ref (Hint []) in
      H.add p.ns_to_prefix ns r;
      r

102 103
  let printer table =
    let p = 
104
      { ns_to_prefix = H.create 63;
105 106 107 108 109
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
110
    H.add p.ns_to_prefix empty (ref (Set empty_str));
111 112 113
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
114 115 116 117
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
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
	     | _ -> 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 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

144
  let register_ns p ns = 
145 146
    match get_prefix p ns with
      | { contents = Hint l } as r ->
147
	  let pr = find_good_prefix p ns l in
148
	  r := Set pr;
149
	  add_prefix p pr ns
150
      | _ -> ()
151

152
  let register_tag p (ns,_) = register_ns p ns
153 154 155 156 157
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
158
    match !(get_prefix p ns) with
159 160 161 162 163 164 165 166 167
      | 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
168
      match !(get_prefix p ns) with
169 170 171 172 173
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
174 175 176


  let any_ns p ns =
177
    match !(get_prefix p ns) with
178 179 180 181 182
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
183
end
184 185 186 187


module InternalPrinter =
struct
188
  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
189 190 191 192

  let set_table t = 
    p := Printer.printer t

193 194 195
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
196 197 198 199 200 201 202 203 204 205 206 207 208 209 210

  let tag x =
    Printer.register_tag !p x;
    Printer.tag !p x

  let attr x =
    Printer.register_attr !p x;
    Printer.attr !p x

  let dump ppf =
    List.iter
      (fun (pr, ns) ->
	 Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
      )	(Printer.prefixes !p)
end