ns.ml 7.76 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
module Table = Map.Make(U)
type table = Uri.t Table.t
    (* Tables prefix->uri *)
39

40 41 42
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]
43 44

let mk_table =
45 46 47 48 49 50 51 52 53
  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 []

54 55


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

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 = {
69
    ns_to_prefix : slot ref H.t;
70 71
    mutable prefixes : (U.t * Uri.t) list;
    table : table;
72
    mutable hints : U.t list;
73
    mutable counter : int;
74 75
  }

76 77 78 79 80 81 82
  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

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

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

134
  let register_qname p (ns,_) = register_ns p ns
135 136 137 138

  let prefixes p = p.prefixes

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

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


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


module InternalPrinter =
struct
173
  let p = ref (Printer.printer def_table)
174 175 176 177

  let set_table t = 
    p := Printer.printer t

178 179 180
  let any_ns ns =
    Printer.register_ns !p ns;
    Printer.any_ns !p ns
181

182 183 184
  let tag q =
    Printer.register_qname !p q;
    Printer.tag !p q
185

186 187 188
  let attr q =
    Printer.register_qname !p q;
    Printer.attr !p q
189 190 191 192

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

  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)
204
end
205

206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
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

233 234 235
let merge_tables t1 t2 =
  Table.fold add_prefix t2 t1

236 237 238 239 240 241 242 243 244 245 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
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

275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
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

295
module QName = struct
296 297 298 299 300
  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 
301
end
302