ns.ml 7.56 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 = Upool.Make(U)
(* module P = Pool.Make(U) *)
26
include P
27 28 29


let value = get
30 31
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
32 33 34 35
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")


36
let mk_ascii s = mk (U.mk s)
37 38 39 40 41

module Table = Map.Make(U)

type table = t Table.t

42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
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
  
63 64 65 66 67 68 69 70 71 72 73 74
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

75 76 77
let ser_prop =
  Serialize.Put.mk_property (fun t -> (ref 0, TableHash.create 17))

78
let serialize_table s table =
79 80 81 82 83 84 85 86 87 88 89 90 91 92
  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 [||])
93 94

let deserialize_table s =
95 96 97 98 99 100 101 102 103 104 105 106 107
  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
108
  in
109
  mk_table p
110 111


112 113 114 115
(* 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)

116 117

let def_table =
118 119
  List.fold_left
    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
120 121 122 123
    empty_table
    ["xsd", xsd_ns; "xsi", xsi_ns]


124 125 126 127
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

128 129 130 131 132 133 134
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

135 136
type qname = t * U.t

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
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
179
  module H = Hashtbl.Make(P)
180 181

  type printer = {
182
    ns_to_prefix : slot ref H.t;
183 184 185 186 187 188
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

189 190 191 192 193 194 195
  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

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

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

247
  let register_tag p (ns,_) = register_ns p ns
248 249 250 251 252
  let register_attr = register_tag

  let prefixes p = p.prefixes

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


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


module InternalPrinter =
struct
285
  let p = State.ref "Ns.InternalPrinter" (Printer.printer def_table)
286 287 288 289

  let set_table t = 
    p := Printer.printer t

290 291 292
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307

  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
308 309 310 311 312 313 314

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