ns.ml 5.44 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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
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
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
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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
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)


include Pool.Make(U)
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

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



(* TODO: harmonize pretty-printing of values and of XML documents *)

  let prefixes_to_ns = State.ref "Ns.prefixes" (Hashtbl.create 63)
  let ns_to_prefixes = State.ref "Ns.prefixes" (Hashtbl.create 63)

  let register_prefix p ns =
    if (Hashtbl.mem !prefixes_to_ns p) || 
       (Hashtbl.mem !ns_to_prefixes ns) 
    then ()
    else ( Hashtbl.add !ns_to_prefixes ns p;
	   Hashtbl.add !prefixes_to_ns p ns )

  let counter = State.ref "Ns.prefixes" 0

  let rec fresh_prefix () =
    incr counter;
    let s = U.mk (Printf.sprintf "ns%i" !counter) in
    if (Hashtbl.mem !prefixes_to_ns s) then fresh_prefix () else s

  let prefix ns =
    try Hashtbl.find !ns_to_prefixes ns
    with Not_found ->
      let p = fresh_prefix () in
      register_prefix p ns;
      p

  let dump_prefix_table ppf =
    Hashtbl.iter
      (fun ns p ->
	 Format.fprintf ppf "%a=>%a@." U.print p U.print (value ns))
      !ns_to_prefixes

  let _ = register_prefix empty_str empty


let print_prefix ppf ns =
  if ns == empty then () else
    Format.fprintf ppf "%a:" U.print (prefix ns)

let print_qname ppf (ns,x)  = 
  Format.fprintf ppf "%a%a" print_prefix ns U.print x


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

  type printer = {
    mutable ns_to_prefix : slot array;
    mutable prefixes     : (U.t * t) list;
    table        : table;
    mutable hints : U.t list;
    mutable counter  : int;
  }

  let ensure p ns =
    let l = Array.length p.ns_to_prefix in
    if ns >= l then
      let a = Array.create (ns + 1 + 2 * l) (Hint []) in
      Array.blit p.ns_to_prefix 0 a 0 l;
      p.ns_to_prefix <- a
 
  let printer table =
    let p = 
      { ns_to_prefix = [| |];
	prefixes     = [];
	table        = table;
	hints        = [];
	counter      = 0
      } in
    ensure p empty;
    p.ns_to_prefix.(empty) <- Set empty_str;
    Table.iter 
      (fun pr ns ->
	 ensure p ns;
	 if (U.get_str pr <> "") then
	   match p.ns_to_prefix.(ns) with
	     | Hint l -> p.hints <- pr::p.hints; p.ns_to_prefix.(ns) <- Hint (pr::l)
	     | _ -> 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 gen = ref 0
  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

  let register_tag p (ns,_) =
     ensure p ns;
    match p.ns_to_prefix.(ns) with
      | Hint l ->
	  let pr = find_good_prefix p ns l in
	  p.ns_to_prefix.(ns) <- Set pr;
	  add_prefix p pr ns
      | Set _ -> ()

  let register_attr = register_tag

  let prefixes p = p.prefixes

  let tag p (ns,l) =
    match p.ns_to_prefix.(ns) with
      | 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
      match p.ns_to_prefix.(ns) with
	| Set pr ->
	    let pr = U.get_str pr in
	    if pr = "" then assert false
            else pr ^ ":" ^ (U.get_str l)
	| _ -> assert false
end