[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

misc/ns.ml

+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

misc/ns.mli

+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