ns.ml 5.95 KB
Newer Older
1
(* TODO:
2 3 4
   special treatment of prefixes xml and xmlns.
   Disallow: namespace xml="..."
*)
5

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


20 21
module P = Pool.Make(U)
include P
22 23
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
24
let mk_ascii s = mk (U.mk s)
25 26 27 28 29

module Table = Map.Make(U)

type table = t Table.t

30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
let serialize_table s table =
  Table.iter 
    (fun prefix ns ->
       Serialize.Put.bool s true;
       U.serialize s prefix;
       P.serialize s ns
    ) table;
  Serialize.Put.bool s false

let deserialize_table s =
  let rec aux table =
    if not (Serialize.Get.bool s) then table
    else
      let prefix = U.deserialize s in
      let ns = P.deserialize s in
      aux (Table.add prefix ns table) 
  in
  aux Table.empty


50 51 52 53 54 55 56 57 58 59
(* 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

60 61 62 63 64 65 66
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

67 68
type qname = t * U.t

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
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
111
  module H = Hashtbl.Make(P)
112 113

  type printer = {
114
    ns_to_prefix : slot ref H.t;
115 116 117 118 119 120
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

121 122 123 124 125 126 127
  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

128 129
  let printer table =
    let p = 
130
      { ns_to_prefix = H.create 63;
131 132 133 134 135
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
136
    H.add p.ns_to_prefix empty (ref (Set empty_str));
137 138 139
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
140 141 142 143
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
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
	     | _ -> 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

170
  let register_ns p ns = 
171 172
    if ns == xml_ns then ()
    else match get_prefix p ns with
173
      | { contents = Hint l } as r ->
174
	  let pr = find_good_prefix p ns l in
175
	  r := Set pr;
176
	  add_prefix p pr ns
177
      | _ -> ()
178

179
  let register_tag p (ns,_) = register_ns p ns
180 181 182 183 184
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
185 186
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else match !(get_prefix p ns) with
187 188 189 190 191 192 193
      | 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) =
194 195
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else if ns == empty then (U.get_str l)
196
    else
197
      match !(get_prefix p ns) with
198 199 200 201 202
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
203 204 205


  let any_ns p ns =
206
    match !(get_prefix p ns) with
207 208 209 210 211
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
212
end
213 214 215 216


module InternalPrinter =
struct
217
  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
218 219 220 221

  let set_table t = 
    p := Printer.printer t

222 223 224
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239

  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
240 241 242 243 244 245 246

module QName = struct
  include Custom.Pair(P)(U)
  let to_string x = InternalPrinter.attr x
  let print ppf x = Format.fprintf ppf "%s" (to_string x)
  let dump = print
end