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
module P = Upool.Make(U)
25
include P
26

27 28
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
29 30 31 32
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")


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

module Table = Map.Make(U)

type table = t Table.t

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

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

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

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


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

113 114

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


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

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

132 133
type qname = t * U.t

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

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

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

193 194
  let printer table =
    let p = 
195
      { ns_to_prefix = H.create 63;
196 197 198 199 200
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
201
    H.add p.ns_to_prefix empty (ref (Set empty_str));
202 203 204
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
205 206 207 208
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
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 234
	     | _ -> 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

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

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

  let prefixes p = p.prefixes

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


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


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

  let set_table t = 
    p := Printer.printer t

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

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

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