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