(* $Id$ -*- tuareg -*-
* ----------------------------------------------------------------------
* PXP: The polymorphic XML parser for Objective Caml.
* Copyright by Gerd Stolpmann. See LICENSE for details.
*)
open Pxp_types
open Pxp_lexers
open Pxp_lexer_types
open Pxp_entity_manager
open Pxp_dtd
open Pxp_aux
type context =
{ mutable current : unit -> token; (* get the current token *)
mutable get_next : unit -> token; (* go on to the next token; return it *)
mutable current_token : token; (* This is the current token *)
mutable manager : entity_manager; (* The entity manager *)
}
type continuation_state =
{ cont_context : context;
cont_extend_dtd : bool;
cont_process_xmldecl : bool;
}
exception End_of_parsing
(* One way to signal that parsing is done *)
exception Interrupt_parsing of continuation_state
(* Interrupt the parsing loop to process pull-style events *)
let make_context ?first_token entity_manager =
let c =
{ current = (fun _ -> assert false);
get_next = (fun _ -> assert false);
current_token = Eof;
manager = entity_manager;
}
in
(* Note that the function which is stored in get_next_ref can be changed
* as a side-effect when an entity is opened or closed. The function in
* c.get_next must be programmed such that always the current "get_next"
* function is executed.
*)
let get_next_ref = entity_manager # yy_get_next_ref in
c.current <- (fun () -> c.current_token);
c.get_next <- (fun () -> let tok = !get_next_ref() in
c.current_token <- tok;
tok);
( match first_token with
Some tok ->
c.current_token <- tok
| None ->
ignore(c.get_next());
);
c
;;
type extended_entry =
[ entry
| `Entry_continuation of continuation_state
]
(**********************************************************************)
(* An array based stack implementation. Advantage: Constant memory
* consumption.
*)
type 't array_stack =
{ mutable stack_array : 't array;
mutable stack_top : int;
mutable stack_null : 't;
}
;;
let stack_create null =
(* null: a dummy element *)
{ stack_array = Array.make 100 null;
stack_top = -1;
stack_null = null;
}
;;
let stack_push x st =
let top = st.stack_top + 1 in
if top >= Array.length st.stack_array then
st.stack_array <- Array.append
st.stack_array (Array.make 100 st.stack_null);
st.stack_array.(top) <- x;
st.stack_top <- top
;;
let stack_top st =
let top = st.stack_top in
if top >= 0 then
st.stack_array.(top)
else
raise Stack.Empty
;;
let stack_pop st =
let top = st.stack_top in
if top >= 0 then begin
let x = st.stack_array.(top) in
st.stack_array.(top) <- st.stack_null;
st.stack_top <- top-1;
x
end
else
raise Stack.Empty
;;
(**********************************************************************)
class virtual core_parser
init_dtd init_config init_pull_counter
=
let make_pool_string = pool_string init_config.name_pool in
object (self)
val mutable dtd = init_dtd
(* The DTD being parsed; or the DTD currently assumed *)
val lfactory = init_dtd # lexer_factory
val config = init_config
(* The current configuration *)
val mutable n_tags_open = 0
(* Number of begin tags that have been parsed and whose corresponding
* end tags have not yet been parsed
*)
val mutable n_entities_open = 0
(* Number of open Begin_entity tokens. If this number decreases to 0
* the parser will terminate.
*)
val pull_counter_limit = init_pull_counter
val mutable pull_counter = init_pull_counter
(* If < 0, pull parsing is disabled.
* If >= 0: pull_counter is decreased for every parsing loop. If
* zero, pull_counter is reinitialized to pull_counter_limit, and
* an Interrupt_parsing exception is raised.
*)
val mutable p_internal_subset = false
(* true while parsing the internal subset - there are some additional
* constraints for internal subsets, and because of this it must
* be known whether the current declaration is contained in the
* internal or external subset of the DTD.
*)
val mutable permit_any_content = false
(* Used with `Entry_content to allow entity references outside
elements and to turn off other parsing restrictions
*)
method private only_whitespace data =
(* Checks that the string "data" contains only whitespace. On failure,
* Validation_error is raised.
*)
if not (Pxp_lib.only_whitespace data) then
raise(WF_error("Data not allowed here"));
()
(************************************************************************)
(* Namespace processing: The following values and methods MAY be used
* 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 = ""
*)
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
* [name]: source name of element
* [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)
attlist
(* TODO: Check that localname matches NCName *)
in
let xmlns_attlist = ref [] in
let xmlns_default = ref None in
let regular_attlist = ref [] in
List.iter
(fun ((prefix, localname), value) ->
if prefix = "" && localname = "xmlns" then
xmlns_default := Some value
else
if prefix = "xmlns" then
xmlns_attlist := (localname, value) :: !xmlns_attlist
else
regular_attlist := (prefix, localname,value) :: !regular_attlist
)
split_attlist;
let mapping = ref [] in
List.iter
(fun (srcprefix, uri) ->
let _normprefix =
mng # lookup_or_add_namespace srcprefix uri in
mapping := (srcprefix, uri) :: !mapping;
)
!xmlns_attlist;
(* Apply xmlns_default: *)
( match !xmlns_default with
None -> ()
| Some "" ->
(* Delete default namespace: *)
ns_default_normprefix <- "";
mapping := ("", "") :: !mapping;
| Some uri ->
let normprefix =
try mng # get_normprefix uri
with Namespace_not_managed _ ->
mng # lookup_or_add_namespace "default" uri
in
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;
(* Clear cache - otherwise the new declarations wouldn't have any
effect
*)
if !mapping <> [] then
ns_cache <- StringMap.empty;
(* NB. normalize_namespace_prefix uses the new values for
ns_scope and ns_cache, so these vars must already be updated
*)
(* Normalize the regular_attlist: *)
let norm_attlist =
List.map
(fun (prefix, localname, value) ->
(prefix,
localname,
self # normalize_namespace_prefix prefix localname,
value
)
)
!regular_attlist
in
(* Normalize the element name: *)
let prefix, localname = namespace_split name in
(* TODO: Check that localname matches NCName *)
let norm_name =
self # normalize_namespace_prefix
~apply_default:true prefix localname in
(prefix, localname, norm_name, norm_attlist)
method private pop_src_norm_mapping () =
(* Pop until the guard is found *)
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
?(apply_default = false) prefix localname =
if String.contains localname ':' then
raise(Namespace_error("Found several colons in a name"));
if prefix = "" then begin
(* No prefix *)
if apply_default && ns_default_normprefix <> "" then
ns_default_normprefix ^ ":" ^ localname
else
localname
end
else begin
(* Prefix exists *)
let normprefix =
try
StringMap.find prefix ns_cache
with
Not_found ->
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
method private virtual sub_parser : unit -> core_parser
(************************************************************************)
(* Events. The parser calls these methods, and the subclass must
* define them
*)
method private virtual init_for_xml_body : entity_id -> unit
method private virtual event_document_xmldecl :
Pxp_lexer_types.prolog_token list -> unit
method private virtual event_start_tag :
(string*int*int) option ->
string ->
(string * string) list ->
bool ->
entity_id ->
unit
method private virtual event_end_tag :
string ->
entity_id ->
unit
method private virtual event_char_data : string -> unit
method private virtual event_pinstr :
(string*int*int) option ->
string ->
string ->
entity_id ->
unit
method private virtual event_comment :
(string*int*int) option ->
string list ->
unit
(************************************************************************)
initializer
(* CHECKS: *)
if config.encoding <> dtd # encoding then
failwith("Encoding mismatch");
(********* Here the method "parse" begins. The grammar below is
* transformed to a local function of this method
*)
method parse context (start_symbol : extended_entry) =
(* extend_dtd:
* Whether the DTD should be extended by ELEMENT, ATTLIST, and
* NOTATION declarations or not. (True for validating mode,
* false for well-formedness mode.)
*)
let extend_dtd =
match start_symbol with
`Entry_document flags ->
List.mem `Extend_dtd_fully flags ||
List.mem `Val_mode_dtd flags
| `Entry_declarations flags ->
List.mem `Extend_dtd_fully flags ||
List.mem `Val_mode_dtd flags
| `Entry_continuation st ->
st.cont_extend_dtd
| _ ->
false
in
( match start_symbol with
`Entry_document flags ->
if not (List.mem `Val_mode_dtd flags) then
(* Instead of dtd # allow_arbitrary, because the processing
* instruction survives marshalling:
*)
dtd # add_pinstr
(new proc_instruction
"pxp:dtd"
"optional-element-and-notation-declarations"
config.encoding);
| `Entry_declarations flags ->
if not (List.mem `Val_mode_dtd flags) then
dtd # add_pinstr
(new proc_instruction
"pxp:dtd"
"optional-element-and-notation-declarations"
config.encoding);
| _ ->
()
);
(* process_xmldecl:
* Whether the XML declaration is parsed and the found XML version
* and standalone declaration are passed to 'doc'.
*)
let process_xmldecl =
match start_symbol with
`Entry_document flags ->
List.mem `Parse_xml_decl flags
| `Entry_continuation st ->
st.cont_process_xmldecl
| _ -> false
in
let parse_ignored_section yy_current yy_get_next =
(* A special parser which should be used after <![IGNORE[.
* It parses until the corresponding ]]> is found.
*)
while yy_current() = Ignore do
ignore(yy_get_next());
done;
( match yy_current() with
Conditional_body _ -> ()
| _ -> raise Parsing.Parse_error;
);
let en = context.manager # current_entity in
let llev = ref 1 in
while !llev >= 1 do
let igntok = en # next_ignored_token in
(* next_ignored_token: uses a special lexer that only
* recognizes Conditional_begin and Conditional_end;
* other character combinations are ignored.
*)
(* NOTE: next_ignored_token works much like yy_get_next,
* but it does not set the current token!
*)
match igntok with
Conditional_begin _ ->
llev := !llev + 1
| Conditional_end _ ->
llev := !llev - 1;
(* Because the loop may be exited now: *)
context.current_token <- igntok;
| (End_entity | Eof) ->
raise Parsing.Parse_error
| _ ->
()
done;
in
let recode_utf8 s =
(* Recode 's' to UTF-8 *)
if config.encoding = `Enc_utf8 then
s (* No recoding necessary *)
else
Netconversion.convert
~in_enc:(config.encoding :> encoding) ~out_enc:`Enc_utf8 s
in
let process_curly_brace tok =
let s =
match config.escape_contents with
None ->
( match tok with
Lcurly -> "{"
| LLcurly -> "{{"
| Rcurly -> "}"
| RRcurly -> "\125\125"
| _ -> assert false
)
| Some f ->
f tok context.manager
in
if s <> "" then begin
if n_tags_open = 0 then
self # only_whitespace s
else
self # event_char_data s
end
in
let process_attribute_event tok pos =
match config.escape_attributes with
None -> assert false
| Some f ->
f tok pos context.manager
in
let reused_lexobj = lfactory # open_string "" in
%%
/* The following grammar looks similar to ocamlyacc grammars, but
* ocamlyacc is actually not used to transform the grammar into a parser.
* Instead, the parser generator m2parsergen is applied.
*
* The format of the grammar is different (see m2parsergen/README),
* but I hope that you can understand most features immediately.
*
* The type of the parser is different: m2parsergen creates a top-down
* parser while ocamlyacc generates a LALR-1 parser.
*
* The way the generated code is called is different: ocamlyacc produces
* lots of top-level definitions whereas m2parsergen generates only
* a local let-in-phrase. This is explained in the already mentioned
* README file.
*/
/* See Pxp_core_types.ml for comments to the various tokens */
%token Begin_entity
%token End_entity
%token <> Comment_begin
%token <> Comment_end
%token Ignore
%token Eq
%token Rangle
%token Rangle_empty
%token <> Conditional_begin
%token <> Conditional_body
%token <> Conditional_end
%token Percent
%token Plus
%token Star
%token Bar
%token Comma
%token Qmark
%token Pcdata
%token Required
%token Implied
%token Fixed
%token Eof
%token Lcurly
%token LLcurly
%token Rcurly
%token RRcurly
%token SQuote
%token DQuote
%token <> Comment_material
%token <> Doctype
%token <> Doctype_rangle
%token <> Dtd_begin
%token <> Dtd_end
%token <> Decl_element
%token <> Decl_attlist
%token <> Decl_entity
%token <> Decl_notation
%token <> Decl_rangle
%token <> Lparen
%token <> Rparen
%token <> RparenPlus
%token <> RparenStar
%token <> RparenQmark
%token <> Tag_beg
%token <> Tag_end
%token <> PI
%token <> PI_xml
%token <> Cdata
%token <> CRef
%token <> ERef
%token <> ERef_att
%token <> PERef
%token <> CharData
%token <> LineEnd
%token <> Name
%token <> Nametoken
%token <> Attval
%token <> Attval_nl_normalized
%token <> Unparsed_string
/* START SYMBOLS:
*
* "entry_document": parses a complete XML document (i.e. containing a
* <!DOCTYPE..> and an element)
* "entry_declarations": parses an "external DTD subset", i.e. a sequence
* of declarations
* "entry_element_content": parses a single element (no <!DOCTYPE...> allowed);
* the element needs not to be the root element of the
* DTD
*
* The functions corresponding to these symbols return always () because
* they only have side-effects.
*/
/* SOME GENERAL COMMENTS:
*
* The parser does not get its tokens from the lexers directly. Instead of
* this, there is an entity object between the parser and the lexers. This
* object already handles:
*
* - References to general and parameter entities. The token stream is
* modified such that tokens automatically come from the referenced entities.
* External parameter entities and all general entities are embraced by
* the two special tokens Begin_entity and End_entity. The parser must
* check that these braces are correctly nested.
*/
%%
entry_document():
Begin_entity
$ {{ n_entities_open <- n_entities_open + 1; }}
doc_xmldecl_then_misc_then_prolog_then_body()
{{
(* Note: In pull parsing mode, the following code won't be executed! *)
()
}}
/* In the following rule, we must find out whether there is an XML declaration
* or not, and directly after that either "process_xmldecl" or
* "process_missing_xmldecl" of the current entity must be called.
* AND IT MUST BE DIRECTLY! Because of this, the invocation is carried out
* in the "$" clause immediately following the first token.
*
* TODO: This is not enough. The first token may be a tag, and the tag
* may already contain non-ASCII characters. (But in this case, the resolvers
* assume UTF8, and they are right...)
*/
doc_xmldecl_then_misc_then_prolog_then_body():
pl:PI_xml
$ {{ context.manager # current_entity # process_xmldecl pl;
if process_xmldecl then self # event_document_xmldecl pl;
}}
misc()* doc_prolog_then_body()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
misc() misc()* doc_prolog_then_body()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
doctypedecl() misc()* body_start()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
body_start()
{{ () }}
doc_prolog_then_body():
doctypedecl() misc()* body_start()
{{ () }}
| body_start()
{{ () }}
entry_element_content():
Begin_entity
$ {{ n_entities_open <- n_entities_open + 1; }}
el_xmldecl_then_misc_then_body()
{{
(* Note: In pull parsing mode the following code won't be executed! *)
()
}}
entry_content():
Begin_entity
$ {{ permit_any_content <- true;
n_entities_open <- n_entities_open + 1;
}}
el_xmldecl_then_entity_body()
{{
(* Note: In pull parsing mode the following code won't be executed! *)
()
}}
/* See comment for doc_mldecl_then_misc_then_prolog_then_body. */
el_xmldecl_then_misc_then_body():
pl:PI_xml
$ {{ context.manager # current_entity # process_xmldecl pl; }}
misc()* body_start()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
misc() misc()* body_start()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
body_start()
{{ () }}
el_xmldecl_then_entity_body():
pl:PI_xml
$ {{ context.manager # current_entity # process_xmldecl pl; }}
entity_body()
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
entity_body()
{{ () }}
entry_declarations():
/* Parses a sequence of declarations given by an entity. As side-effect,
* the parsed declarations are put into the dtd object.
*
* Note: The following Begin_entity is not counted because this entity
* will certainly be closed when pull parsing mode is entered.
*/
Begin_entity decl_xmldecl_then_body()
{{ () }}
| Eof
{{ () }}
decl_xmldecl_then_body():
/* Note: This rule is also called from declaration()! */
pl:PI_xml
$ {{ context.manager # current_entity # process_xmldecl pl;
}}
declaration()* End_entity
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
declaration() declaration()* End_entity
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
End_entity
{{ () }}
misc():
pi()
{{ () }}
| data: CharData
/* In this context, the lexers sometimes do not recognize white space;
* instead CharData tokens containing white space are delivered.
*/
{{ self # only_whitespace data }}
| Ignore
{{ () }}
| comment()
{{ () }}
/********************* DOCUMENT TYPE DECLARATION *************************/
doctypedecl():
/* parses from <!DOCTYPE to >. As side-effect, first the declarations of
* the internal DTD (if any) are put into !!on_dtd, then the declarations
* of the external DTD (if any) are put into this DTD object.
*/
doctype_entid: Doctype
ws: Ignore Ignore*
doctypedecl_material (doctype_entid)
{{ () }}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after `DOCTYPE'"))
| _ -> raise(WF_error("Bad DOCTYPE declaration"))
}}
/* TRICK:
* ws: Ignore? Ignore*
* is meant seriously. The effect is that ws becomes a boolean variable
* which is true if there is an Ignore token and false otherwise.
* This construct is faster than just
* ws: Ignore*
* in which case ws becomes an integer variable containing the number of
* Ignore tokens. Counting the number of tokens is slower than only checking
* the existence.
*
* We need the information whether there is an Ignore token (representing
* white space), because white space is only obligatory if also an identifier
* for the external subset is parsed; this conditional syntax constraint is
* simply programmed in the body of the grammar rule.
*/
doctypedecl_material(doctype_entid):
root_name: Name
ws: Ignore? Ignore*
external_subset: external_id()?
Ignore*
internal_subset: internal_dtd()?
Ignore*
doctype_rangle_entid: Doctype_rangle
{{
if doctype_entid != doctype_rangle_entid then
raise (Validation_error("Entities not properly nested with DOCTYPE declaration"));
dtd # set_root root_name;
begin match external_subset, internal_subset with
None, None -> () (* no DTD means no ID *)
| None, Some _ -> dtd # set_id Internal
| Some id, None -> dtd # set_id (External id)
| Some id, Some _ -> dtd # set_id (Derived id)
end;
(* Get now the external doctype declaration. Note that the internal
* subset has precedence and must be read first.
*)
begin match external_subset with
None -> ()
| Some id ->
if not ws then
raise(WF_error("Whitespace is missing after `DOCTYPE " ^
root_name ^ "'"));
let resolver =
context.manager # current_resolver # clone in
let system_base =
(context.manager # current_resolver # active_id).rid_system in
let pobj = self # sub_parser() in
let en = new Pxp_entity.external_entity resolver dtd "[dtd]"
config.swarner config.warner id system_base false
config.encoding
in
en # set_debugging_mode (config.debugging_mode);
let mgr = new entity_manager en dtd in
en # open_entity true Declaration;
begin try
let context = make_context mgr in
let flags =
(if extend_dtd then [`Extend_dtd_fully] else []) in
pobj # parse context (`Entry_declarations flags);
mgr # pop_entity_until en;
if en # is_open then ignore(en # close_entity);
with
error ->
(* When the error happens, the current entity can be
* different than [en]. So the entity stack is muddled up,
* and we need to pop entites until we find [en] again.
*)
let pos = mgr # position_string in
mgr # pop_entity_until en;
if en # is_open then ignore(en # close_entity);
raise (At(pos, error))
end;
end;
dtd # validate
}}
? {{
match !yy_position with
"doctype_rangle_entid" -> raise(WF_error("`>' expected"))
| _ -> raise(WF_error("Bad DOCTYPE declaration"))
}}
/* Note that there are no keywords for SYSTEM or PUBLIC, as these would
* be difficult to recognize in the lexical contexts. Because of this,
* SYSTEM/PUBLIC is parsed as name, and the rule for everything after
* SYSTEM/PUBLIC is computed dynamically.
*/
external_id():
tok:Name
$ {{
let followup =
match tok with
"SYSTEM" -> parse_system_id
(* Apply the rule system_id (below) to parse the
* rest of the ID
*)
| "PUBLIC" -> parse_public_id
(* Apply the rule public_id (below) to parse the
* rest of the ID
*)
| _ -> raise(WF_error("SYSTEM or PUBLIC expected"))
in
}}
ws:Ignore Ignore*
r:[followup]()
{{ r }}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after " ^ tok))
| _ -> raise(WF_error("Bad SYSTEM or PUBLIC identifier"))
}}
system_id():
str:Unparsed_string
{{ System (recode_utf8 str) }}
public_id():
str1: Unparsed_string
ws: Ignore Ignore*
str2: Unparsed_string
{{ check_public_id str1;
Public(recode_utf8 str1, recode_utf8 str2)
}}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing between the literals of the PUBLIC identifier"))
| _ -> raise(WF_error("Bad PUBLIC identifier"))
}}
/* The internal subset: "[" declaration* "]". While parsing the declarations
* the object variable p_internal_subset must be true; however, if there
* are entity references, this variable must be reset to false during
* the entity. (See the rule for "declaration" below.)
*/
internal_dtd():
dtd_begin_entid: internal_dtd_begin()
declaration()*
dtd_end_entid: internal_dtd_end()
{{
if dtd_begin_entid != dtd_end_entid then
raise(Validation_error("Entities not properly nested with internal DTD subset"))
}}
? {{ match !yy_position with
"dtd_end_entid" -> raise(WF_error("`]' expected"))
| _ -> raise(WF_error("Bad internal DTD subset"))
}}
internal_dtd_begin():
Dtd_begin
{{ assert (not p_internal_subset);
p_internal_subset <- true }}
internal_dtd_end():
Dtd_end
{{ assert p_internal_subset;
p_internal_subset <- false }}
declaration():
/* Parses a single declaration (or processing instruction). As side-effect
* the parsed declaration is stored into the dtd object.
*/
elementdecl()
{{ () }}
| attlistdecl()
{{ () }}
| entid:Decl_entity ws:Ignore Ignore* _e:entitydecl(entid)
{{ () }}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after ENTITY"))
| "_e" -> raise(WF_error("Name or `%' expected"))
| _ -> raise(WF_error("Bad entity declaration"))
}}
| notationdecl()
{{ () }}
| pi: PI
{{ let target, value, ent_id = pi in
let pi = new proc_instruction target value config.encoding in
dtd # add_pinstr pi
}}
| Ignore
{{ () }}
| begin_entid:Comment_begin Comment_material* end_entid:Comment_end
{{
if begin_entid != end_entid then
raise(Validation_error("The first and the last token of comments must be in the same entity"));
}}
? {{ match !yy_position with
"end_entid" -> raise(WF_error("`-->' expected"))
| _ -> raise(WF_error("Bad comment"))
}}
| Begin_entity
$ {{ (* Set 'p_internal_subset' to 'false' until the matching 'end_entity'
* rule is parsed. This allows unrestricted usage of parameter entities
* within declarations of internal entities.
*)
let old_p_internal_subset = p_internal_subset in
p_internal_subset <- false;
}}
decl_xmldecl_then_body()
{{ (* Restore the old value of 'p_internal_subset'. *)
p_internal_subset <- old_p_internal_subset;
()
}}
| begin_entid:Conditional_begin
$ {{ (* Check whether conditional sections are allowed at this position. *)
if p_internal_subset then
raise(WF_error("Restriction of the internal subset: Conditional sections not allowed"));
}}
Ignore*
_cond:conditional_section() end_entid:Conditional_end
{{ (* Check whether Conditional_begin and Conditional_end are in the same
* entity. (This restriction is explained in the file SPECS.)
*)
if begin_entid != end_entid then
raise(Validation_error("The first and the last token of conditional sections must be in the same entity (additional restriction of this parser)"));
}}
? {{ match !yy_position with
"end_entid" -> raise(WF_error("`>]>' expected"))
| "_cond" -> raise(WF_error("INCLUDE or IGNORE expected"))
| _ -> raise(WF_error("Bad conditional section"))
}}
/* The tokens INCLUDE/IGNORE are scanned as names, and the selection of the
* right parsing rule is dynamic.
* Note that parse_ignored_section is not defined by a grammar rule but
* by a conventional let-binding above.
*/
conditional_section():
include_or_ignore:Name
$ {{ let parsing_function =
match include_or_ignore with
"INCLUDE" -> parse_included_section
(* invoke rule "included_section" below *)
| "IGNORE" -> parse_ignored_section
(* invoke function "parse_ignored_section" *)
| _ -> raise(WF_error("INCLUDE or IGNORE expected"))
in
}}
[ parsing_function ] ()
{{ () }}
? {{ ignore(!yy_position); raise(WF_error("Bad conditional section")) }}
included_section():
Conditional_body declaration()*
{{ () }}
| Ignore Ignore* Conditional_body declaration()*
{{ () }}
/*************************** ELEMENT DECLARATIONS ********************/
elementdecl():
/* parses <!ELEMENT ... >. Puts the parsed element type as side-effect into
* dtd.
*/
decl_element_entid: Decl_element
$ {{ let extdecl = context.manager # current_entity_counts_as_external in
}}
ws1: Ignore Ignore*
name: Name
ws2: Ignore Ignore*
content_model: contentspec()
Ignore*
decl_rangle_entid: Decl_rangle
{{
if decl_element_entid != decl_rangle_entid then
raise (Validation_error "Entities not properly nested with ELEMENT declaration");
if extend_dtd then begin
let el = new dtd_element dtd name in
(* It is allowed that an <!ATTLIST...> precedes the corresponding
* <!ELEMENT...>. Because of this it is possible that there is already
* an element called 'name' in the DTD, and we only must set the content
* model of this element.
*)
try
dtd # add_element el;
el # set_cm_and_extdecl content_model extdecl;
with
Not_found -> (* means: there is already an element 'name' *)
let el' = dtd # element name in
el' # set_cm_and_extdecl content_model extdecl;
(* raises Validation_error if el' already has a content model *)
end
}}
? {{ match !yy_position with
("ws1"|"ws2") -> raise(WF_error("Whitespace is missing"))
| "name" -> raise(WF_error("The name of the element is expected here"))
| "content_model" -> raise(WF_error("Content model expression expected"))
| "decl_rangle_entid" -> raise(WF_error("`>' expected"))
| _ -> raise(WF_error("Bad element type declaration"))
}}
contentspec():
/* parses a content model and returns it (type content_model_type) */
name: Name /* EMPTY or ANY */
{{ match name with
"EMPTY" -> Empty
| "ANY" -> Any
| _ -> raise(WF_error("EMPTY, ANY, or a subexpression expected"))
}}
| entid:Lparen Ignore* term:mixed_or_regexp(entid)
{{ term }}
? {{ raise(WF_error("Bad content model expression")) }}
/* Many of the following rules have an lparen_entid argument. This is the
* internal ID of the entity containing the corresponding left parenthesis;
* by comparing it with the ID of the entity of the right parenthesis the
* contraint is implemented that both parentheses must be in the same entity.
*/
mixed_or_regexp(lparen_entid):
re: choice_or_seq(lparen_entid)
{{ Regexp re }}
| m: mixed(lparen_entid)
{{ m }}
multiplier():
/* returns one of the multiplier symbols (?,*,+) */
Plus
{{ Plus }}
| Star
{{ Star }}
| Qmark
{{ Qmark }}
mixed (lparen_entid) :
Pcdata
Ignore*
material: mixed_alternatives_top()
{{
let rest, rparen_entid = material in
if lparen_entid != rparen_entid then
raise (Validation_error "Entities not properly nested with parentheses");
Mixed (MPCDATA :: rest)
}}
? {{ raise(WF_error("Bad content model expression")) }}
mixed_alternatives_top():
entid: Rparen
{{ [], entid }}
| entid: RparenStar
{{ [], entid }}
| Bar Ignore* name:Name Ignore* names:mixed_alternative()* entid:RparenStar
{{
(MChild name :: names), entid
}}
? {{ match !yy_position with
"name" -> raise(WF_error("Name expected"))
| "entid" -> raise(WF_error("`)*' expected"))
| _ -> raise(WF_error("Bad content model expression"))
}}
mixed_alternative() :
Bar Ignore* name:Name Ignore*
{{ MChild name }}
? {{ match !yy_position with
"name" -> raise(WF_error("Name expected"))
| _ -> raise(WF_error("Bad content model expression"))
}}
choice_or_seq (lparen_entid):
/* parses either a regular expression, or a mixed expression. Returns
* Mixed spec or Regexp spec (content_model_type).
* Which kind of expression (regexp or mixed) is being read is recognized
* after the first subexpression has been parsed; the other subexpressions
* must be of the same kind.
*/
re: cp()
Ignore*
factor: choice_or_seq_factor()
{{
let (finalmark,subexpr), rparen_entid = factor in
if lparen_entid != rparen_entid then
raise (Validation_error "Entities not properly nested with parentheses");
(* Check that the other subexpressions are "regexp", too, and
* merge them with the first.
*)
let re' =
match subexpr with
Alt [] -> re
| Alt alt -> Alt (re :: alt)
| Seq seq -> Seq (re :: seq)
| _ -> assert false
in
(* Interpret the finalmark. *)
match finalmark with
Ignore -> re'
| Plus -> Repeated1 re'
| Star -> Repeated re'
| Qmark -> Optional re'
| _ -> assert false
}}
? {{ raise(WF_error("Bad content model expression")) }}
choice_or_seq_factor():
/* Parses "|<subexpr>|...)" or ",<subexpr>,...)", both forms optionally
* followed by ?, *, or +.
* Returns ((finalmark, expr), rparen_entid), where
* - finalmark is the character after the right parenthesis or Ignore
* - expr is either
* Alt [] meaning that only ")" has been found
* Alt non_empty_list meaning that the subexpressions are separated by '|'
* Seq non_empty_list meaning that the subexpressions are separated by ','
*/
entid:Rparen
{{ (Ignore, Alt []), entid }}
| entid:RparenPlus
{{ (Plus, Alt []), entid }}
| entid:RparenStar
{{ (Star, Alt []), entid }}
| entid:RparenQmark
{{ (Qmark, Alt []), entid }}
| Bar Ignore* re:cp() Ignore* factor:choice_or_seq_factor()
{{
let (finalmark, subexpr), rparen_entid = factor in
begin match subexpr with
Alt [] -> (finalmark, (Alt [re])), rparen_entid
| Alt alt -> (finalmark, (Alt (re :: alt))), rparen_entid
| _ -> raise(WF_error("It is not allowed to mix alternatives and sequences"))
end
}}
? {{ raise(WF_error("Bad content model expression")) }}
| Comma Ignore* re:cp() Ignore* factor:choice_or_seq_factor()
{{
let (finalmark, subexpr), rparen_entid = factor in
begin match subexpr with
Alt [] -> (finalmark, (Seq [re])), rparen_entid
| Seq seq -> (finalmark, (Seq (re :: seq))), rparen_entid
| _ -> raise(WF_error("It is not allowed to mix alternatives and sequences"))
end
}}
? {{ raise(WF_error("Bad content model expression")) }}
cp():
/* parse either a name, or a parenthesized subexpression "(...)" */
name:Name m:multiplier()?
{{ match m with
None -> Child name
| Some Plus -> Repeated1 (Child name)
| Some Star -> Repeated (Child name)
| Some Qmark -> Optional (Child name)
| _ -> assert false
}}
? {{ raise(WF_error("Bad content model expression")) }}
| entid:Lparen Ignore* m:choice_or_seq(entid)
{{ m }}
? {{ raise(WF_error("Bad content model expression")) }}
/********************* ATTRIBUTE LIST DECLARATION ***********************/
attlistdecl():
/* parses <!ATTLIST ... >. Enters the attribute list in dtd as side-
* effect.
*/
decl_attlist_entid: Decl_attlist
$ {{ let extdecl = context.manager # current_entity_counts_as_external in
}}
ws1: Ignore Ignore*
el_name: Name
ws: Ignore? Ignore*
factor: attdef_factor()
{{
let at_list, decl_rangle_entid = factor in
if decl_attlist_entid != decl_rangle_entid then
raise (Validation_error "Entities not properly nested with ATTLIST declaration");
if not ws && at_list <> [] then begin
match at_list with
(name,_,_) :: _ ->
(* This is normally impossible, because the lexer demands
* some other token between two names.
*)
raise(WF_error("Whitespace is missing before `" ^ name ^ "'"));
| _ -> assert false
end;
if extend_dtd then begin
let new_el = new dtd_element dtd el_name in
(* Note that it is allowed that <!ATTLIST...> precedes the corresponding
* <!ELEMENT...> declaration. In this case we add the element declaration
* already to the DTD but leave the content model unspecified.
*)
let el =
try
dtd # add_element new_el;
new_el
with
Not_found -> (* already added *)
let old_el = dtd # element el_name in
if old_el # attribute_names <> [] then
warn config.swarner config.warner
(`W_multiple_ATTLIST_declarations el_name);
old_el
in
List.iter
(fun (a_name, a_type, a_default) ->
el # add_attribute a_name a_type a_default extdecl)
at_list
end
}}
? {{ match !yy_position with
"ws1" -> raise(WF_error("Whitespace is missing after ATTLIST"))
| "el_name" -> raise(WF_error("The name of the element is expected here"))
| "factor" -> raise(WF_error("Another attribute name or `>' expected"))
| _ -> raise(WF_error("Bad attribute declaration"))
}}
attdef_factor():
/* parses a list of triples <name> <type> <default value> and returns the
* list as (string * att_type * att_default) list.
*/
attdef:attdef() ws:Ignore? Ignore* factor:attdef_factor()
{{
let attdef_rest, decl_rangle_entid = factor in
if not ws && attdef_rest <> [] then begin
match attdef_rest with
(name,_,_) :: _ ->
raise(WF_error("Missing whitespace before `" ^ name ^ "'"));
| _ -> assert false
end;
(attdef :: attdef_rest), decl_rangle_entid }}
? {{ match !yy_position with
| "factor" -> raise(WF_error("Another attribute name or `>' expected"))
| _ -> raise(WF_error("Bad attribute declaration"))
}}
| entid:Decl_rangle
{{ [], entid }}
attdef():
/* Parses a single triple */
name: Name
ws1: Ignore Ignore*
tp: atttype()
ws2: Ignore Ignore*
default: defaultdecl()
{{ (name,tp,default) }}
? {{ match !yy_position with
("ws1"|"ws2") -> raise(WF_error("Whitespace is missing"))
| "tp" -> raise(WF_error("Type of attribute or `(' expected"))
| "default" -> raise(WF_error("#REQUIRED, #IMPLIED, #FIXED or a string literal expected"))
| _ -> raise(WF_error("Bad attribute declaration"))
}}
atttype():
/* Parses an attribute type and returns it as att_type. */
name: Name
$ {{ let followup =
if name = "NOTATION" then
parse_notation
else
parse_never
in
}}
nota: [followup]()?
{{
match name with
"CDATA" -> A_cdata
| "ID" -> A_id
| "IDREF" -> A_idref
| "IDREFS" -> A_idrefs
| "ENTITY" -> A_entity
| "ENTITIES" -> A_entities
| "NMTOKEN" -> A_nmtoken
| "NMTOKENS" -> A_nmtokens
| "NOTATION" ->
(match nota with
None -> raise(WF_error("Error in NOTATION type (perhaps missing whitespace after NOTATION?)"))
| Some n -> n
)
| _ -> raise(WF_error("One of CDATA, ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS, NOTATION, or a subexpression expected"))
}}
? {{ raise(WF_error("Bad attribute declaration (perhaps missing whitespace after NOTATION)")) }}
| Lparen
Ignore*
name: name_or_nametoken()
Ignore*
names: nmtoken_factor()*
_rp: Rparen
/* Enumeration */
{{ A_enum(name :: names) }}
? {{ match !yy_position with
"name" -> raise(WF_error("Name expected"))
| "names" -> raise(WF_error("`|' and more names expected, or `)'"))
| "_rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| _ -> raise(WF_error("Bad enumeration type"))
}}
never():
/* The always failing rule */
$ {{ raise Not_found; }}
Doctype /* questionable */
{{ A_cdata (* Does not matter *)
}}
notation():
Ignore Ignore*
_lp: Lparen
Ignore*
name: Name
Ignore*
names: notation_factor()*
_rp: Rparen
{{ A_notation(name :: names) }}
? {{ match !yy_position with
"_lp" -> raise(WF_error("`(' expected"))
| "name" -> raise(WF_error("Name expected"))
| "names" -> raise(WF_error("`|' and more names expected, or `)'"))
| "_rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| _ -> raise(WF_error("Bad NOTATION type"))
}}
notation_factor():
/* Parse "|<name>" and return the name */
Bar Ignore* name:Name Ignore*
{{ name }}
? {{ match !yy_position with
"name" -> raise(WF_error("Name expected"))
| _ -> raise(WF_error("Bad NOTATION type"))
}}
nmtoken_factor():
/* Parse "|<nmtoken>" and return the nmtoken */
Bar Ignore* n:name_or_nametoken() Ignore*
{{ n }}
? {{ match !yy_position with
"n" -> raise(WF_error("Nametoken expected"))
| _ -> raise(WF_error("Bad enumeration type"))
}}
name_or_nametoken():
n:Name {{ n }}
| n:Nametoken {{ n }}
/* The default values must be expanded and normalized. This has been implemented
* by the function expand_attvalue.
*/
defaultdecl():
/* Parse the default value for an attribute and return it as att_default */
Required
{{ D_required }}
| Implied
{{ D_implied }}
| Fixed ws:Ignore Ignore* str:Unparsed_string
{{ D_fixed
(expand_attvalue reused_lexobj dtd str false) }}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after #FIXED"))
| "str" -> raise(WF_error("String literal expected"))
| _ -> raise(WF_error("Bad #FIXED default value"))
}}
| str:Unparsed_string
{{ D_default
(expand_attvalue reused_lexobj dtd str false) }}
/**************************** ENTITY DECLARATION ***********************/
entitydecl(decl_entity_entid):
/* parses everything _after_ <!ENTITY until the matching >. The parsed
* entity declaration is entered into the dtd object as side-effect.
*/
name: Name
$ {{ let extdecl = context.manager # current_entity_counts_as_external in
}}
ws: Ignore Ignore*
material: entitydef()
Ignore*
decl_rangle_entid: Decl_rangle
/* A general entity */
{{
if decl_entity_entid != decl_rangle_entid then
raise (Validation_error "Entities not properly nested with ENTITY declaration");
let en =
(* Distinguish between
* - internal entities
* - external entities
* - NDATA (unparsed) entities
*)
match material with
(Some s, None, None) ->
new Pxp_entity.internal_entity dtd name config.swarner
config.warner s p_internal_subset false config.encoding
| (None, Some xid, None) ->
let resolver =
context.manager # current_resolver # clone in
let system_base =
(context.manager # current_resolver # active_id).rid_system in
new Pxp_entity.external_entity resolver dtd name config.swarner
config.warner
xid system_base false
config.encoding
| (None, Some xid, Some n) ->
(new Pxp_entity.ndata_entity name xid n config.encoding
:> Pxp_entity.entity)
| _ -> assert false
in
dtd # add_gen_entity en extdecl
}}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing"))
| "material" -> raise(WF_error("String literal or identifier expected"))
| "decl_rangle_entid" -> raise(WF_error("`>' expected"))
| _ -> raise(WF_error("Bad entity declaration"))
}}
| Percent
$ {{ let extdecl = context.manager # current_entity_counts_as_external in
}}
ws1: Ignore Ignore*
name: Name
ws2: Ignore Ignore*
material: pedef()
Ignore*
decl_rangle_entid: Decl_rangle
/* A parameter entity */
{{
if decl_entity_entid != decl_rangle_entid then
raise (Validation_error "Entities not properly nested with ENTITY declaration");
let en =
(* Distinguish between internal and external entities *)
match material with
(Some s, None) ->
new Pxp_entity.internal_entity dtd name config.swarner
config.warner s p_internal_subset true config.encoding
| (None, Some xid) ->
let resolver =
context.manager # current_resolver # clone in
let system_base =
(context.manager # current_resolver # active_id).rid_system in
new Pxp_entity.external_entity resolver dtd name config.swarner
config.warner
xid system_base true
config.encoding
| _ -> assert false
in
(* The following two lines force that even internal entities count
* as external (for the standalone check) if the declaration of
* the internal entity occurs in an external entity.
*)
if extdecl then
en # set_counts_as_external;
dtd # add_par_entity en;
}}
? {{ match !yy_position with
("ws1"|"ws2") -> raise(WF_error("Whitespace is missing"))
| "material" -> raise(WF_error("String literal or identifier expected"))
| "decl_rangle_entid" -> raise(WF_error("`>' expected"))
| _ -> raise(WF_error("Bad entity declaration"))
}}
entitydef():
/* parses the definition value of a general entity. Returns either:
* - (Some s, None, None) meaning the definition of an internal entity
* with (literal) value s has been found
* - (None, Some x, None) meaning that an external parsed entity with
* external ID x has been found
* - (None, Some x, Some n) meaning that an unparsed entity with
* external ID x and notations n has been found
*/
str:Unparsed_string
{{ Some str, None, None }}
| id:external_id() ws:Ignore? Ignore* decl:ndatadecl()?
{{ if not ws && decl <> None then
raise(WF_error("Whitespace missing before `NDATA'"));
None, Some id, decl
}}
pedef():
/* parses the definition value of a parameter entity. Returns either:
* - (Some s, None) meaning that the definition of an internal entity
* with (literal) value s has been found
* - (None, Some x) meaning that an external ID x has been found
*/
str:Unparsed_string
{{ Some str, None }}
| id:external_id()
{{ None, Some id }}
ndatadecl():
/* Parses either NDATA "string" or the empty string; returns Some "string"
* in the former, None in the latter case.
*/
ndata:Name ws:Ignore Ignore* name:Name
{{ if ndata = "NDATA" then
name
else
raise(WF_error("NDATA expected"))
}}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after NDATA"))
| "name" -> raise(WF_error("Name expected"))
| _ -> raise(WF_error("Bad NDATA declaration"))
}}
/**************************** NOTATION DECLARATION *******************/
notationdecl():
/* parses <!NOTATION ... > and enters the notation declaration into the
* dtd object as side-effect
*/
decl_notation_entid: Decl_notation
ws1: Ignore Ignore*
name: Name
ws2: Ignore Ignore*
sys_or_public: Name /* SYSTEM or PUBLIC */
ws3: Ignore Ignore*
str1: Unparsed_string
ws: Ignore? Ignore*
str2: Unparsed_string?
Ignore*
decl_rangle_entid: Decl_rangle
{{
if decl_notation_entid != decl_rangle_entid then
raise (Validation_error "Entities not properly nested with NOTATION declaration");
let xid =
(* Note that it is allowed that PUBLIC is only followed by one
* string literal
*)
match sys_or_public with
"SYSTEM" ->
if str2 <> None then raise(WF_error("SYSTEM must be followed only by one argument"));
System (recode_utf8 str1)
| "PUBLIC" ->
begin match str2 with
None ->
check_public_id str1;
Public(recode_utf8 str1,"")
| Some p ->
if not ws then
raise(WF_error("Missing whitespace between the string literals of the `PUBLIC' id"));
check_public_id str1;
Public(recode_utf8 str1, recode_utf8 p)
end
| _ -> raise(WF_error("PUBLIC or SYSTEM expected"))
in
if extend_dtd then begin
let no = new dtd_notation name xid config.encoding in
dtd # add_notation no
end
}}
? {{ match !yy_position with
("ws1"|"ws2"|"ws3") -> raise(WF_error("Whitespace is missing"))
| "name" -> raise(WF_error("Name expected"))
| "sys_or_public" -> raise(WF_error("SYSTEM or PUBLIC expected"))
| ("str1"|"str2") -> raise(WF_error("String literal expected"))
| "decl_rangle_entid" -> raise(WF_error("`>' expected"))
| _ -> raise(WF_error("Bad NOTATION declaration"))
}}
/****************************** ELEMENTS **************************/
/* In the following rules, the number of error rules is reduced to
* improve the performance of the parser.
*/
body_start():
/* parses <element>...</element> misc*, i.e. exactly one element followed
* optionally by white space or processing instructions.
* The element is entered into the global variables as follows:
* - If elstack is non-empty, the parsed element is added as new child to
* the top element of the stack.
* - If elstack is empty, the root_examplar object is modified rather than
* that a new element is created. If additionally the variable root is
* None, it is assigned Some root_examplar.
* Note that the modification of the root_exemplar is done by the method
* internal_init.
* The reason why the root element is modified rather than newly created
* is a typing requirement. It must be possible that the class of the root
* is derived from the original class element_impl, i.e. the user must be
* able to add additional methods. If we created a new root object, we
* would have to denote to which class the new object belongs; the root
* would always be an 'element_impl' object (and not a derived object).
* If we instead cloned an exemplar object and modified it by the
* "create" method, the root object would belong to the same class as the
* exemplar (good), but the type of the parsing function would always
* state that an 'element_impl' was created (because we can pass the new
* object only back via a global variable). The only solution is to
* modify the object that has been passed to the parsing function directly.
*/
$ {{ self # init_for_xml_body
(context.manager # current_entity :> entity_id);
let parse_fn =
if pull_counter < 0 then
parse_content_push
else
parse_content_pull in
}}
start_tag() [parse_fn]()
{{ () }}
entity_body():
/* The body of an external entity, i.e. content. */
End_entity
{{ self # init_for_xml_body
(context.manager # current_entity :> entity_id);
n_entities_open <- n_entities_open - 1;
raise End_of_parsing
}}
| $ {{
self # init_for_xml_body
(context.manager # current_entity :> entity_id);
let parse_fn =
if pull_counter < 0 then
parse_content_push
else
parse_content_pull in
}}
node_tag() [parse_fn]()
{{ () }}
entry_expr():
$ {{ self # init_for_xml_body
(context.manager # current_entity :> entity_id);
}}
entry_expr_content()
{{ () }}
entry_expr_content():
start_tag()
$ {{ begin try
while n_tags_open > 0 do
parse_node_tag yy_current yy_get_next
done
with Not_found ->
yy_position := "expr";
raise Parsing.Parse_error
end;
}}
{{ () }}
? {{ match !yy_position with
"expr" -> raise(WF_error("Unexpected token"))
| _ -> raise(WF_error("Syntax error"))
}}
| pi()
{{ () }}
| comment()
{{ () }}
| entry_expr_space()
{{ () }}
| CRef
{{ raise(WF_error("Character entity not allowed here")) }}
| Begin_entity entry_expr() entry_expr_space()* End_entity
{{ () }}
entry_expr_space():
data:CharData
{{
self # only_whitespace data
}}
content_push():
node_tag() node_tag()*
{{ () }}
content_pull():
node_tag()
$ {{ pull_counter <- pull_counter - 1;
if pull_counter <= 0 then begin
pull_counter <- pull_counter_limit;
let state = { cont_context = context;
cont_extend_dtd = extend_dtd;
cont_process_xmldecl = process_xmldecl;
} in
raise(Interrupt_parsing state)
end;
}}
content_pull()
{{ () }}
node_tag():
/* parses: start tags, end tags, content, or processing
* instructions. That the tags are properly nested is dynamically checked.
* As result, recognized elements are added to their parent elements,
* content is added to the element containing it, and processing instructions
* are entered into the element embracing them. (All as side-effects.)
*/
start_tag()
{{ () }}
| end_tag()
{{ () }}
| char_data()
{{ () }}
| cref()
{{ () }}
| pi()
{{ () }}
| comment()
{{ () }}
| Begin_entity
$ {{ if n_tags_open = 0 && not permit_any_content then
raise(WF_error("Entity reference not allowed here"));
n_entities_open <- n_entities_open + 1;
}}
init_inner_entity()
{{ () }}
| End_entity
{{ n_entities_open <- n_entities_open - 1;
if n_entities_open = 0 then begin
if n_tags_open <> 0 then raise(WF_error("Missing end tag"));
raise End_of_parsing
end;
}}
/* See comment for doc_mldecl_then_misc_then_prolog_then_body. */
init_inner_entity():
pl:PI_xml
$ {{ context.manager # current_entity # process_xmldecl pl;
}}
{{ () }}
| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
node_tag()
{{ () }}
start_tag():
/* parses <element attribute-values> or <element attribute-values/>.
*
* EFFECT: If elstack is non-empty, the element is added to the
* top element of the stack as new child, and the element
* is pushed on the stack. If elstack is empty, the root_exemplar is
* modified and gets the parsed name and attribute list. The root_exemplar
* is pushed on the stack. If additionally the variable root is empty, too,
* this variable is initialized.
* If the <element ... /> form has been parsed, no element is pushed
* on the stack.
*/
/* TODO: Support for namespaces. xmlns attributes must be identified.
* These atts are not added to the regular attribute list, but the
* contained namespace information is interpreted.
* We need a stack tracking namespace declarations (PUSH for every
* start tag; POP for every end tag). Element names and attribute names
* are splitted into src_prefix and localname. The src_prefix is mapped
* to norm_prefix using the mentioned stack. The element and attributes
* are created with names "norm_prefix:localname".
* If configured, the namespace_info field of elements is set from
* the current contents of the namespace stack.
* New config options:
* - namespace_manager = None or Some mng
* - namespace_objects = true or false
*/
tag: Tag_beg
$ {{ let position =
if config.store_element_positions then
Some(context.manager # position)
else
None
in
let attlist = ref [] in
let attspace = ref true in
}}
_ws: Ignore? Ignore*
attribute(attlist,attspace)*
emptiness: start_tag_rangle()
/* Note: it is guaranteed that there is whitespace between Tag_beg and
* the name of the first attribute, because there must be some separator.
* So we need not to check ws!
*/
{{
let name0, tag_beg_entid = tag in
let name =
if config.enable_name_pool_for_element_types
then make_pool_string name0
else name0 in
self # event_start_tag position name !attlist emptiness tag_beg_entid;
if not emptiness then
n_tags_open <- n_tags_open + 1;
}}
? {{ match !yy_position with
| "emptiness" -> raise(WF_error("`>' or `/>' expected"))
| _ -> raise(WF_error("Bad start tag"))
}}
attribute(attlist,attspace):
/* Parses name="value" */
n0:Name Ignore* Eq Ignore* v:attval() ws:Ignore? Ignore*
{{ if not !attspace then
raise(WF_error("Whitespace is missing before attribute `" ^
n0 ^ "'"));
let n =
if config.enable_name_pool_for_attribute_names
then make_pool_string n0
else n0 in
attlist := (n,v) :: !attlist;
attspace := ws;
()
}}
attval():
v:Attval
{{ expand_attvalue reused_lexobj dtd v true }}
| v:Attval_nl_normalized
{{ expand_attvalue reused_lexobj dtd v false }}
/* The following rules are only used if event-based attribute parsing
* is enabled. In this case, neither Attval nor Attval_nl_normalized,
* but SQuote, DQuote and attribute tokens are scanned.
*/
| SQuote
$ {{ let attpos = ref 0 in }}
sl:attval_squote_token(attpos)* SQuote
{{ String.concat "" sl }}
| DQuote
$ {{ let attpos = ref 0 in }}
sl:attval_dquote_token(attpos)* DQuote
{{ String.concat "" sl }}
attval_squote_token(attpos):
name:ERef_att
{{
let etext = "&" ^ name ^ ";" in
let s =
Pxp_aux.expand_attvalue
reused_lexobj dtd etext false in
attpos := !attpos + String.length s;
s
}}
| code:CRef
{{ let s = Pxp_aux.character
?swarner:config.swarner config.encoding config.warner code in
attpos := !attpos + String.length s;
s
}}
| data:CharData
{{
if data.[0] = '<' then (* '<' is always a separate token *)
raise
(WF_error ("Attribute value contains character '<' literally"))
else (
attpos := !attpos + String.length data;
data
)
}}
| LLcurly
{{ let s = process_attribute_event LLcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| Lcurly
{{ let s = process_attribute_event Lcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| RRcurly
{{ let s = process_attribute_event RRcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| Rcurly
{{ let s = process_attribute_event Rcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| DQuote
{{ incr attpos; "\"" }}
attval_dquote_token(attpos):
name:ERef_att
{{
let etext = "&" ^ name ^ ";" in
let s = Pxp_aux.expand_attvalue
reused_lexobj dtd etext false in
attpos := !attpos + String.length s;
s
}}
| code:CRef
{{ let s = Pxp_aux.character
?swarner:config.swarner config.encoding config.warner code in
attpos := !attpos + String.length s;
s
}}
| data:CharData
{{
if data.[0] = '<' then (* '<' is always a separate token *)
raise
(WF_error ("Attribute value contains character '<' literally"))
else (
attpos := !attpos + String.length data;
data
)
}}
| LLcurly
{{ let s = process_attribute_event LLcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| Lcurly
{{ let s = process_attribute_event Lcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| RRcurly
{{ let s = process_attribute_event RRcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| Rcurly
{{ let s = process_attribute_event Rcurly !attpos in
attpos := !attpos + String.length s;
s
}}
| SQuote
{{ incr attpos; "'" }}
start_tag_rangle():
Rangle {{ false }}
| Rangle_empty {{ true }}
end_tag():
/* parses </element>.
* Pops the top element from the elstack and checks if it is the same
* element.
*/
tag:Tag_end Ignore* Rangle
{{ let name, tag_end_entid = tag in
if n_tags_open = 0 then
raise(WF_error("End-tag without start-tag"));
self # event_end_tag name tag_end_entid;
n_tags_open <- n_tags_open - 1;
assert (n_tags_open >= 0);
}}
char_data():
/* Parses any literal characters not otherwise matching, and adds the
* characters to the top element of elstack.
* If elstack is empty, it is assumed that there is no surrounding
* element, and any non-white space character is forbidden.
*/
data:CharData
{{
if n_tags_open = 0 && not permit_any_content then
(* only white space is allowed *)
self # only_whitespace data
else
self # event_char_data data
}}
| Lcurly
{{ process_curly_brace Lcurly }}
| LLcurly
{{ process_curly_brace LLcurly }}
| Rcurly
{{ process_curly_brace Rcurly }}
| RRcurly
{{ process_curly_brace RRcurly }}
| data:Cdata
{{
if n_tags_open = 0 && not permit_any_content then
raise (WF_error("CDATA section not allowed here"));
self # event_char_data data
}}
cref():
/* Parses &#...; and adds the character to the top element of elstack. */
code:CRef
{{
if n_tags_open = 0 && not permit_any_content then
(* No surrounding element: character references are not allowed *)
raise(WF_error("Character reference not allowed here"));
self # event_char_data
(character ?swarner:config.swarner config.encoding config.warner code)
}}
pi():
/* Parses <?...?> (but not <?xml white-space ... ?>).
* If there is a top element in elstack, the processing instruction is added
* to this element.
*/
pi: PI
{{
let position =
if config.store_element_positions then
Some(context.manager # position)
else
None
in
let target0,value,ent_id = pi in
let target =
if config.enable_name_pool_for_pinstr_targets
then make_pool_string target0
else target0 in
self # event_pinstr position target value ent_id
}}
comment():
/* Parses <!-- ... -->
*/
begin_entid:Comment_begin
$ {{
let position =
if config.enable_comment_nodes && config.store_element_positions then
Some(context.manager # position)
else
None
in
}}
mat: Comment_material*
end_entid: Comment_end
{{
if begin_entid != end_entid then
raise(Validation_error("The first and the last token of comments must be in the same entity"));
self # event_comment position mat
}}
? {{ match !yy_position with
| "end_entid" -> raise(WF_error("`-->' expected"))
| _ -> raise(WF_error("Bad comment"))
}}
%%
(* The method "parse" continues here... *)
try
begin match start_symbol with
`Entry_document flags ->
parse_entry_document context.current context.get_next
| `Entry_declarations flags ->
parse_entry_declarations context.current context.get_next
| `Entry_element_content flags ->
parse_entry_element_content context.current context.get_next
| `Entry_content flags ->
parse_entry_content context.current context.get_next
| `Entry_expr flags ->
parse_entry_expr context.current context.get_next
| `Entry_continuation _ ->
parse_content_pull context.current context.get_next
end;
raise End_of_parsing
with
Not_found ->
raise Parsing.Parse_error
| End_of_parsing ->
if n_entities_open > 0 then
raise(WF_error("Illegal token"));
()
(* The exception Interrupt_parsing is not caught here, but by the
* caller
*)
(*********** The method "parse" ends here *************)
(**********************************************************************)
(* Here ends the class definition: *)
end
;;
