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

6 7 8 9
(* TODO:
   It is very important to hash-cons table when 
   serializing/deserializing code with many XmlNs literals ... *)

10 11 12 13 14 15 16 17 18 19 20 21 22 23
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)


24 25
module P = Pool.Make(U)
include P
26 27
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
28 29 30 31
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")


32
let mk_ascii s = mk (U.mk s)
33 34 35 36 37

module Table = Map.Make(U)

type table = t Table.t

38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
let empty_table =
  List.fold_left
    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
    Table.empty
    ["", empty; "xml", xml_ns]

module TableData = Custom.List(Custom.Pair(U)(U))
module TableHash = Hashtbl.Make(TableData)

let get_table table : TableData.t =
  Table.fold (fun prefix ns r -> 
		let std =
		  try equal (Table.find prefix empty_table) ns
		  with Not_found -> false in
		if std then r else (prefix,value ns)::r) table []

let mk_table =
  List.fold_left
    (fun table (pr,ns) -> Table.add pr (mk ns) table)
    empty_table
  
59 60 61 62 63 64 65 66 67 68 69 70
let get_table_ns table =
  Table.fold (fun prefix ns r -> 
		let std =
		  try equal (Table.find prefix empty_table) ns
		  with Not_found -> false in
		if std then r else (prefix,ns)::r) table []

let mk_table_ns =
  List.fold_left
    (fun table (pr,ns) -> Table.add pr ns table)
    empty_table

71 72 73
let ser_prop =
  Serialize.Put.mk_property (fun t -> (ref 0, TableHash.create 17))

74
let serialize_table s table =
75 76 77 78 79 80 81 82 83 84 85 86 87 88
  let (nb,tbl) = Serialize.Put.get_property ser_prop s in
  let p = get_table table in
  try
    let i = TableHash.find tbl p in
    Serialize.Put.int s i
  with Not_found ->
    let i = !nb in
    incr nb;
    TableHash.add tbl p i;
    Serialize.Put.int s i;
    TableData.serialize s p

let deser_prop =
  Serialize.Get.mk_property (fun t -> ref [||])
89 90

let deserialize_table s =
91 92 93 94 95 96 97 98 99 100 101 102 103
  let tbl = Serialize.Get.get_property deser_prop s in
  let i = Serialize.Get.int s in
  (if (i >= Array.length !tbl) then
     let ntbl = Array.create (2 * i + 10) None in
     Array.blit !tbl 0 ntbl 0 (Array.length !tbl);
     tbl := ntbl);
  let p = match !tbl.(i) with
    | None ->
	let p = TableData.deserialize s in
	(!tbl).(i) <- Some p;
	p
    | Some p ->
	p
104
  in
105
  mk_table p
106 107


108 109 110 111
(* 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)

112 113

let def_table =
114 115
  List.fold_left
    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
116 117 118 119
    empty_table
    ["xsd", xsd_ns; "xsi", xsi_ns]


120 121 122 123
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

124 125 126 127 128 129 130
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

131 132
type qname = t * U.t

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
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
175
  module H = Hashtbl.Make(P)
176 177

  type printer = {
178
    ns_to_prefix : slot ref H.t;
179 180 181 182 183 184
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

185 186 187 188 189 190 191
  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

192 193
  let printer table =
    let p = 
194
      { ns_to_prefix = H.create 63;
195 196 197 198 199
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
200
    H.add p.ns_to_prefix empty (ref (Set empty_str));
201 202 203
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
204 205 206 207
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
	     | _ -> 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

234
  let register_ns p ns = 
235 236
    if ns == xml_ns then ()
    else match get_prefix p ns with
237
      | { contents = Hint l } as r ->
238
	  let pr = find_good_prefix p ns l in
239
	  r := Set pr;
240
	  add_prefix p pr ns
241
      | _ -> ()
242

243
  let register_tag p (ns,_) = register_ns p ns
244 245 246 247 248
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
249 250
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else match !(get_prefix p ns) with
251 252 253 254 255 256 257
      | 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) =
258 259
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else if ns == empty then (U.get_str l)
260
    else
261
      match !(get_prefix p ns) with
262 263 264 265 266
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
267 268 269


  let any_ns p ns =
270
    match !(get_prefix p ns) with
271 272 273 274 275
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
276
end
277 278 279 280


module InternalPrinter =
struct
281
  let p = State.ref "Ns.InternalPrinter" (Printer.printer def_table)
282 283 284 285

  let set_table t = 
    p := Printer.printer t

286 287 288
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
289 290 291 292 293 294 295 296 297 298 299 300 301 302 303

  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
304 305 306 307 308 309 310

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