ns.ml 5.15 KB
Newer Older
1
2
3
(* TODO:
   special treatment of prefixes xml and xmlns *)

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


18
19
module P = Pool.Make(U)
include P
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")

module Table = Map.Make(U)

type table = t Table.t

(* 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 =
  Table.add empty_str empty (Table.add (U.mk "xml") xml_ns Table.empty)
let add_prefix pr ns table =
  if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
  Table.add pr ns table

37
38
39
40
41
42
43
let dump_table ppf table =
  Table.iter
    (fun pr ns ->
       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
    ) table
       

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
type qname = t * U.t

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
85
  module H = Hashtbl.Make(P)
86
87

  type printer = {
88
    ns_to_prefix : slot ref H.t;
89
90
91
92
93
94
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

95
96
97
98
99
100
101
  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

102
103
  let printer table =
    let p = 
104
      { ns_to_prefix = H.create 63;
105
106
107
108
109
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
110
    H.add p.ns_to_prefix empty (ref (Set empty_str));
111
112
113
    Table.iter 
      (fun pr ns ->
	 if (U.get_str pr <> "") then
114
115
116
117
	   match get_prefix p ns  with
	     | { contents = Hint l } as r -> 
		 p.hints <- pr::p.hints; 
		 r := Hint (pr::l)
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
	     | _ -> 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

144
  let register_ns p ns = 
145
146
    match get_prefix p ns with
      | { contents = Hint l } as r ->
147
	  let pr = find_good_prefix p ns l in
148
	  r := Set pr;
149
	  add_prefix p pr ns
150
      | _ -> ()
151

152
  let register_tag p (ns,_) = register_ns p ns
153
154
155
156
157
  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
158
    match !(get_prefix p ns) with
159
160
161
162
163
164
165
166
167
      | 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) =
    if ns == empty then (U.get_str l)
    else
168
      match !(get_prefix p ns) with
169
170
171
172
173
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
174
175
176


  let any_ns p ns =
177
    match !(get_prefix p ns) with
178
179
180
181
182
      | Set pr ->
	  let pr = U.get_str pr in
	  if pr = "" then ".:*"
          else pr ^ ":*"
      | _ -> assert false
183
end
184
185
186
187


module InternalPrinter =
struct
188
  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
189
190
191
192

  let set_table t = 
    p := Printer.printer t

193
194
195
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

  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