Commit 3449b942 authored by Pietro Abate's avatar Pietro Abate

[r2003-06-30 13:46:51 by cvscast] Oubli cvs add ns.ml, ns.mli

Original author: cvscast
Date: 2003-06-30 13:46:52+00:00
parent 44e7f328
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
open Encodings
exception UnknownPrefix of Utf8.t
type t = int (* Namespaces (URIs) *)
val mk: Utf8.t -> t
val value: t -> Utf8.t
val empty : t
val compare: t -> t -> int
val hash: t -> int
val equal: t -> t -> bool
type table (* prefix => namespace *)
val empty_table: table
(* Contains only xml -> "http://www.w3.org/XML/1998/namespace" *)
type qname = t * Utf8.t
val add_prefix: Utf8.t -> t -> table -> table
val process_start_tag:
table -> string -> (string * string) list ->
table * qname * (qname * Utf8.t) list
val print_qname: Format.formatter -> qname -> unit
val map_tag: table -> Utf8.t -> qname
val map_attr: table -> Utf8.t -> qname
val map_prefix: table -> Utf8.t -> t
(* Support for printing XML documents *)
module Printer : sig
type printer
val printer: table -> printer
val register_tag: printer -> qname -> unit
val register_attr: printer -> qname -> unit
val prefixes: printer -> (Utf8.t * t) list
val tag: printer -> qname -> string
val attr: printer -> qname -> string
end
(***)
val register_prefix : Utf8.t -> t -> unit
val prefix : t -> Utf8.t
val dump_prefix_table : Format.formatter -> unit
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment