ns.ml 6.15 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 25 26 27
let xsd_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema")
let xsi_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")


28
let mk_ascii s = mk (U.mk s)
29 30 31 32 33

module Table = Map.Make(U)

type table = t Table.t

34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
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


54 55 56 57 58
(* 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 =
59 60 61 62 63
  List.fold_left
    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
    Table.empty
    ["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
     
64 65 66 67
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

68 69 70 71 72 73 74
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

75 76
type qname = t * U.t

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
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
119
  module H = Hashtbl.Make(P)
120 121

  type printer = {
122
    ns_to_prefix : slot ref H.t;
123 124 125 126 127 128
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

129 130 131 132 133 134 135
  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

136 137
  let printer table =
    let p = 
138
      { ns_to_prefix = H.create 63;
139 140 141 142 143
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
144
    H.add p.ns_to_prefix empty (ref (Set empty_str));
145 146 147
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
148 149 150 151
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
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
	     | _ -> 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

178
  let register_ns p ns = 
179 180
    if ns == xml_ns then ()
    else match get_prefix p ns with
181
      | { contents = Hint l } as r ->
182
	  let pr = find_good_prefix p ns l in
183
	  r := Set pr;
184
	  add_prefix p pr ns
185
      | _ -> ()
186

187
  let register_tag p (ns,_) = register_ns p ns
188 189 190 191 192
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
193 194
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else match !(get_prefix p ns) with
195 196 197 198 199 200 201
      | 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) =
202 203
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else if ns == empty then (U.get_str l)
204
    else
205
      match !(get_prefix p ns) with
206 207 208 209 210
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
211 212 213


  let any_ns p ns =
214
    match !(get_prefix p ns) with
215 216 217 218 219
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
220
end
221 222 223 224


module InternalPrinter =
struct
225
  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
226 227 228 229

  let set_table t = 
    p := Printer.printer t

230 231 232
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247

  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
248 249 250 251 252 253 254

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