ns.ml 7.1 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
module U = Encodings.Utf8
let empty_str = U.mk ""

let split_qname s =
  let s = U.get_str s in
  try
12
    let i = String.rindex s ':' in
13
14
    let ns = String.sub s 0 i in
    let s = String.sub s (i + 1) (String.length s - i - 1) in
15
    (ns,U.mk s)
16
  with Not_found -> 
17
    ("",U.mk s)
18

19
20
21
let form_qname ns local =
  let ns' = U.get_str ns and local' = U.get_str local in
  if ns' = "" then local else U.mk (ns' ^ ":" ^ local')
22

23
24
25
26
module Uri = struct 
  include Upool.Make(U)
  let print ppf x = U.print ppf (value x)
end
27

28
29
30
31
32
let empty = Uri.mk empty_str
let xml_ns_str = "http://www.w3.org/XML/1998/namespace"
let xml_ns = Uri.mk (U.mk xml_ns_str)
let xsd_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema")
let xsi_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
33
34


35
36
37



38

39
40
41
module Table = Map.Make(U)
type table = Uri.t Table.t
    (* Tables prefix->uri *)
42

43
44
45
let mktbl = List.fold_left (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
let empty_table = mktbl Table.empty ["", empty; "xml", xml_ns]
let def_table = mktbl empty_table ["xsd", xsd_ns; "xsi", xsi_ns]
46
47

let mk_table =
48
49
50
51
52
53
54
55
56
  List.fold_left (fun table (pr,ns) -> Table.add pr ns table) empty_table
let get_table table =
  Table.fold 
    (fun prefix ns r -> 
       let std =
	 try Uri.equal (Table.find prefix empty_table) ns
	 with Not_found -> false in
       if std then r else (prefix,ns)::r) table []

57
58


59
60
(* TODO: avoid re-inserting the same hint for the same
   namespace ==> otherwise memory leak with load_xml ... *)
61
let global_hints = Hashtbl.create 63
62
63
64
65
66
67
68
69

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
70
  module H = Hashtbl.Make(Uri)
71
72

  type printer = {
73
    ns_to_prefix : slot ref H.t;
74
75
    mutable prefixes : (U.t * Uri.t) list;
    table : table;
76
    mutable hints : U.t list;
77
    mutable counter : int;
78
79
  }

80
81
82
83
84
85
86
  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

87
88
  let printer table =
    let p = 
89
      { ns_to_prefix = H.create 63;
90
91
92
93
94
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
95
    H.add p.ns_to_prefix empty (ref (Set empty_str));
96
97
    Table.iter 
      (fun pr ns ->
98
	 if (U.get_str pr <> "") && not (Uri.equal empty ns) then
99
100
101
102
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
	     | _ -> 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 -> 
122
      try List.find (is_really_free p) (Hashtbl.find_all global_hints ns)
123
124
125
126
127
128
      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

129
  let register_ns p ns = 
130
131
    if ns == xml_ns then ()
    else match get_prefix p ns with
132
      | { contents = Hint l } as r ->
133
	  let pr = find_good_prefix p ns l in
134
	  r := Set pr;
135
	  add_prefix p pr ns
136
      | _ -> ()
137

138
  let register_qname p (ns,_) = register_ns p ns
139
140
141
142

  let prefixes p = p.prefixes

  let tag p (ns,l) =
143
144
    let l = U.get_str l in
    if ns == xml_ns then "xml:" ^ l
145
    else match !(get_prefix p ns) with
146
147
      | Set pr ->
	  let pr = U.get_str pr in
148
149
	  if pr = "" then l
          else pr ^ ":" ^ l
150
151
152
      | _ -> assert false

  let attr p (ns,l) =
153
154
155
    let l = U.get_str l in
    if ns == xml_ns then "xml:" ^ l
    else if ns == empty then l
156
    else
157
      match !(get_prefix p ns) with
158
159
	| Set pr ->
	    let pr = U.get_str pr in
160
161
	    assert(pr <> "");
            pr ^ ":" ^ l
162
	| _ -> assert false
163
164
165


  let any_ns p ns =
166
    match !(get_prefix p ns) with
167
168
169
170
171
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
172
end
173
174
175
176


module InternalPrinter =
struct
177
  let p = ref (Printer.printer def_table)
178
179
180
181

  let set_table t = 
    p := Printer.printer t

182
183
184
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
185

186
187
188
  let tag q =
    Printer.register_qname !p q;
    Printer.tag !p q
189

190
191
192
  let attr q =
    Printer.register_qname !p q;
    Printer.attr !p q
193
194
195
196

  let dump ppf =
    List.iter
      (fun (pr, ns) ->
197
	 Format.fprintf ppf "%a=>\"%a\"@." U.print pr Uri.print ns
198
      )	(Printer.prefixes !p)
199
200
201
202
203
204
205
206
207

  let print_tag ppf q =
    Format.fprintf ppf "%s" (tag q)

  let print_attr ppf q =
    Format.fprintf ppf "%s" (attr q)

  let print_any_ns ppf ns =
    Format.fprintf ppf "%s" (any_ns ns)
208
end
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
235
236
237
238
239
240
241
242
module Label = struct
  include Upool.Make(Custom.Pair(Uri)(U))

  let print_attr ppf q = InternalPrinter.print_attr ppf (value q)
  let print_tag ppf q = InternalPrinter.print_tag ppf (value q)
  let print_quote ppf q = Format.fprintf ppf "`"; print_tag ppf q

  let string_of_attr q = InternalPrinter.attr (value q)
  let string_of_tag q = InternalPrinter.tag (value q)
(*
  let to_string s = U.to_string (value s)
  let print ppf s = U.print ppf (value s)
*)

  let mk_ascii s = mk (empty, U.mk s)
  let get_ascii q = U.get_str (snd (value q))
(*
  let split q =
    let ns,local = split_qname (value q) in
    U.mk ns, local
*)
end







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

243
244
245
let merge_tables t1 t2 =
  Table.fold add_prefix t2 t1

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr Uri.print ns
    ) table
       

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) = 
  Label.mk
    ((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 (Uri.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 (Uri.mk (U.mk v)) table in
	      aux table attrs rest
	  | x ->
	      aux table ((x,U.mk v)::attrs) rest in
  aux table [] attrs




288
module QName = struct
289
290
291
292
293
  include Custom.Pair(Uri)(U)
  let print = InternalPrinter.print_tag
(*  let mk_ascii s = (empty, U.mk s)
  let get_ascii (_,s) = U.get_str s *)
  let to_string = InternalPrinter.tag 
294
end
295