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