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

6
7
8
9
10
11
12
13
14
15
16
17
18
19
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)


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


28
let mk_ascii s = mk (U.mk s)
29
30
31
32
33

module Table = Map.Make(U)

type table = t Table.t

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
let serialize_table s table =
  Table.iter 
    (fun prefix ns ->
       Serialize.Put.bool s true;
       U.serialize s prefix;
       P.serialize s ns
    ) table;
  Serialize.Put.bool s false

let deserialize_table s =
  let rec aux table =
    if not (Serialize.Get.bool s) then table
    else
      let prefix = U.deserialize s in
      let ns = P.deserialize s in
      aux (Table.add prefix ns table) 
  in
  aux Table.empty


54
55
56
57
58
(* 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)

let empty_table =
59
60
61
62
63
  List.fold_left
    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
    Table.empty
    ["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
     
64
65
66
67
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

68
69
70
71
72
73
74
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

75
76
type qname = t * U.t

77
78
79



80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
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
119
  module H = Hashtbl.Make(P)
120
121

  type printer = {
122
    ns_to_prefix : slot ref H.t;
123
124
125
126
127
128
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

129
130
131
132
133
134
135
  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

136
137
  let printer table =
    let p = 
138
      { ns_to_prefix = H.create 63;
139
140
141
142
143
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
144
    H.add p.ns_to_prefix empty (ref (Set empty_str));
145
146
147
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
148
149
150
151
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
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
	     | _ -> 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

178
  let register_ns p ns = 
179
180
    if ns == xml_ns then ()
    else match get_prefix p ns with
181
      | { contents = Hint l } as r ->
182
	  let pr = find_good_prefix p ns l in
183
	  r := Set pr;
184
	  add_prefix p pr ns
185
      | _ -> ()
186

187
  let register_tag p (ns,_) = register_ns p ns
188
189
190
191
192
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
193
194
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else match !(get_prefix p ns) with
195
196
197
198
199
200
201
      | 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) =
202
203
    if ns == xml_ns then "xml:" ^ (U.get_str l)
    else if ns == empty then (U.get_str l)
204
    else
205
      match !(get_prefix p ns) with
206
207
208
209
210
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
211
212
213


  let any_ns p ns =
214
    match !(get_prefix p ns) with
215
216
217
218
219
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
220
end
221
222
223
224


module InternalPrinter =
struct
225
  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
226
227
228
229

  let set_table t = 
    p := Printer.printer t

230
231
232
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

  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
248
249
250
251
252
253
254

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