ns.ml 4.96 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
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
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

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

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
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

  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
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


module InternalPrinter =
struct
  let p = ref (Printer.printer empty_table)

  let set_table t = 
    p := Printer.printer t

  let ns ns =
    U.to_string (value ns)

  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