ns.ml 7.77 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
module H = Hashtbl.Make(Uri)
35

36 37 38



39

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

44 45 46
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]
47 48

let mk_table =
49 50 51 52 53 54 55 56 57
  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 []

58 59


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

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

285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304
let process_start_tag_subst table tag attrs subst_hash =
  let real_ns ns = 
    if H.mem subst_hash ns then H.find subst_hash ns 
    else ns in 
  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 (real_ns (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 (real_ns (Uri.mk (U.mk v))) 
	      table in
	      aux table attrs rest
	  | x ->
	      aux table ((x,U.mk v)::attrs) rest in
  aux table [] attrs

305 306 307



308
module QName = struct
309 310 311 312 313
  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 
314
end
315