(* $Id$
* ----------------------------------------------------------------------
* PXP: The polymorphic XML parser for Objective Caml.
* Copyright by Gerd Stolpmann. See LICENSE for details.
*)
open Pxp_core_types.I
open Pxp_lexer_types
open Pxp_lexers
open Pxp_entity
open Pxp_aux
open Pxp_dfa
(**********************************************************************)
type validation_record =
{ content_model : content_model_type;
content_dfa : dfa_definition option Lazy.t;
id_att_name : string option;
idref_att_names : string list;
att_lookup : int Str_hashtbl.t;
init_att_vals : (string * att_value) array;
att_info : (att_type * bool) array;
att_required : int list;
accept_undeclared_atts : bool;
}
;;
(* class type? *)
class namespace_manager =
object (self)
val uri_of_prefix = Hashtbl.create 10 (* not unique *)
val prefix_of_uri = Hashtbl.create 10 (* unique *)
val primary_uri_of_prefix = Hashtbl.create 10 (* unique *)
initializer
ignore(self # add_namespace "xml" "http://www.w3.org/XML/1998/namespace")
method add_uri (np:string) (uri:string) =
if not (Hashtbl.mem uri_of_prefix np) then
raise(Namespace_prefix_not_managed np);
try
let np' = Hashtbl.find prefix_of_uri uri in
if np <> np' then
raise(Namespace_error "add_uri: the URI is already managed")
with
Not_found ->
Hashtbl.add uri_of_prefix np uri;
Hashtbl.add prefix_of_uri uri np;
()
method add_namespace np uri =
let l = Hashtbl.find_all uri_of_prefix np in
if l = [] then begin
if Hashtbl.mem prefix_of_uri uri then
raise(Namespace_error "add_namespace: the URI is already managed");
Hashtbl.add uri_of_prefix np uri;
Hashtbl.add primary_uri_of_prefix np uri;
Hashtbl.add prefix_of_uri uri np;
end
else
if l <> [ uri ] then
raise(Namespace_error "add_namespace: the namespace does already exist")
method lookup_or_add_namespace prefix (uri:string) =
let rec add_loop n =
let p = prefix ^ (if n=0 then "" else string_of_int n) in
if Hashtbl.mem uri_of_prefix p then begin
add_loop (n+1)
end
else begin
Hashtbl.add uri_of_prefix p uri;
Hashtbl.add primary_uri_of_prefix p uri;
Hashtbl.add prefix_of_uri uri p;
p
end
in
try
Hashtbl.find prefix_of_uri uri
with
Not_found ->
add_loop (if prefix = "" then 1 else 0)
(* prefix = "": make sure that such a prefix is never added *)
method get_primary_uri normprefix =
try
Hashtbl.find primary_uri_of_prefix normprefix
with
Not_found ->
raise(Namespace_prefix_not_managed normprefix)
method get_uri_list normprefix =
Hashtbl.find_all uri_of_prefix normprefix
method get_normprefix uri =
try
Hashtbl.find prefix_of_uri uri
with
Not_found ->
raise(Namespace_not_managed uri)
method iter_namespaces f =
Hashtbl.iter
(fun p uri -> f p)
primary_uri_of_prefix
method as_declaration =
let l = ref [] in
Hashtbl.iter
(fun p uri -> l := (p, uri) :: !l)
primary_uri_of_prefix;
!l
end
;;
let create_namespace_manager () = new namespace_manager;;
class type namespace_scope =
object
method namespace_manager : namespace_manager
method parent_scope : namespace_scope option
method declaration : (string * string) list
method effective_declaration : (string * string) list
method display_prefix_of_uri : string -> string
method display_prefix_of_normprefix : string -> string
method uri_of_display_prefix : string -> string
method normprefix_of_display_prefix : string -> string
end
;;
module StrSet = Set.Make(String);;
class namespace_scope_impl mng parent_opt decl : namespace_scope =
object(self)
method namespace_manager = mng
method parent_scope = parent_opt
method declaration = decl
method effective_declaration =
let rec collect visible d s =
match d with
| ("", "") :: d' ->
if StrSet.mem "" visible then
collect visible d' s (* no effect *)
else
collect (StrSet.add "" visible) d' s (* hide inner default *)
| (dp, uri) :: d' ->
if StrSet.mem dp visible then
collect visible d' s
else
(dp, uri) :: collect (StrSet.add dp visible) d' s
| [] ->
( match s # parent_scope with
Some s' ->
collect visible s'#declaration s'
| None ->
[]
)
in
collect StrSet.empty self#declaration (self : #namespace_scope :> namespace_scope)
method display_prefix_of_uri uri =
try
fst(List.find (fun (p,u) -> u = uri) decl)
with
Not_found ->
( match parent_opt with
Some pa -> pa # display_prefix_of_uri uri
| None -> raise(Namespace_not_in_scope uri)
)
method display_prefix_of_normprefix np =
let uris = mng # get_uri_list np in
if uris = [] then raise(Namespace_prefix_not_managed np);
try
fst(List.find (fun (p,u) -> List.mem u uris) decl)
with
Not_found ->
( match parent_opt with
Some pa -> pa # display_prefix_of_normprefix np
| None -> raise(Namespace_not_in_scope
(List.hd(List.rev uris)))
)
method uri_of_display_prefix dp =
try
List.assoc dp decl
with
Not_found ->
( match parent_opt with
Some pa -> pa # uri_of_display_prefix dp
| None -> raise Not_found
)
method normprefix_of_display_prefix dp =
let uri = self # uri_of_display_prefix dp in
mng # get_normprefix uri
end
;;
let create_namespace_scope ?parent ?(decl = []) mng =
new namespace_scope_impl mng parent decl ;;
class dtd ?swarner the_warner init_encoding =
object (self)
val mutable root = (None : string option)
val mutable id = (None : dtd_id option)
val mutable mng = (None : namespace_manager option)
val warner = (the_warner : collect_warnings)
val swarner = (swarner : symbolic_warnings option)
val encoding = init_encoding
val lfactory = Pxp_lexers.get_lexer_factory init_encoding
val elements = (Str_hashtbl.create 100 : dtd_element Str_hashtbl.t)
val gen_entities = (Str_hashtbl.create 100 : (entity * bool) Str_hashtbl.t)
val par_entities = (Str_hashtbl.create 100 : entity Str_hashtbl.t)
val notations = (Str_hashtbl.create 100 : dtd_notation Str_hashtbl.t)
val pinstr = (Str_hashtbl.create 100 : proc_instruction Str_hashtbl.t)
val mutable element_names = []
val mutable gen_entity_names = []
val mutable par_entity_names = []
val mutable notation_names = []
val mutable pinstr_names = []
val mutable allow_arbitrary = false
val mutable standalone_declaration = false
val mutable validated = false
initializer
let w = new drop_warnings in
self # add_gen_entity
(new internal_entity self "lt" None w "&#60;" false false encoding)
false;
self # add_gen_entity
(new internal_entity self "gt" None w ">" false false encoding)
false;
self # add_gen_entity
(new internal_entity self "amp" None w "&#38;" false false encoding)
false;
self # add_gen_entity
(new internal_entity self "apos" None w "'" false false encoding)
false;
self # add_gen_entity
(new internal_entity self "quot" None w """ false false encoding)
false;
method encoding = encoding
method lexer_factory = lfactory
method warner = warner
method swarner = swarner
method set_root r =
if root = None then
root <- Some r
else
assert false
method set_id j =
if id = None then
id <- Some j
else
assert false
method standalone_declaration = standalone_declaration
method set_standalone_declaration b =
standalone_declaration <- b
method allow_arbitrary =
allow_arbitrary <- true
method disallow_arbitrary =
allow_arbitrary <- false
method arbitrary_allowed = allow_arbitrary
method root = root
method id = id
method namespace_manager =
match mng with
None -> raise(Namespace_method_not_applicable "namespace_manager")
| Some m -> m
method set_namespace_manager m =
mng <- Some m
method add_element el =
(* raises Not_found if 'el' has already been added *)
(* Note: 'el' is encoded in the same way as 'self'! *)
let name = el # name in
check_name ?swarner warner name;
if Str_hashtbl.mem elements name then
raise Not_found;
Str_hashtbl.add elements name el;
element_names <- name :: element_names;
validated <- false
method add_gen_entity en extdecl =
(* The following is commented out; perhaps there should be an option
* to reactivate it on demand
*)
(* raises Validation_error if the predefines entities 'lt', 'gt', 'amp',
* 'quot', and 'apos' are redeclared with an improper value.
*)
if en # encoding <> encoding then
failwith "Pxp_dtd.dtd # add_gen_entity: Inconsistent encodings";
let name = en # name in
check_name ?swarner warner name;
if Str_hashtbl.mem gen_entities name then begin
if List.mem name [ "lt"; "gt"; "amp"; "quot"; "apos" ] then begin
(* These are allowed to be declared several times *)
let (rt,_) = en # replacement_text in
let toks = tokens_of_content_string lfactory rt in
try
begin match toks with
[CRef 60] -> if name <> "lt" then raise Not_found
| [CharData ">"] -> if name <> "gt" then raise Not_found
| [CRef 62] -> if name <> "gt" then raise Not_found
| [CRef 38] -> if name <> "amp" then raise Not_found
| [CharData "'"] -> if name <> "apos" then raise Not_found
| [CRef 39] -> if name <> "apos" then raise Not_found
| [CharData "\""] -> if name <> "quot" then raise Not_found
| [CRef 34] -> if name <> "quot" then raise Not_found
| _ -> raise Not_found
end
with
Not_found ->
raise (Validation_error("Predefined entity `" ^ name ^
"' redeclared"))
end
else
warn swarner warner (`W_entity_declared_twice name)
end
else begin
Str_hashtbl.add gen_entities name (en, extdecl);
gen_entity_names <- name :: gen_entity_names
end
method add_par_entity en =
if en # encoding <> encoding then
failwith "Pxp_dtd.dtd # add_par_entity: Inconsistent encodings";
let name = en # name in
check_name ?swarner warner name;
if not (Str_hashtbl.mem par_entities name) then begin
Str_hashtbl.add par_entities name en;
par_entity_names <- name :: par_entity_names
end
else
warn swarner warner (`W_entity_declared_twice name)
method add_notation no =
(* raises Validation_error if 'no' already added *)
if no # encoding <> encoding then
failwith "Pxp_dtd.dtd # add_notation: Inconsistent encodings";
let name = no # name in
check_name ?swarner warner name;
if Str_hashtbl.mem notations name then
raise (Validation_error("Notation `" ^ name ^ "' declared twice"));
Str_hashtbl.add notations name no;
notation_names <- name :: notation_names
method add_pinstr pi =
if pi # encoding <> encoding then
failwith "Pxp_dtd.dtd # add_pinstr: Inconsistent encodings";
let name = pi # target in
check_name ?swarner warner name;
if String.length name >= 4 && String.sub name 0 4 = "pxp:" then begin
match name with
"pxp:dtd" ->
let _, optname, atts = pi # parse_pxp_option in
begin match optname with
"optional-element-and-notation-declarations" ->
self # allow_arbitrary
| "optional-attribute-declarations" ->
let el_string =
try List.assoc "elements" atts
with Not_found ->
raise(Error("Missing `elements' attribute for pxp:dtd"))
in
let el = split_attribute_value lfactory el_string in
List.iter
(fun e_name ->
let e =
try Str_hashtbl.find elements e_name
with
Not_found ->
raise(Error("Reference to unknown element `" ^
e_name ^ "'"))
in
e # allow_arbitrary
)
el
| "namespace" ->
let prefix =
try List.assoc "prefix" atts
with Not_found ->
raise(Error("Missing `prefix' attribute for pxp:dtd"))
in
let uri =
try List.assoc "uri" atts
with Not_found ->
raise(Error("Missing `uri' attribute for pxp:dtd"))
in
( match mng with
None ->
raise(Error("Cannot do pxp:dtd instruction: namespaces not enabled"))
| Some m ->
( try m # add_uri prefix uri
with Namespace_prefix_not_managed _ ->
m # add_namespace prefix uri
)
)
| _ ->
raise(Error("Unknown PXP option `" ^
optname ^ "'"))
end
| _ ->
raise(Error("The processing instruction target `" ^
name ^ "' is not defined by this PXP version"))
end;
Str_hashtbl.add pinstr name pi;
if not (List.mem name pinstr_names) then
pinstr_names <- pinstr_names @ [name];
method element name =
(* returns the element 'name' or raises Validation_error if not found *)
try
Str_hashtbl.find elements name
with
Not_found ->
if allow_arbitrary then
raise Undeclared
else
raise(Validation_error("Reference to undeclared element `" ^ name ^ "'"))
method element_names =
(* returns the list of all names of element declarations *)
element_names
method gen_entity name =
(* returns the entity 'name' or raises WF_error if not found *)
try
Str_hashtbl.find gen_entities name
with
Not_found ->
raise(WF_error("Reference to undeclared general entity `" ^ name ^ "'"))
method gen_entity_names = gen_entity_names
method par_entity name =
(* returns the entity 'name' or raises WF_error if not found *)
try
Str_hashtbl.find par_entities name
with
Not_found ->
raise(WF_error("Reference to undeclared parameter entity `" ^ name ^ "'"))
method par_entity_names = par_entity_names
method notation name =
(* returns the notation 'name' or raises Validation_error if not found *)
try
Str_hashtbl.find notations name
with
Not_found ->
if allow_arbitrary then
raise Undeclared
else
raise(Validation_error("Reference to undeclared notation `" ^ name ^ "'"))
method notation_names = notation_names
method pinstr name =
(* returns the list of all processing instructions contained in the DTD
* with target 'name'
*)
Str_hashtbl.find_all pinstr name
method pinstr_names = pinstr_names
method write_ref ?root:proot os enc =
let write_sysid s =
write_markup_string
~from_enc:`Enc_utf8 ~to_enc:enc os
( if String.contains s '"' then
"'" ^ s ^ "'"
else
"\"" ^ s ^ "\""
)
in
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
wms "<!DOCTYPE ";
( match proot with
| None ->
( match root with
None -> failwith "#write: DTD without root";
| Some r -> wms r
)
| Some r -> wms r
);
begin match id with
None ->
failwith "#write_ref: DTD does not have an ID"
| Some (External (Public (p,s))) ->
wms " PUBLIC ";
write_sysid p;
wms " ";
write_sysid s
| Some (External (System s)) ->
wms " SYSTEM ";
write_sysid s
| Some (External _) ->
failwith "#write_ref: External ID cannot be represented"
| Some Internal ->
failwith "#write_ref: Cannot write internal ID"
| Some (Derived _) ->
failwith "#write_ref: Cannot write derived ID"
end;
wms ">\n";
method write ?root:proot os enc doctype =
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
let write_sysid s =
write_markup_string
~from_enc:`Enc_utf8 ~to_enc:enc os
( if String.contains s '"' then
"'" ^ s ^ "'"
else
"\"" ^ s ^ "\""
)
in
if doctype then begin
wms "<!DOCTYPE ";
( match proot with
| None ->
( match root with
None -> failwith "#write: DTD without root";
| Some r -> wms r
);
| Some r -> wms r
);
wms " [\n";
end;
(* Notations: *)
List.iter
(fun name ->
let notation =
try Str_hashtbl.find notations name with Not_found -> assert false in
notation # write os enc)
(List.sort compare notation_names);
(* Unparsed entities: *)
List.iter
(fun name ->
let ent,_ =
try Str_hashtbl.find gen_entities name with Not_found -> assert false
in
if ent # is_ndata then begin
let xid = ent # ext_id in
let notation = ent # notation in
wms ("<!ENTITY " ^ name ^ " " );
( match xid with
System s ->
wms "SYSTEM ";
write_sysid s;
| Public (p,s) ->
wms "PUBLIC ";
write_sysid p;
if (s <> "") then begin
wms " ";
write_sysid s;
end;
| Anonymous ->
failwith "#write: External ID `Anonymous' cannot be represented"
| Private _ ->
failwith "#write: External ID `Private' cannot be represented"
);
wms (" NDATA " ^ notation ^ ">\n");
end
)
(List.sort compare gen_entity_names);
(* Elements: *)
List.iter
(fun name ->
let element =
try Str_hashtbl.find elements name with Not_found -> assert false in
element # write os enc)
(List.sort compare element_names);
(* Processing instructions: *)
List.iter
(fun name ->
List.iter
(fun pi ->
pi # write os enc)
(Str_hashtbl.find_all pinstr name)
)
(List.sort compare pinstr_names);
if doctype then
wms "]>\n";
(************************************************************)
(* VALIDATION *)
(************************************************************)
method only_deterministic_models =
Str_hashtbl.iter
(fun n el ->
let cm = el # content_model in
match cm with
Regexp _ ->
if el # content_dfa = None then
raise(Validation_error("The content model of element `" ^
n ^ "' is not deterministic"))
| _ ->
()
)
elements;
method validate =
if validated || allow_arbitrary then
()
else begin
(* Validity constraint: Notations in NDATA entity declarations must
* be declared
*)
List.iter
(fun name ->
let ent,_ =
try Str_hashtbl.find gen_entities name with Not_found -> assert false
in
if ent # is_ndata then begin
let _xid = ent # ext_id in
let notation = ent # notation in
try
ignore(self # notation notation)
(* Raises Validation_error if the constraint is violated *)
with
Undeclared -> ()
end
)
gen_entity_names;
(* Validate the elements: *)
Str_hashtbl.iter
(fun n el ->
el # validate)
elements;
(* Check the root element: This check is commented out because:
* - it is performed anyway when the root element is validated
* - it does not work in namespace mode (missing ns normalization)
*)
(* --
begin match root with
None -> ()
| Some r ->
begin try
let _ = Str_hashtbl.find elements r in ()
with
Not_found ->
raise(Validation_error("The root element is not declared"))
end
end;
--*)
validated <- true;
end
method invalidate =
validated <- false
(************************************************************)
end
(**********************************************************************)
and dtd_element the_dtd the_name =
object (self)
val dtd = (the_dtd : dtd)
val name = the_name
val lfactory = the_dtd # lexer_factory
val mutable content_model = Unspecified
val mutable content_model_validated = false
val mutable content_dfa = lazy None
val mutable externally_declared = false
val mutable attributes =
([] : (string * ((att_type * att_default) * bool)) list)
val mutable attributes_validated = false
val mutable id_att_name = None
val mutable idref_att_names = []
val mutable allow_arbitrary = false
val mutable vr = (None : validation_record option)
method name = name
method set_cm_and_extdecl m extdecl =
if content_model = Unspecified then begin
content_model <- m;
content_model_validated <- false;
content_dfa <- lazy (self # compute_content_dfa);
externally_declared <- extdecl;
self # update_vr;
dtd # invalidate
end
else
raise(Validation_error("Element `" ^ name ^ "' has already a content model"))
method content_model = content_model
method content_dfa = Lazy.force content_dfa
method private compute_content_dfa =
match content_model with
Regexp re ->
( try Some (dfa_of_regexp_content_model re)
with Not_found -> None
)
| _ ->
None
method externally_declared = externally_declared
method encoding = dtd # encoding
method allow_arbitrary =
allow_arbitrary <- true;
self # update_vr;
method disallow_arbitrary =
allow_arbitrary <- false;
self # update_vr;
method arbitrary_allowed = allow_arbitrary
method add_attribute aname t d extdecl =
let swarner = dtd#swarner
and warner = dtd#warner in
if aname <> "xml:lang" && aname <> "xml:space" then
check_name ?swarner warner aname;
if List.mem_assoc aname attributes then
warn swarner warner (`W_multiple_attribute_declarations(name,aname))
else begin
begin match aname with
"xml:space" ->
begin match t with
A_enum l ->
let ok =
List.for_all
(fun tok -> List.mem tok ["default";"preserve"])
l
in
if not ok then
raise(Validation_error("Declaration of attribute `xml:space' does not conform to XML specification"))
| _ ->
raise(Validation_error("Declaration of attribute `xml:space' does not conform to XML specification"))
end
| _ -> ()
end;
begin match t with
A_id ->
id_att_name <- Some aname;
| (A_idref | A_idrefs) ->
idref_att_names <- aname :: idref_att_names;
| _ ->
()
end;
attributes <- (aname, ((t,d),extdecl)) :: attributes;
attributes_validated <- false;
dtd # invalidate;
self # update_vr;
end
method attribute attname =
try
fst (List.assoc attname attributes)
with
Not_found ->
if allow_arbitrary then
raise Undeclared
else
raise(Validation_error("Attribute `" ^ attname ^ "' of element `"
^ name ^ "' not declared"))
method attribute_violates_standalone_declaration attname v =
try
let (atype, adefault), extdecl = List.assoc attname attributes in
extdecl &&
( match v with
None ->
adefault <> D_required && adefault <> D_implied
(* i.e. adefault matches D_default or D_fixed *)
| Some s ->
atype <> A_cdata &&
normalization_changes_value lfactory atype s
)
with
Not_found ->
if allow_arbitrary then
raise Undeclared
else
raise(Validation_error("Attribute `" ^ attname ^ "' of element `"
^ name ^ "' not declared"))
method attribute_names =
List.map fst attributes
method names_of_required_attributes =
List.flatten
(List.map
(fun (n,((t,d),_)) ->
if d = D_required then
[n]
else
[])
attributes)
method id_attribute_name = id_att_name
method idref_attribute_names = idref_att_names
method private update_vr =
vr <- None
method internal_vr =
( match vr with
None ->
let n = List.length attributes in
let init_att_vals = Array.make n ("", Implied_value) in
let att_lookup = Str_hashtbl.create n in
let att_info = Array.make n (A_cdata, false) in
let att_required = ref [] in
let k = ref 0 in
List.iter
(fun (n, ((t,d), ext)) ->
Str_hashtbl.add att_lookup n !k;
let init_val =
match d with
(D_required | D_implied) -> Implied_value
| D_default v ->
value_of_attribute lfactory dtd n t v
| D_fixed v ->
value_of_attribute lfactory dtd n t v
in
init_att_vals.( !k ) <- (n, init_val);
att_info.( !k ) <- (t, match d with D_fixed _ -> true
| _ -> false);
if d = D_required then
att_required := !k :: !att_required;
incr k;
)
attributes;
vr <- Some { content_model = content_model;
content_dfa = content_dfa;
id_att_name = id_att_name;
idref_att_names = idref_att_names;
init_att_vals = init_att_vals;
att_lookup = att_lookup;
att_info = att_info;
att_required = !att_required;
accept_undeclared_atts = allow_arbitrary;
}
| _ -> ()
);
( match vr with
None -> assert false
| Some vr' -> vr'
)
method write os enc =
let encoding = self # encoding in
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
let rec write_contentspec cs =
match cs with
Unspecified ->
failwith "#write: Unspecified content model found"
| Empty ->
wms "EMPTY"
| Any ->
wms "ANY"
| Mixed ml ->
wms "(";
write_mixedspec_list ml;
wms ")*";
| Regexp re ->
write_children re false
and write_mixedspec_list ml =
match ml with
MPCDATA :: ml' ->
wms "#PCDATA";
if ml' <> [] then wms "|";
write_mixedspec_list ml';
| MChild s :: ml' ->
wms s;
if ml' <> [] then wms "|";
write_mixedspec_list ml';
| [] ->
()
and write_children re cp =
match re with
Optional re' ->
let p = needs_parens re' in
if p then wms "(";
write_children re' cp;
if p then wms ")";
wms "?";
| Repeated re' ->
let p = needs_parens re' in
if p then wms "(";
write_children re' cp;
if p then wms ")";
wms "*";
| Repeated1 re' ->
let p = needs_parens re' in
if p then wms "(";
write_children re' cp;
if p then wms ")";
wms "+";
| Alt re' ->
wms "(";
( match re' with
re1' :: rer' ->
write_children re1' true;
List.iter
(fun ren' ->
wms "|";
write_children ren' true;
)
rer';
| [] ->
failwith "#write: Illegal content model"
);
wms ")";
| Seq re' ->
wms "(";
( match re' with
re1' :: rer' ->
write_children re1' true;
List.iter
(fun ren' ->
wms ",";
write_children ren' true;
)
rer';
| [] ->
failwith "#write: Illegal content model"
);
wms ")";
| Child ch ->
if not cp then wms "(";
wms ch;
if not cp then wms ")";
and needs_parens re =
match re with
(Optional _ | Repeated _ | Repeated1 _ ) -> true
| _ -> false
in
wms ("<!ELEMENT " ^ name ^ " ");
write_contentspec content_model;
wms ">\n";
wms ("<!ATTLIST " ^ name);
List.iter
(fun (n,((t,d),_)) ->
wms ("\n " ^ n);
( match t with
A_cdata -> wms " CDATA";
| A_id -> wms " ID";
| A_idref -> wms " IDREF";
| A_idrefs -> wms " IDREFS";
| A_entity -> wms " ENTITY";
| A_entities -> wms " ENTITIES";
| A_nmtoken -> wms " NMTOKEN";
| A_nmtokens -> wms " NMTOKENS";
| A_notation nl ->
wms " NOTATION (";
( match nl with
nl1:: nl' ->
wms nl1;
List.iter
(fun n ->
wms ("|" ^ n);
)
nl'
| [] ->
failwith "#write: Illegal content model";
);
wms ")";
| A_enum el ->
wms " (";
( match el with
el1:: el' ->
wms el1;
List.iter
(fun e ->
wms ("|" ^ e);
)
el'
| [] ->
failwith "#write: Illegal content model";
);
wms ")";
);
( match d with
D_required -> wms " #REQUIRED"
| D_implied -> wms " #IMPLIED"
| D_default s ->
wms " \"";
write_data_string ~from_enc:encoding ~to_enc:enc os s;
wms "\"";
| D_fixed s ->
wms " FIXED \"";
write_data_string ~from_enc:encoding ~to_enc:enc os s;
wms "\"";
);
)
(List.sort (fun (n1,x1) (n2,x2) -> compare n1 n2) attributes);
wms ">\n";
(************************************************************)
(* VALIDATION *)
(************************************************************)
method validate =
self # validate_attributes();
self # validate_content_model()
method private validate_attributes() =
if attributes_validated then
()
else begin
(* Validity Constraint: One ID per Element Type *)
let n = count (fun (n,((t,d),_)) -> t = A_id) attributes in
if n > 1 then
raise(Validation_error("More than one ID attribute for element `" ^ name ^ "'"));
(* Validity Constraint: ID Attribute Default *)
if List.exists
(fun (n,((t,d),_)) ->
t = A_id && (d <> D_required && d <> D_implied))
attributes
then
raise(Validation_error("ID attribute must be #IMPLIED or #REQUIRED; element `" ^ name ^ "'"));
(* Validity Constraint: One Notation per Element Type *)
let n = count (fun (n,((t,d),_)) ->
match t with A_notation _ -> true | _ -> false)
attributes in
if n > 1 then
raise(Validation_error("More than one NOTATION attribute for element `" ^ name ^ "'"));
(* Validity Constraint: Notation Attributes [second part] *)
List.iter
(fun (n,((t,d),_)) ->
match t with
A_notation l ->
List.iter
(fun nname ->
let _ = dtd # notation nname in ())
l
| _ -> ())
attributes;
(* Validity Constraint: Attribute Default Legal *)
List.iter
(fun (n,((t,d),_)) ->
let check v =
let lexical_error() =
lazy (raise(Validation_error("Default value for attribute `" ^ n ^ "' is lexically malformed"))) in
check_attribute_value_lexically lfactory (lexical_error()) t v;
begin match t with
(A_entity|A_entities) ->
List.iter
(fun nd ->
let en, extdecl = dtd # gen_entity nd in
if not (en # is_ndata) then
raise(Validation_error("Attribute default value must be the name of an NDATA entity; attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
(* if dtd # standalone_declaration && extdecl then
raise(Validation_error("Attribute default value violates the standalone declaration; attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
-- This is checked anyway when the attribute value is normalized
*)
)
(split_attribute_value lfactory v)
| A_notation nl ->
if not (List.mem v nl) then
raise(Validation_error("Illegal default value for attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
| A_enum nl ->
if not (List.mem v nl) then
raise(Validation_error("Illegal default value for attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
| _ -> ()
end
in
match d with
D_required -> ()
| D_implied -> ()
| D_default v -> check v
| D_fixed v -> check v
)
attributes;
(* Ok: This element declaration is valid *)
attributes_validated <- true;
end
method private validate_content_model () =
(* checks:
* - Validity Constraint: No Duplicate Types
* It is not an error if there is a child in the declaration for which
* no element declaration is provided.
*)
match content_model with
Unspecified ->
warn (dtd#swarner) (dtd#warner)
(`W_element_mentioned_but_not_declared name);
()
| Empty -> ()
| Any -> ()
| Mixed (pcdata :: l) ->
(* MPCDATA is always the first element by construction *)
assert (pcdata = MPCDATA);
if check_dups l then
raise (Validation_error("Double children in declaration for element `" ^ name ^ "'"))
| Regexp _ -> ()
| _ -> assert false
(************************************************************)
end
and dtd_notation the_name the_xid init_encoding =
object (self)
val name = the_name
val xid = (the_xid : ext_id)
val encoding = (init_encoding : Pxp_core_types.I.rep_encoding)
method name = name
method ext_id = xid
method encoding = encoding
method write os enc =
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
let write_sysid s =
if String.contains s '"' then
wms ("'" ^ s ^ "'")
else
wms ("\"" ^ s ^ "\"");
in
wms ("<!NOTATION " ^ name ^ " ");
( match xid with
System s ->
wms "SYSTEM ";
write_sysid s;
| Public (p,s) ->
wms "PUBLIC ";
write_sysid p;
if (s <> "") then begin
wms " ";
write_sysid s;
end;
| Anonymous ->
failwith "#write: External ID `Anonymous' cannot be represented"
| Private _ ->
failwith "#write: External ID `Private' cannot be represented"
);
wms ">\n";
end
and proc_instruction the_target the_value init_encoding =
object (self)
val target = the_target
val value = (the_value : string)
val encoding = (init_encoding : Pxp_core_types.I.rep_encoding)
initializer
match target with
("xml"|"xmL"|"xMl"|"xML"|"Xml"|"XmL"|"XMl"|"XML") ->
(* This is an error, not a warning, because I do not have a
* "warner" object by hand.
*)
raise(WF_error("Reserved processing instruction"))
| _ -> ()
method target = target
method value = value
method encoding = encoding
method write os enc =
let wms =
write_markup_string ~from_enc:encoding ~to_enc:enc os in
wms "<?";
wms target;
wms " ";
wms value;
wms "?>";
method parse_pxp_option =
let lfactory = get_lexer_factory encoding in
try
let toks = tokens_of_xml_pi lfactory value in (* may raise WF_error *)
begin match toks with
(Pro_name option_name) :: toks' ->
let atts = decode_xml_pi toks' in (* may raise WF_error *)
(target, option_name, atts)
| _ ->
raise(Error("Bad PXP processing instruction"))
end
with
WF_error _ ->
raise(Error("Bad PXP processing instruction"))
end
;;
let create_dtd ?swarner ?(warner = new drop_warnings) enc =
new dtd ?swarner warner enc ;;
type source =
Entity of ((dtd -> Pxp_entity.entity) * Pxp_reader.resolver)
| ExtID of (ext_id * Pxp_reader.resolver)
| XExtID of (ext_id * string option * Pxp_reader.resolver)
;;
module Entity = struct
let get_name ent = ent # name
let get_full_name ent = ent # full_name
let get_encoding ent = ent # encoding
let get_type ent =
if ent # is_ndata then `NDATA else
try ignore(ent # ext_id); `External with Not_found -> `Internal
let replacement_text ent = fst(ent # replacement_text)
let get_xid ent =
try Some(ent # ext_id) with Not_found -> None
let get_resolver_id ent =
try Some(ent # resolver_id) with Not_found -> None
let get_notation ent =
if ent # is_ndata then Some (ent # notation) else None
let create_internal_entity ~name ~value dtd =
new internal_entity dtd name (dtd # swarner) (dtd # warner) value
false false (dtd # encoding)
let create_ndata_entity ~name ~xid ~notation dtd =
new ndata_entity name xid notation dtd#encoding
let create_external_entity ?(doc_entity = false) ?system_base
~name ~xid ~resolver dtd =
if doc_entity then
new document_entity resolver dtd name dtd#swarner dtd#warner xid
system_base dtd#encoding
else
new external_entity resolver dtd name dtd#swarner dtd#warner xid
system_base false dtd#encoding
let from_external_source ?doc_entity ~name dtd src =
match src with
ExtID(xid,resolver) ->
create_external_entity ?doc_entity ~name ~xid ~resolver dtd
| XExtID(xid,system_base,resolver) ->
create_external_entity ?doc_entity ?system_base
~name ~xid ~resolver dtd
| Entity(make,resolver) ->
make dtd (* resolver ignored *)
let entity_id ent = (ent :> entity_id)
class fake = object method pxp_magic_coercion() : unit = raise Not_found end
let create_entity_id () = new fake
let lookup eid =
try
let () = eid#pxp_magic_coercion() in
assert false
with
| Not_found -> invalid_arg "Pxp_dtd.Event.lookup"
| Pxp_entity.Coerced_entity e -> e
end
