Commit b8498edb authored by gerd's avatar gerd

Revised namespace handling: There are now namespace

scope objects. Retrieving the display prefix is now easier.
Method "display" to write the document with display prefixes.
The namespace_info stuff has been removed.


git-svn-id: https://godirepo.camlcity.org/svn/lib-pxp/trunk@690 dbe99aee-44db-0310-b2b3-d33182c8eb97
parent 2296ae60
......@@ -23,14 +23,6 @@ end;;
module Str_hashtbl = Hashtbl.Make(HashedString);;
module StringOrd = struct
type t = string
let compare = (compare : string -> string -> int)
end;;
module StringMap = Map.Make(StringOrd);;
(* 'a StringMap.t: the type of maps (dictionaries) from string to 'a *)
let character ?swarner enc warner k =
assert (k>=0);
if (k >= 0xd800 & k < 0xe000) or (k >= 0xfffe & k <= 0xffff) or k > 0x10ffff
......
......@@ -174,14 +174,34 @@ class virtual core_parser
* by the subclass, but this is completely voluntary
*)
val mutable ns_stack = Stack.create()
(* Stack of previous ns_scope, ns_cache, ns_default_normprefix *)
val mutable ns_scope = None
(* The current namespace_scope *)
val mutable ns_cache = StringMap.empty
(* The cache mapping display prefixes to normprefixes *)
val mutable ns_default_normprefix = ""
(* The default normprefix, or "" if none *)
(*
val mutable src_norm_mapping = [ "xml", "xml" ]
(* Namespace processing: Contains pairs (srcprefix, normprefix).
* srcprefix = "!" is used as guard.
*)
val mutable default_normprefix = ""
(* Namespace_processing: The default normprefix, or "" if none *)
*)
method private init_ns_processing (mng:namespace_manager) =
let scope =
new namespace_scope_impl
mng None [ "xml", mng # get_primary_uri "xml" ] in
ns_scope <- Some scope;
ns_cache <- StringMap.empty;
ns_default_normprefix <- ""
method private push_src_norm_mapping (mng:namespace_manager) name attlist =
(* [mng]: namespace manager
......@@ -189,6 +209,10 @@ class virtual core_parser
* [attlist]: source attribute list
* returns quadruple (src_prefix, localname, norm_name, norm_attlist)
*)
(* Save state: *)
Stack.push (ns_scope, ns_cache, ns_default_normprefix) ns_stack;
let split_attlist =
List.map
(fun (name, value) -> namespace_split name, value)
......@@ -211,15 +235,12 @@ class virtual core_parser
)
split_attlist;
(* Apply xmlns_attlist: *)
src_norm_mapping <- ( "!", default_normprefix ) :: src_norm_mapping;
(* add guard *)
let mapping = ref [] in
List.iter
(fun (srcprefix, uri) ->
let normprefix =
mng # lookup_or_add_namespace srcprefix uri in
src_norm_mapping <- (srcprefix, normprefix) :: src_norm_mapping;
mapping := (srcprefix, uri) :: !mapping;
)
!xmlns_attlist;
......@@ -228,15 +249,25 @@ class virtual core_parser
None -> ()
| Some "" ->
(* Delete default namespace: *)
default_normprefix <- "";
ns_default_normprefix <- "";
mapping := ("", "") :: !mapping;
| Some uri ->
let normprefix =
try mng # get_normprefix uri
with Not_found ->
mng # lookup_or_add_namespace "default" uri
in
default_normprefix <- normprefix
ns_default_normprefix <- normprefix;
mapping := ("", uri) :: !mapping;
);
(* Create new scope: *)
let scope =
if !mapping = [] then
ns_scope
else
Some(new namespace_scope_impl mng ns_scope !mapping) in
ns_scope <- scope;
(* Normalize the regular_attlist: *)
let norm_attlist =
......@@ -262,20 +293,12 @@ class virtual core_parser
(prefix, localname, norm_name, norm_attlist)
method private pop_src_norm_mapping () =
(* Pop until the guard is found *)
let rec pop m =
match m with
[] ->
assert false
| ("!",d)::m' ->
default_normprefix <- d;
src_norm_mapping <- m'
| (_,_)::m' ->
pop m'
in
pop src_norm_mapping
let (scope, cache, default_normprefix) = Stack.pop ns_stack in
ns_scope <- scope;
ns_cache <- cache;
ns_default_normprefix <- default_normprefix
method private normalize_namespace_prefix
......@@ -284,18 +307,28 @@ class virtual core_parser
raise(Namespace_error("Found several colons in a name"));
if prefix = "" then begin
(* No prefix *)
if apply_default && default_normprefix <> "" then
default_normprefix ^ ":" ^ localname
if apply_default && ns_default_normprefix <> "" then
ns_default_normprefix ^ ":" ^ localname
else
localname
end
else begin
(* Prefix exists *)
let normprefix =
try List.assoc prefix src_norm_mapping
try
StringMap.find prefix ns_cache
with
Not_found ->
raise(Namespace_error ("Namespace prefix not declared: " ^ prefix))
let scope =
match ns_scope with Some s -> s | None -> assert false in
let np =
try scope # normprefix_of_display_prefix prefix
with
Not_found ->
raise(Namespace_error ("Namespace prefix not declared: " ^ prefix))
in
ns_cache <- StringMap.add prefix np ns_cache;
np
in
normprefix ^ ":" ^ localname
end
......
......@@ -66,13 +66,14 @@ object
val pull_counter_limit : int
val mutable pull_counter : int
val mutable p_internal_subset : bool
val mutable src_norm_mapping : (string * string ) list
val mutable default_normprefix : string
val mutable ns_scope : Pxp_dtd.namespace_scope option
method parse : context -> extended_entry -> unit
method private only_whitespace : string -> unit
method private init_ns_processing : Pxp_dtd.namespace_manager -> unit
method private push_src_norm_mapping :
namespace_manager -> string -> (string * string) list ->
(string * string * string *
......
......@@ -4,6 +4,8 @@
* Copyright by Gerd Stolpmann. See LICENSE for details.
*)
module StringMap = Map.Make(String);;
type private_id = Pxp_type_anchor.private_id
type ext_id = Pxp_type_anchor.ext_id =
......
......@@ -10,6 +10,8 @@
*)
module type CORE_TYPES = sig
module StringMap : Map.S with type key = string
type ext_id = Pxp_type_anchor.ext_id =
System of string
| Public of (string * string)
......
......@@ -4,6 +4,7 @@
*)
open Pxp_aux
open Pxp_core_types
module Graph = struct
......
......@@ -107,10 +107,12 @@ class type [ 'ext ] node =
method set_comment : string option -> unit
method comment : string option
method normprefix : string
method display_prefix : string
method localname : string
method namespace_uri : string
method namespace_info : 'ext namespace_info
method set_namespace_info : 'ext namespace_info option -> unit
method namespace_scope : namespace_scope
method set_namespace_scope : namespace_scope -> unit
method namespaces_as_nodes : 'ext node list
method namespace_manager : namespace_manager
method dtd : dtd
method encoding : rep_encoding
......@@ -131,6 +133,7 @@ class type [ 'ext ] node =
method write : ?prefixes:string list ->
?default:string ->
output_stream -> encoding -> unit
method display : ?prefixes:(string StringMap.t) -> output_stream -> encoding -> unit
method internal_adopt : 'ext node option -> int -> unit
method internal_set_pos : int -> unit
method internal_delete : 'ext node -> unit
......@@ -142,23 +145,6 @@ class type [ 'ext ] node =
dtd -> node_type -> unit
method dump : Format.formatter -> unit
end
and ['ext] namespace_info =
object
method srcprefix : string
(* Returns the prefix before it is normalized *)
method declaration : 'ext node list
(* Returns the currently active namespace declaration. The list
* enumerates all namespace objects with
* namespace # node_type = T_namespace "srcprefix"
* meaning that the srcprefix is declared to correspond to the
* namespace URI
* namespace # namespace_uri.
* This list always declares the prefix "xml". If there is a default
* namespace, it is declared for the prefix "".
*)
end
;;
type 'ext spec_table =
......@@ -552,13 +538,18 @@ class virtual ['ext] no_validation_feature =
class virtual ['ext] no_namespace_feature =
object (self)
method normprefix : string = nsmethod_na "normprefix"
method display_prefix : string = nsmethod_na "display_prefix"
method localname : string = nsmethod_na "localname"
method namespace_uri : string = nsmethod_na "namespace_uri"
method namespace_info : 'ext namespace_info = nsmethod_na "namespace_info"
method set_namespace_info (_ : 'ext namespace_info option) : unit
= nsmethod_na "set_namespace_info"
method namespace_scope : namespace_scope = nsmethod_na "namespace_scope"
method set_namespace_scope : namespace_scope -> unit
= nsmethod_na "set_namespace_scope"
method namespaces_as_nodes : 'ext node list
= nsmethod_na "namespaces_as_nodes"
method namespace_manager : namespace_manager
= nsmethod_na "namespace_manager"
= nsmethod_na "namespace_manager"
end
;;
......@@ -643,6 +634,10 @@ class ['ext] data_impl an_ext : ['ext] node =
let encoding = self # encoding in
write_data_string ~from_enc:encoding ~to_enc:enc os content
method display ?prefixes os enc =
let encoding = self # encoding in
write_data_string ~from_enc:encoding ~to_enc:enc os content
method internal_init _ _ _ _ _ _ _ = assert false
method internal_init_other _ _ _ = assert false
......@@ -789,6 +784,7 @@ class ['ext] attribute_impl ~element ~name value init_dtd : ['ext] node =
method create_data _ _ = method_na "create_data"
method create_other ?position _ _ = method_na "create_other"
method write ?prefixes ?default _ _ = method_na "write"
method display ?prefixes _ _ = method_na "display"
end
;;
......@@ -854,6 +850,9 @@ class [ 'ext ] comment_impl an_ext : ['ext] node =
);
wms ("-->");
method display ?prefixes os enc =
self # write os enc
method dump fmt =
Format.pp_open_vbox fmt 2;
Format.pp_print_string fmt "* T_comment";
......@@ -991,6 +990,9 @@ class [ 'ext ] pinstr_impl an_ext : ['ext] node =
method write ?prefixes ?default os enc =
self # write_pinstr os enc
method display ?prefixes os enc =
self # write_pinstr os enc
method dump fmt =
Format.pp_open_vbox fmt 2;
Format.pp_print_string fmt "* T_pinstr \"";
......@@ -1799,7 +1801,7 @@ class type [ 'ext ] element_node =
;;
class [ 'ext ] element_impl an_ext : ['ext] element_node =
class [ 'ext ] element_impl an_ext (* : ['ext] element_node *) =
object(self)
inherit ['ext] container_features an_ext
inherit ['ext] pinstr_features
......@@ -2556,6 +2558,12 @@ class [ 'ext ] element_impl an_ext : ['ext] element_node =
wms ("</" ^ name' ^ "\n>");
method display ?prefixes os enc =
(* Overriden in namespace_element_impl, so this is only for the
* non-namespace case:
*)
self # write os enc
method internal_init_other new_pos new_dtd new_ntype =
method_na "internal_init_other"
......@@ -2635,6 +2643,15 @@ class [ 'ext ] super_root_impl an_ext : ['ext] node =
(fun n -> n # write ?prefixes ?default os enc)
(self # sub_nodes);
method display ?prefixes os enc =
let encoding = self # encoding in
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
self # write_pinstr os enc;
List.iter
(fun n -> n # display ?prefixes os enc)
(self # sub_nodes);
method create_element ?name_pool_for_attribute_values ?position
?valcheck ?att_values _ _ _ =
method_na "create_element"
......@@ -2668,122 +2685,24 @@ class ['ext] namespace_attribute_impl ~element ~name value dtd =
method normprefix = normprefix
method localname = localname
method display_prefix =
self # parent # namespace_scope # display_prefix_of_normprefix normprefix
method namespace_uri =
self # namespace_manager # get_primary_uri normprefix
method namespace_info =
self # parent # namespace_info
method namespace_scope =
self # parent # namespace_scope
method set_namespace_info x =
method_na "set_namespace_info"
method set_namespace_scope x =
method_na "set_namespace_scope"
method namespace_manager =
self # dtd # namespace_manager
end
;;
(**********************************************************************)
(* namespace_element_impl *)
(**********************************************************************)
class [ 'ext ] namespace_element_impl an_ext =
object (self)
inherit [ 'ext ] element_impl an_ext as super
(* Note: Inheriting from an *_impl class can be problematic
* as not all methods and/or values may be visible
*)
val mutable normprefix = ""
val mutable localname = ""
val mutable nsinfo = None
method normprefix = normprefix
method localname = localname
method namespace_uri =
self # namespace_manager # get_primary_uri normprefix
method namespace_info =
match nsinfo with
None -> raise Not_found
| Some x -> x
method set_namespace_info x =
nsinfo <- x
method namespaces_as_nodes =
[]
method namespace_manager =
self # dtd # namespace_manager
method internal_init new_pos attval_name_pool valcheck_element_exists
new_dtd new_name
new_attlist new_attvalues =
super # internal_init
new_pos attval_name_pool valcheck_element_exists new_dtd new_name
new_attlist new_attvalues;
let (p,l) = namespace_split new_name in
normprefix <- p;
localname <- l;
(* TODO: Use pools *)
method private get_nsname name default =
(* Overrides the definition in element_impl *)
(* If the prefix of [name] is [default], strip the prefix: *)
let prefix, localname = namespace_split name in
if prefix = default then
localname
else
name
method private get_nsdecls prefixes =
(* Overrides the definition in element_impl *)
(* This method modifies the behaviour of 'write'. In 'prefixes' the
* list of already printed namespace declarations is passed to this
* method. The task is to check whether additional declarations are
* necessary and to pass them back as list of pairs (normprefix, uri).
*)
let scan_att name value = (* return prefix of attribute *)
extract_prefix name
in
let rec add_prefixes prefixes candidates =
match candidates with
[] -> []
| "" :: candidates' ->
add_prefixes prefixes candidates'
| p :: candidates' ->
if List.mem p prefixes then
add_prefixes prefixes candidates'
else
p :: (add_prefixes (p :: prefixes) candidates')
in
let p_candidates =
normprefix ::
(attlist_to_list vr scan_att attributes)
in
let prefixes' = add_prefixes prefixes p_candidates in
let mng = self # namespace_manager in
List.map
(fun p ->
try
p, Value (mng # get_primary_uri p)
with
Not_found -> (* raised by get_primary_uri *)
failwith ("Pxp_document.namespace_element_impl#write: cannot map the prefix `" ^ p ^ "' to any URI")
)
prefixes'
method private make_attribute_node element_name att_name value dtd =
(* This method modifies the behaviour of attributes_as_nodes *)
new namespace_attribute_impl
~element:element_name
~name:att_name
value
dtd
end
;;
......@@ -2822,15 +2741,22 @@ class [ 'ext ] namespace_impl srcprefix normprefix init_dtd : ['ext] node =
(self # namespace_manager) # get_primary_uri normprefix
method normprefix =
normprefix
(* CHECK in the light of new namespace impl *)
(* This is a hack to ensure whenever there is no srcprefix we will
* not have a normprefix, either.
* However, there may be a namespace URI
*)
(*
if srcprefix = "" then
""
else
normprefix
*)
method display_prefix =
srcprefix
method namespace_uri =
(* XPath requires this to be null: *)
raise Not_found
......@@ -2838,6 +2764,12 @@ class [ 'ext ] namespace_impl srcprefix normprefix init_dtd : ['ext] node =
method namespace_manager =
self # dtd # namespace_manager
method namespace_scope =
self # parent # namespace_scope
method namespaces_as_nodes =
[]
method dump fmt =
Format.pp_open_vbox fmt 2;
Format.pp_print_string fmt "+ T_namespace";
......@@ -2845,7 +2777,7 @@ class [ 'ext ] namespace_impl srcprefix normprefix init_dtd : ['ext] node =
Format.pp_print_string fmt "normprefix=";
Format.pp_print_string fmt (self # normprefix);
Format.pp_print_cut fmt ();
Format.pp_print_string fmt "srcprefix=";
Format.pp_print_string fmt "display prefix=";
Format.pp_print_string fmt srcprefix;
Format.pp_print_cut fmt ();
Format.pp_print_string fmt "uri=";
......@@ -2867,16 +2799,15 @@ class [ 'ext ] namespace_impl srcprefix normprefix init_dtd : ['ext] node =
method internal_init _ _ _ _ _ _ _ = method_na "internal_init"
method internal_init_other _ _ _ = method_na "internal_init_other"
method set_data _ = method_na "set_data"
method set_namespace_scope _ = method_na "set_namespace_scope"
method create_element ?name_pool_for_attribute_values ?position
?valcheck ?att_values _ _ _ =
method_na "create_element"
method create_data _ _ = method_na "create_data"
method create_other ?position _ _ = method_na "create_other"
method write ?prefixes ?default _ _ = method_na "write"
method display ?prefixes _ _ = method_na "display"
method localname = method_na "localname"
method namespace_info = method_na "namespace_info"
method set_namespace_info info =
method_na "set_namespace_info"
method previous_node = method_na "previous_node"
method next_node = method_na "next_node"
method remove _ = method_na "remove"
......@@ -2889,10 +2820,10 @@ let namespace_normprefix n =
| _ -> invalid_arg "Pxp_document.namespace_normprefix"
;;
let namespace_srcprefix n =
let namespace_display_prefix n =
match n # node_type with
T_namespace s -> s
| _ -> invalid_arg "Pxp_document.namespace_srcprefix"
T_namespace _ -> n # display_prefix
| _ -> invalid_arg "Pxp_document.namespace_display_prefix"
;;
let namespace_uri n =
......@@ -2901,50 +2832,224 @@ let namespace_uri n =
| _ -> invalid_arg "Pxp_document.namespace_uri"
;;
(**********************************************************************)
(* namespace_info_impl *)
(* namespace_element_impl *)
(**********************************************************************)
class [ 'ext ] namespace_info_impl
(srcprefix:string) (element : 'ext node) mapping =
object
val srcprefix = srcprefix
val parent = element
val mutable src_norm_mapping = mapping
val mutable declaration = None
class [ 'ext ] namespace_element_impl an_ext =
object (self)
inherit [ 'ext ] element_impl an_ext as super
(* Note: Inheriting from an *_impl class can be problematic
* as not all methods and/or values may be visible
*)
method srcprefix = srcprefix
val mutable normprefix = ""
val mutable localname = ""
val mutable scope = None
val mutable nsnodes = None
method declaration =
match declaration with
Some d -> d
| None ->
let d = ref [] in
let done_srcprefixes = ref [] in
let dtd = parent # dtd in
let pos = ref 0 in
(* Note: The first pair ("!", s) contains the current default
* namespace. if s = "" there is no such default; otherwise,
* s is the normprefix of the default.
*)
List.iter
(fun (srcprefix, normprefix) ->
if not (List.mem srcprefix !done_srcprefixes) then begin
let srcprefix' =
if srcprefix = "!" then "" else srcprefix in
if normprefix <> "" then begin
let nsnode = new namespace_impl srcprefix' normprefix dtd in
nsnode # internal_adopt (Some parent) !pos;
d := nsnode :: !d;
end;
done_srcprefixes := srcprefix :: !done_srcprefixes;
end
method normprefix = normprefix
method localname = localname
method namespace_uri =
self # namespace_manager # get_primary_uri normprefix
method display_prefix =
self # namespace_scope # display_prefix_of_normprefix normprefix
method namespace_scope =
match scope with
None ->
( let empty_scope =
new namespace_scope_impl self#namespace_manager None [] in
scope <- Some empty_scope;
empty_scope
)
src_norm_mapping;
declaration <- Some !d;
src_norm_mapping <- []; (* save memory *)
!d
end
| Some x -> x
method set_namespace_scope x =
let m = self#namespace_manager in
if m <> x # namespace_manager then
failwith "set_namespace_scope: Invalid namespace manager";
scope <- Some x;
nsnodes <- None; (* force recomputation *)
method namespace_manager =
self # dtd # namespace_manager
method namespaces_as_nodes =
match nsnodes with
None ->
let dtd = self#dtd in
let m = self#namespace_manager in
let s = self#namespace_scope in
let l1 = s#effective_declaration in (* pairs (dsp_prefix, uri) *)
let l2 =
List.map
(fun (dsp_prefix, uri) ->
let norm_prefix =
try m#get_normprefix uri
with Not_found -> "<unknown>" (* CHECK *) in
new namespace_impl dsp_prefix norm_prefix dtd
)
l1 in
nsnodes <- Some l2;
l2
| Some l ->
l
method internal_init new_pos attval_name_pool valcheck_element_exists
new_dtd new_name
new_attlist new_attvalues =
super # internal_init
new_pos attval_name_pool valcheck_element_exists new_dtd new_name
new_attlist new_attvalues;
let (p,l) = namespace_split new_name in
normprefix <- p;
localname <- l;
(* TODO: Use pools *)
method private get_nsname name default =
(* Overrides the definition in element_impl *)
(* If the prefix of [name] is [default], strip the prefix: *)
let prefix, localname = namespace_split name in
if prefix = default then
localname
else
name
method private get_nsdecls prefixes =
(* Overrides the definition in element_impl *)
(* This method modifies the behaviour of 'write'. In 'prefixes' the
* list of already printed namespace declarations is passed to this
* method. The task is to check whether additional declarations are
* necessary and to pass them back as list of pairs (normprefix, uri).
*)
let scan_att name value = (* return prefix of attribute *)
extract_prefix name
in
let rec add_prefixes prefixes candidates =
match candidates with
[] -> []
| "" :: candidates' ->
add_prefixes prefixes candidates'
| p :: candidates' ->
if List.mem p prefixes then
add_prefixes prefixes candidates'
else
p :: (add_prefixes (p :: prefixes) candidates')
in
let p_candidates =
normprefix ::
(attlist_to_list vr scan_att attributes)
in
let prefixes' = add_prefixes prefixes p_candidates in
let mng = self # namespace_manager in
List.map
(fun p ->
try
p, Value (mng # get_primary_uri p)
with
Not_found -> (* raised by get_primary_uri *)
failwith ("Pxp_document.namespace_element_impl#write: cannot map the prefix `" ^ p ^ "' to any URI")
)
prefixes'
method private make_attribute_node element_name att_name value dtd =
(* This method modifies the behaviour of attributes_as_nodes *)