+++ /dev/null
-(* $Id$ -*- tuareg -*-
- * ----------------------------------------------------------------------
- * PXP: The polymorphic XML parser for Objective Caml.
- * Copyright by Gerd Stolpmann. See LICENSE for details.
- *)
-
-open Parsing
-open Pxp_types
-open Pxp_lexer_types
-open Pxp_dtd
-open Pxp_entity
-open Pxp_document
-open Pxp_aux
-
-(* Some types from the interface definition: *)
-
-exception ID_not_unique
-
-class type [ 'ext ] index =
-object
- constraint 'ext = 'ext node #extension
- method add : string -> 'ext node -> unit
- method find : string -> 'ext node
-end
-
-
-type config =
- { warner : collect_warnings;
- errors_with_line_numbers : bool;
- enable_pinstr_nodes : bool;
- enable_super_root_node : bool;
- enable_comment_nodes : bool;
- encoding : rep_encoding;
- recognize_standalone_declaration : bool;
- store_element_positions : bool;
- idref_pass : bool;
- validate_by_dfa : bool;
- accept_only_deterministic_models : bool;
- debugging_mode : bool;
- }
-
-type source =
- Entity of ((dtd -> Pxp_entity.entity) * Pxp_reader.resolver)
- | ExtID of (ext_id * Pxp_reader.resolver)
-
-
-type start_symbol =
- Ext_document
- | Ext_declarations
- | Ext_element
-
-
-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 *)
- }
-
-
-let make_context 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);
- ignore(c.get_next());
- c
-;;
-
-
-let from_channel ?system_encoding ?id:init_id ?fixenc ch =
-
- (* Reading from a channel works by modifying the algorithm of
- * resolve_as_file.
- *)
-
- let url_syntax = (* A syntax suitable for "file" URLs *)
- { Neturl.null_url_syntax with
- Neturl.url_enable_scheme = Neturl.Url_part_allowed;
- Neturl.url_enable_host = Neturl.Url_part_allowed;
- Neturl.url_enable_path = Neturl.Url_part_required;
- Neturl.url_accepts_8bits = true;
- }
- in
-
- let an_url =
- Neturl.make_url
- ~scheme: "file"
- ~host: ""
- ~path: [ "" ]
- url_syntax
- in
-
- let init_channel_done = ref false in
- (* Whether the first access to this source has already happened. *)
-
- (* The task of url_of_id is:
- * - When it is called the first time, and no init_id is present,
- * the URL file:/// is passed back (an_url). This forces that
- * absolute path names /path/dir/... will be interpreted as
- * file path names. (But relative path names will not work.)
- * - If an init_id has been passed, we can assume that the opened URL
- * is exactly this init_id. By raising Not_competent it is indicated
- * that the standard method is to be used for the interpretation of
- * the URL.
- * - Otherwise, the channel is already being read, and thus cannot again
- * opened. (This case is handled in channel_of_url.)
- *)
-
- let url_of_id xid =
- if !init_channel_done then begin
- (* Use the normal way of determining the URL of the ID: *)
- raise Pxp_reader.Not_competent
- end
- else begin
- match init_id with
- None ->
- an_url
- (* If the channel is not associated with any URL: Simply pass
- * the URL file:/// back.
- *)
- | Some the_init_id ->
- assert (the_init_id = xid);
- raise Pxp_reader.Not_competent
- (* If the channel is associated with a URL, the corresponding
- * ID must be passed when the first invocation happens.
- *)
- end
- in
-
- (* The task of channel_of_url:
- * - If it is called the first time ("else"), the channel is returned
- * - Otherwise, the channel is already being read, and thus cannot again
- * opened. By raising Not_competent it is signaled that the
- * resolve_as_file object must not continue to open the URL.
- *)
-
- let channel_of_url url =
- if !init_channel_done then
- raise Pxp_reader.Not_competent
- else begin
- init_channel_done := true;
- ch, fixenc
- end
- in
-
- let r =
- new Pxp_reader.resolve_as_file
- ?system_encoding:system_encoding
- ~url_of_id:url_of_id
- ~channel_of_url:channel_of_url
- ()
- in
-
- let init_xid =
- match init_id with
- None -> Anonymous
- | Some id ->
- (* Note: 'id' may be illegal (malformed); in this case, the first
- * invocation of url_of_id will raise Not_competent, and the 'open_in'
- * method will fail.
- *)
- id
- in
-
- ExtID(init_xid, r)
-;;
-
-
-let from_file ?system_encoding utf8_filename =
-
- let r =
- new Pxp_reader.resolve_as_file
- ?system_encoding:system_encoding
- ()
- in
-
- let utf8_abs_filename =
- if utf8_filename <> "" && utf8_filename.[0] = '/' then
- utf8_filename
- else
- Sys.getcwd() ^ "/" ^ utf8_filename
- in
-
- let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
- let url = Neturl.make_url
- ~scheme:"file"
- ~host:"localhost"
- ~path:(Neturl.split_path utf8_abs_filename)
- syntax
- in
-
- let xid = System (Neturl.string_of_url url) in
-
-
- ExtID(xid, r)
-;;
-
-
-let from_string ?fixenc s =
- let r =
- new Pxp_reader.resolve_read_this_string ?fixenc:fixenc s in
- ExtID(Anonymous, r)
-;;
-
-
-(**********************************************************************)
-
-class ['ext] parser_object
- init_doc init_dtd init_extend_dtd init_config init_resolver init_spec
- init_process_xmldecl transform_dtd id_index
- =
- object (self)
-
- (* Note that the 'ext parameter has been the motivation to make the
- * parser a class.
- *)
-
- val mutable dtd = init_dtd
- (* The DTD being parsed; or the DTD currently assumed *)
-
- val extend_dtd = init_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.)
- *)
-
- val transform_dtd = transform_dtd
- (* A function transforming the DTD *)
-
- val id_index = (id_index : 'ext index option)
- (* The ID index or None *)
-
- val process_xmldecl = init_process_xmldecl
- (* Whether the XML declaration is parsed and the found XML version
- * and standalone declaration are passed to 'doc'.
- *)
-
- val lexerset = Pxp_lexers.get_lexer_set (init_config.encoding)
-
- val doc = init_doc
- (* The current document *)
-
- method doc = (doc : 'ext document)
-
- val resolver = init_resolver
- (* The resolver for external IDs *)
-
- val config = init_config
- (* The current configuration *)
-
- val elstack = (Stack.create() : ('ext node * entity_id) Stack.t)
- (* The element stack containing all open elements, i.e. elements that
- * have begun by a start tag but that have not been finished (end tag).
- * If the parser sees a start tag, it creates the element and pushes it
- * on top of this stack. If the parser recognizes an end tag, it pulls
- * one element from the stack and checks if it has the same name as
- * given with the end tag.
- *
- * At initialization time, a special element is pushed on the stack,
- * the so-called super root. It is always the bottommost
- * element of the stack, and serves as a guard.
- * [See "initializer" below.]
- *)
-
- method current =
- (* Get the top element of the element stack *)
- try
- fst(Stack.top elstack)
- with
- Stack.Empty -> assert false
- (* Not possible, because the super root is always the element
- * at the bottom of the stack.
- *)
-
- 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 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 root = None
- (* Contains the root element (topmost element) while it is being parsed
- * and after it has been parsed.
- * This variable is None before the root element is seen.
- *)
-
- method root = root
-
- val spec = init_spec
- (* A hashtable that contains exemplar objects for the various element
- * types. If an element is parsed, the exemplar is looked up and
- * "cloned" (by the "create" method)
- *)
-
- val mutable current_data = []
- (* Collects character data. *)
-
- method collect_data s =
- (* Collects the character material 's' *)
- current_data <- s :: current_data
-
- method save_data =
- (* Puts the material collected in 'current_data' into a new
- * node, and appends this node as new sub node to 'current'
- *)
- match current_data with
- [] ->
- ()
- | [ str ] ->
- if str <> "" then
- self # current # add_node (create_data_node spec dtd str);
- current_data <- []
- | _ ->
- let count = List.fold_left
- (fun acc s -> acc + String.length s)
- 0
- current_data in
- let str = String.create count in
- let pos = ref count in
- List.iter
- (fun s ->
- let l = String.length s in
- pos := !pos - l;
- String.blit
- ~src:s
- ~src_pos:0
- ~dst:str
- ~dst_pos:(!pos)
- ~len:l
- )
- current_data;
- assert(!pos = 0);
- if str <> "" then
- self # current # add_node (create_data_node spec dtd str);
- current_data <- []
-
-
- method only_whitespace data =
- (* Checks that the string "data" contains only whitespace. On failure,
- * Validation_error is raised.
- *)
- let lexbuf = Lexing.from_string data in
- let t1 = lexerset.scan_name_string lexbuf in
- if t1 <> Ignore then
- raise(WF_error("Data not allowed here"));
- let t2 = lexerset.scan_name_string lexbuf in
- if t2 <> Eof then
- raise(WF_error("Data not allowed here"));
- ()
-
- initializer
- (* CHECKS: *)
- if config.encoding <> dtd # encoding then
- failwith("Encoding mismatch");
-
- (* --- Initialize 'elstack': Push the super-root on the stack. *)
- let super_root =
- if config.enable_super_root_node then
- create_super_root_node spec dtd
- else
- (* because spec may not contain an exemplar for the super root: *)
- create_no_node spec dtd
- in
- (* Move the super root or the emulation to the stack: *)
- Stack.push (super_root, (self :> entity_id)) elstack;
-
-
-
- (********* Here the method "parse" begins. The grammar below is
- * transformed to a local function of this method
- *)
-
- method parse context start_symbol =
-
- 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 check_and_parse_xmldecl xmldecl =
- if process_xmldecl then begin
- let v, _, s = decode_doc_xml_pi (decode_xml_pi xmldecl) in
- check_version_num v;
- doc # init_xml_version v;
- let v = match s with
- None -> false
- | Some "yes" -> true
- | Some "no" -> false
- | _ -> raise (WF_error("Illegal 'standalone' declaration"))
- in
- if config.recognize_standalone_declaration then
- dtd # set_standalone_declaration v
- end
- in
-
- let recode_utf8 s =
- (* Recode 's' to UTF-8 *)
- if config.encoding = `Enc_utf8 then
- s (* No recoding necessary *)
- else
- Netconversion.recode_string
- ~in_enc:(config.encoding :> encoding) ~out_enc:`Enc_utf8 s
- 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_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 <> 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 <> PERef
-%token <> CharData
-%token <> LineEnd
-%token <> Name
-%token <> Nametoken
-%token <> Attval
-%token <> Attval_nl_normalized
-%token <> Unparsed_string
-
-/* START SYMBOLS:
- *
- * "ext_document": parses a complete XML document (i.e. containing a
- * <!DOCTYPE..> and an element)
- * "ext_declarations": parses an "external DTD subset", i.e. a sequence
- * of declarations
- * "ext_element": 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.
- */
-
-%%
-
-
-ext_document():
- Begin_entity
- doc_xmldecl_then_misc_then_prolog_then_rest() End_entity
- {{
- if n_tags_open <> 0 then
- raise(WF_error("Missing end tag"))
- }}
-
-
-/* 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_rest():
- pl:PI_xml
- $ {{ context.manager # current_entity # process_xmldecl pl;
- check_and_parse_xmldecl pl;
- }}
- misc()* doc_prolog_then_rest()
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- misc() misc()* doc_prolog_then_rest()
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- doctypedecl() misc()* contents_start()
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- contents_start()
- {{ () }}
-
-
-doc_prolog_then_rest():
- doctypedecl() misc()* contents_start()
- {{ () }}
-| contents_start()
- {{ () }}
-
-
-ext_element():
- Begin_entity el_xmldecl_then_misc_then_rest() End_entity
- {{
- if n_tags_open <> 0 then
- raise(WF_error("Missing end tag"))
- }}
-
-
-/* See comment for doc_mldecl_then_misc_then_prolog_then_rest. */
-
-el_xmldecl_then_misc_then_rest():
- pl:PI_xml
- $ {{ context.manager # current_entity # process_xmldecl pl; }}
- misc()* contents_start()
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- misc() misc()* contents_start()
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- contents_start()
- {{ () }}
-
-
-ext_declarations():
- /* Parses a sequence of declarations given by an entity. As side-effect,
- * the parsed declarations are put into the dtd object.
- */
- Begin_entity decl_xmldecl_then_rest()
- {{ () }}
-| Eof
- {{ () }}
-
-
-decl_xmldecl_then_rest():
- /* 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 r' = resolver # clone in
- let pobj =
- new parser_object
- (new document config.warner)
- dtd
- extend_dtd
- config
- r'
- spec
- process_xmldecl
- (fun x -> x)
- None
- in
- let en = new external_entity r' dtd "[dtd]"
- config.warner id false config.errors_with_line_numbers
- config.encoding
- in
- en # set_debugging_mode (config.debugging_mode);
- let mgr = new entity_manager en in
- en # open_entity true Declaration;
- try
- let context = make_context mgr in
- pobj # parse context Ext_declarations;
- ignore(en # close_entity);
- with
- error ->
- ignore(en # close_entity);
- r' # close_all;
- let pos = mgr # position_string in
- raise (At(pos, error))
- 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 = pi in
- let pi = new proc_instruction target value config.encoding in
- dtd # add_pinstr pi
- }}
-| Ignore
- {{ () }}
-| Comment_begin Comment_material* ce:Comment_end
- {{ () }}
- ? {{ match !yy_position with
- "ce" -> 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_rest()
- {{ (* 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 ] ()
- {{ () }}
- ? {{ 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
- config.warner # warn ("More than one ATTLIST declaration for element type `" ^
- 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 lexerset dtd str config.warner 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 lexerset dtd str config.warner 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 internal_entity dtd name config.warner s p_internal_subset
- config.errors_with_line_numbers false config.encoding
- | (None, Some xid, None) ->
- new external_entity (resolver # clone) dtd name config.warner
- xid false config.errors_with_line_numbers
- config.encoding
-
- | (None, Some xid, Some n) ->
- (new ndata_entity name xid n config.encoding :> 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 internal_entity dtd name config.warner s p_internal_subset
- config.errors_with_line_numbers true config.encoding
- | (None, Some xid) ->
- new external_entity (resolver # clone) dtd name config.warner
- xid true config.errors_with_line_numbers
- 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.
- */
-
-
-contents_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.
- */
- $ {{ dtd <- transform_dtd dtd; }}
- start_tag() content()*
- {{ () }}
-
-
-content():
- /* 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()
- {{ () }}
-| entity_ref()
- {{ () }}
-| comment()
- {{ () }}
-
-
-entity_ref():
- Begin_entity eref_xmldecl_then_rest()
- {{ if n_tags_open = 0 then
- raise(WF_error("Entity reference not allowed here"))
- }}
-
-
-/* See comment for doc_mldecl_then_misc_then_prolog_then_rest. */
-
-eref_xmldecl_then_rest():
- pl:PI_xml
- $ {{ context.manager # current_entity # process_xmldecl pl;
- }}
- content()* End_entity
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- content() content()* End_entity
- {{ () }}
-
-| $ {{ context.manager # current_entity # process_missing_xmldecl; }}
- End_entity
- {{ () }}
-
-
-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.
- */
- tag: Tag_beg
- $ {{ let position =
- if config.store_element_positions then
- Some(context.manager # position)
- else
- None
- in
- }}
- ws: Ignore? Ignore*
- attlist: attribute()*
- 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 rec check_attlist al =
- match al with
- (nv1, num1) :: al' ->
- if not num1 && al' <> [] then begin
- match al with
- ((n1,_),_) :: ((n2,_),_) :: _ ->
- raise(WF_error("Whitespace is missing between attributes `" ^
- n1 ^ "' and `" ^ n2 ^ "'"))
- | _ -> assert false
- end;
- check_attlist al'
- | [] -> ()
- in
- check_attlist attlist;
-
- let name, tag_beg_entid = tag in
- let attlist' = List.map (fun (nv,_) -> nv) attlist in
- let d =
- create_element_node ?position:position spec dtd name attlist' in
-
- begin match id_index with
- None -> ()
- | Some idx ->
- (* Put the ID attribute into the index, if present *)
- begin try
- let v = d # id_attribute_value in (* may raise Not_found *)
- idx # add v d (* may raise ID_not_unique *)
- with
- Not_found ->
- (* No ID attribute *)
- ()
- | ID_not_unique ->
- (* There is already an ID with the same value *)
- raise(Validation_error("ID not unique"))
- end
- end;
-
- if n_tags_open = 0 then begin
- if root = None then begin
- (* We have found the begin tag of the root element. *)
- if config.enable_super_root_node then begin
- (* The user wants the super root instead of the real root.
- * The real root element becomes the child of the VR.
- *)
- (* Assertion: self # current is the super root *)
- assert (self # current # node_type = T_super_root);
- root <- Some (self # current);
- self # current # add_node d;
- doc # init_root (self # current);
- end
- else begin
- (* Normal behaviour: The user wants to get the real root. *)
- root <- Some d;
- doc # init_root d;
- end;
- end
- else
- (* We have found a second topmost element. This is illegal. *)
- raise(WF_error("Document must consist of only one toplevel element"))
- end
- else begin
- (* We have found some inner begin tag. *)
- self # save_data; (* Save outstanding data material first *)
- self # current # add_node d
- end;
-
- if emptiness then
- (* An empty tag like <a/>. *)
- d # local_validate ~use_dfa:config.validate_by_dfa ()
- else begin
- (* A non-empty tag. *)
- Stack.push (d, tag_beg_entid) elstack;
- n_tags_open <- n_tags_open + 1;
- end;
- }}
- ? {{ match !yy_position with
- "attlist" -> raise(WF_error("Bad attribute list"))
- | "emptiness" -> raise(WF_error("`>' or `/>' expected"))
- | _ -> raise(WF_error("Bad start tag"))
- }}
-
-
-attribute():
- /* Parses name="value" */
- n:Name Ignore* Eq Ignore* v:attval() ws:Ignore? Ignore*
- {{ (n,v), ws }}
-
-
-attval():
- v:Attval
- {{ expand_attvalue lexerset dtd v config.warner true }}
-| v:Attval_nl_normalized
- {{ expand_attvalue lexerset dtd v config.warner false }}
-
-
-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 # save_data; (* Save outstanding data material first *)
-
- let x, tag_beg_entid = Stack.pop elstack in
- let x_name =
- match x # node_type with
- | T_element n -> n
- | _ -> assert false
- in
- if name <> x_name then
- raise(WF_error("End-tag does not match start-tag"));
- if tag_beg_entid != tag_end_entid then
- raise(WF_error("End-tag not in the same entity as the start-tag"));
- x # local_validate ~use_dfa:config.validate_by_dfa ();
-
- 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 then
- (* only white space is allowed *)
- self # only_whitespace data
- else
- self # collect_data data
- (* We collect the chardata material until the next end tag is
- * reached. Then the collected material will concatenated and
- * stored as a single T_data node (see end_tag rule above)
- * using save_data.
- *)
- }}
-| data:Cdata
- {{
- if n_tags_open = 0 then
- raise (WF_error("CDATA section not allowed here"));
- self # collect_data data
- (* Also collect CDATA material *)
- }}
-
-cref():
- /* Parses &#...; and adds the character to the top element of elstack. */
- code:CRef
- {{
- if n_tags_open = 0 then
- (* No surrounding element: character references are not allowed *)
- raise(WF_error("Character reference not allowed here"));
- self # collect_data (character config.encoding config.warner code)
- (* Also collect character references *)
- }}
-
-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 target,value = pi in
-
- if n_tags_open = 0 & not config.enable_super_root_node
- then
- doc # add_pinstr (new proc_instruction target value config.encoding)
- else begin
- (* Special case: if processing instructions are processed inline,
- * they are wrapped into T_pinstr nodes.
- *)
- if config.enable_pinstr_nodes then begin
- self # save_data; (* Save outstanding data material first *)
- let pinstr = new proc_instruction target value config.encoding in
- let wrapper = create_pinstr_node
- ?position:position spec dtd pinstr in
- wrapper # local_validate(); (* succeeds always *)
- self # current # add_node wrapper;
- end
- else
- (* Normal behaviour: Add the PI to the parent element. *)
- self # current # add_pinstr
- (new proc_instruction target value config.encoding)
- end
- }}
-
-
-comment():
- /* Parses <!-- ... -->
- */
- Comment_begin
- $ {{
- let position =
- if config.enable_comment_nodes && config.store_element_positions then
- Some(context.manager # position)
- else
- None
- in
- }}
- mat: Comment_material*
- ce: Comment_end
- {{
- if config.enable_comment_nodes then begin
- self # save_data; (* Save outstanding data material first *)
- let comment_text = String.concat "" mat in
- let wrapper = create_comment_node
- ?position:position spec dtd comment_text in
- wrapper # local_validate(); (* succeeds always *)
- self # current # add_node wrapper;
- end
- }}
- ? {{ match !yy_position with
- | "ce" -> raise(WF_error("`-->' expected"))
- | _ -> raise(WF_error("Bad comment"))
- }}
-
-
-%%
- (* The method "parse" continues here... *)
-
- try
- match start_symbol with
- Ext_document ->
- parse_ext_document context.current context.get_next
- | Ext_declarations ->
- parse_ext_declarations context.current context.get_next
- | Ext_element ->
- parse_ext_element context.current context.get_next
- with
- Not_found ->
- raise Parsing.Parse_error
-
- (*********** The method "parse" ends here *************)
-
-
-(**********************************************************************)
-
-(* Here ends the class definition: *)
-end
-;;
-
-(**********************************************************************)
-
-open Pxp_reader;;
-
-
-class default_ext =
- object(self)
- val mutable node = (None : ('a extension node as 'a) option)
- method clone = {< >}
- method node =
- match node with
- None ->
- assert false
- | Some n -> n
- method set_node n =
- node <- Some n
- end
-;;
-
-
-let default_extension = new default_ext;;
-
-let default_spec =
- make_spec_from_mapping
- ~super_root_exemplar: (new element_impl default_extension)
- ~comment_exemplar: (new element_impl default_extension)
- ~default_pinstr_exemplar: (new element_impl default_extension)
- ~data_exemplar: (new data_impl default_extension)
- ~default_element_exemplar: (new element_impl default_extension)
- ~element_mapping: (Hashtbl.create 1)
- ()
-;;
-
-
-let idref_pass id_index root =
- let error t att value =
- let name =
- match t # node_type with
- T_element name -> name
- | _ -> assert false
- in
- let text =
- "Attribute `" ^ att ^ "' of element `" ^ name ^
- "' refers to unknown ID `" ^ value ^ "'" in
- let pos_ent, pos_line, pos_col = t # position in
- if pos_line = 0 then
- raise(Validation_error text)
- else
- raise(At("In entity " ^ pos_ent ^ " at line " ^
- string_of_int pos_line ^ ", position " ^ string_of_int pos_col ^
- ":\n",
- Validation_error text))
- in
-
- let rec check_tree t =
- let idref_atts = t # idref_attribute_names in
- List.iter
- (fun att ->
- match t # attribute att with
- Value s ->
- begin try ignore(id_index # find s) with
- Not_found ->
- error t att s
- end
- | Valuelist l ->
- List.iter
- (fun s ->
- try ignore(id_index # find s) with
- Not_found ->
- error t att s
- )
- l
- | Implied_value -> ()
- )
- idref_atts;
- List.iter check_tree (t # sub_nodes)
- in
- check_tree root
-;;
-
-
-exception Return_DTD of dtd;;
- (* Used by extract_dtd_from_document_entity to jump out of the parser *)
-
-
-let call_parser ~configuration:cfg
- ~source:src
- ~dtd
- ~extensible_dtd
- ~document:doc
- ~specification:spec
- ~process_xmldecl
- ~transform_dtd
- ~(id_index : 'ext #index option)
- ~use_document_entity
- ~entry
- ~init_lexer =
- let e = cfg.errors_with_line_numbers in
- let w = cfg.warner in
- let r, en =
- match src with
- Entity(m,r') -> r', m dtd
- | ExtID(xid,r') -> r',
- if use_document_entity then
- new document_entity
- r' dtd "[toplevel]" w xid e
- cfg.encoding
- else
- new external_entity
- r' dtd "[toplevel]" w xid false e
- cfg.encoding
- in
- r # init_rep_encoding cfg.encoding;
- r # init_warner w;
- en # set_debugging_mode (cfg.debugging_mode);
- let pobj =
- new parser_object
- doc
- dtd
- extensible_dtd
- cfg
- r
- spec
- process_xmldecl
- transform_dtd
- (id_index :> 'ext index option)
- in
- let mgr = new entity_manager en in
- en # open_entity true init_lexer;
- begin try
- let context = make_context mgr in
- pobj # parse context entry;
- ignore(en # close_entity);
- with
- Return_DTD d ->
- ignore(en # close_entity);
- raise(Return_DTD d)
- | error ->
- ignore(en # close_entity);
- r # close_all;
- let pos = mgr # position_string in
- raise (At(pos, error))
- end;
- if cfg.idref_pass then begin
- match id_index with
- None -> ()
- | Some idx ->
- ( match pobj # root with
- None -> ()
- | Some root ->
- idref_pass idx root;
- )
- end;
- pobj
-
-
-let parse_dtd_entity cfg src =
- (* Parse a DTD given as separate entity. *)
- let dtd = new dtd cfg.warner cfg.encoding in
- let doc = new document cfg.warner in
- let pobj =
- call_parser
- ~configuration:cfg
- ~source:src
- ~dtd:dtd
- ~extensible_dtd:true (* Extend the DTD by parsed declarations *)
- ~document:doc
- ~specification:default_spec
- ~process_xmldecl:false (* The XML declaration is ignored
- * (except 'encoding')
- *)
- ~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
- ~id_index: None
- ~use_document_entity:false
- ~entry:Ext_declarations (* Entry point of the grammar *)
- ~init_lexer:Declaration (* The initially used lexer *)
- in
- dtd # validate;
- if cfg.accept_only_deterministic_models then dtd # only_deterministic_models;
- dtd
-;;
-
-
-let parse_content_entity ?id_index cfg src dtd spec =
- (* Parse an element given as separate entity *)
- dtd # validate; (* ensure that the DTD is valid *)
- if cfg.accept_only_deterministic_models then dtd # only_deterministic_models;
- let doc = new document cfg.warner in
- let pobj =
- call_parser
- ~configuration:cfg
- ~source:src
- ~dtd:dtd
- ~extensible_dtd:true (* Extend the DTD by parsed declarations *)
- ~document:doc
- ~specification:spec
- ~process_xmldecl:false (* The XML declaration is ignored
- * (except 'encoding')
- *)
- ~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
- ~id_index:(id_index :> 'ext index option)
- ~use_document_entity:false
- ~entry:Ext_element (* Entry point of the grammar *)
- ~init_lexer:Content (* The initially used lexer *)
- in
- match pobj # root with
- Some r -> r
- | None -> raise(WF_error("No root element"))
-;;
-
-
-let parse_wfcontent_entity cfg src spec =
- let dtd = new dtd cfg.warner cfg.encoding in
- dtd # allow_arbitrary;
- let doc = new document cfg.warner in
- let pobj =
- call_parser
- ~configuration:cfg
- ~source:src
- ~dtd:dtd
- ~extensible_dtd:false (* Do not extend the DTD *)
- ~document:doc
- ~specification:spec
- ~process_xmldecl:false (* The XML declaration is ignored
- * (except 'encoding')
- *)
- ~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
- ~id_index:None
- ~use_document_entity:false
- ~entry:Ext_element (* Entry point of the grammar *)
- ~init_lexer:Content (* The initially used lexer *)
- in
- match pobj # root with
- Some r -> r
- | None -> raise(WF_error("No root element"))
-;;
-
-
-let iparse_document_entity ?(transform_dtd = (fun x -> x))
- ?id_index
- cfg0 src spec p_wf =
- (* Parse an element given as separate entity *)
- (* p_wf: 'true' if in well-formedness mode, 'false' if in validating mode *)
- let cfg = { cfg0 with
- recognize_standalone_declaration =
- cfg0.recognize_standalone_declaration && (not p_wf)
- } in
- let dtd = new dtd cfg.warner cfg.encoding in
- if p_wf then
- dtd # allow_arbitrary;
- let doc = new document cfg.warner in
- let pobj =
- call_parser
- ~configuration:cfg
- ~source:src
- ~dtd:dtd
- ~extensible_dtd:(not p_wf) (* Extend the DTD by parsed declarations
- * only if in validating mode
- *)
- ~document:doc
- ~specification:spec
- ~process_xmldecl:true (* The XML declaration is processed *)
- (* TODO: change to 'not p_wf' ? *)
- ~transform_dtd:(fun dtd ->
- let dtd' = transform_dtd dtd in
- if cfg.accept_only_deterministic_models then
- dtd' # only_deterministic_models;
- dtd')
-
- ~id_index:(id_index :> 'ext index option)
- ~use_document_entity:true
- ~entry:Ext_document (* Entry point of the grammar *)
- ~init_lexer:Document (* The initially used lexer *)
- in
- pobj # doc
-;;
-
-
-let parse_document_entity ?(transform_dtd = (fun x -> x))
- ?id_index
- cfg src spec =
- iparse_document_entity
- ~transform_dtd:transform_dtd
- ?id_index:(id_index : 'ext #index option :> 'ext index option)
- cfg src spec false;;
-
-let parse_wfdocument_entity cfg src spec =
- iparse_document_entity cfg src spec true;;
-
-let extract_dtd_from_document_entity cfg src =
- let transform_dtd dtd = raise (Return_DTD dtd) in
- try
- let doc = parse_document_entity
- ~transform_dtd:transform_dtd
- cfg
- src
- default_spec in
- (* Should not happen: *)
- doc # dtd
- with
- Return_DTD dtd ->
- (* The normal case: *)
- dtd
-;;
-
-
-let default_config =
- let w = new drop_warnings in
- { warner = w;
- errors_with_line_numbers = true;
- enable_pinstr_nodes = false;
- enable_super_root_node = false;
- enable_comment_nodes = false;
- encoding = `Enc_iso88591;
- recognize_standalone_declaration = true;
- store_element_positions = true;
- idref_pass = false;
- validate_by_dfa = true;
- accept_only_deterministic_models = true;
- debugging_mode = false;
- }
-
-
-class [ 'ext ] hash_index =
-object
- constraint 'ext = 'ext node #extension
- val ht = (Hashtbl.create 100 : (string, 'ext node) Hashtbl.t)
- method add s n =
- try
- ignore(Hashtbl.find ht s);
- raise ID_not_unique
- with
- Not_found ->
- Hashtbl.add ht s n
-
- method find s = Hashtbl.find ht s
- method index = ht
-end
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:29 lpadovan
- * Initial revision
- *
- * Revision 1.14 2000/08/26 23:23:14 gerd
- * Bug: from_file must not interpret the file name as URL path.
- * Bug: When PI and comment nodes are generated, the collected data
- * material must be saved first.
- *
- * Revision 1.13 2000/08/19 21:30:03 gerd
- * Improved the error messages of the parser
- *
- * Revision 1.12 2000/08/18 20:16:25 gerd
- * Implemented that Super root nodes, pinstr nodes and comment
- * nodes are included into the document tree.
- *
- * Revision 1.11 2000/08/14 22:24:55 gerd
- * Moved the module Pxp_encoding to the netstring package under
- * the new name Netconversion.
- *
- * Revision 1.10 2000/07/23 02:16:33 gerd
- * Support for DFAs.
- *
- * Revision 1.9 2000/07/14 13:57:29 gerd
- * Added the id_index feature.
- *
- * Revision 1.8 2000/07/09 17:52:45 gerd
- * New implementation for current_data.
- * The position of elements is stored on demand.
- *
- * Revision 1.7 2000/07/09 01:00:35 gerd
- * Improvement: It is now guaranteed that only one data node
- * is added for consecutive character material.
- *
- * Revision 1.6 2000/07/08 16:27:29 gerd
- * Cleaned up the functions calling the parser.
- * New parser argument: transform_dtd.
- * Implementations for 'extract_dtd_from_document_entity' and
- * 'parse_wfcontent_entity'.
- *
- * Revision 1.5 2000/07/06 23:05:18 gerd
- * Initializations of resolvers were missing.
- *
- * Revision 1.4 2000/07/06 22:11:01 gerd
- * Fix: The creation of the non-virtual root element is protected
- * in the same way as the virtual root element.
- *
- * Revision 1.3 2000/07/04 22:15:18 gerd
- * Change: Using the new resolver capabilities.
- * Still incomplete: the new extraction and parsing functions.
- *
- * Revision 1.2 2000/06/14 22:19:06 gerd
- * Added checks such that it is impossible to mix encodings.
- *
- * Revision 1.1 2000/05/29 23:48:38 gerd
- * Changed module names:
- * Markup_aux into Pxp_aux
- * Markup_codewriter into Pxp_codewriter
- * Markup_document into Pxp_document
- * Markup_dtd into Pxp_dtd
- * Markup_entity into Pxp_entity
- * Markup_lexer_types into Pxp_lexer_types
- * Markup_reader into Pxp_reader
- * Markup_types into Pxp_types
- * Markup_yacc into Pxp_yacc
- * See directory "compatibility" for (almost) compatible wrappers emulating
- * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
- *
- * ======================================================================
- * Old logs from markup_yacc.m2y:
- *
- * Revision 1.9 2000/05/29 21:14:57 gerd
- * Changed the type 'encoding' into a polymorphic variant.
- *
- * Revision 1.8 2000/05/27 19:26:19 gerd
- * Change: The XML declaration is interpreted right after
- * it has been parsed (no longer after the document): new function
- * check_and_parse_xmldecl.
- * When elements, attributes, and entities are declared
- * it is stored whether the declaration happens in an external
- * entity (for the standalone check).
- * The option recognize_standalone_declaration is interpreted.
- *
- * Revision 1.7 2000/05/20 20:31:40 gerd
- * Big change: Added support for various encodings of the
- * internal representation.
- *
- * Revision 1.6 2000/05/14 21:51:24 gerd
- * Change: Whitespace is handled by the grammar, and no longer
- * by the entity.
- *
- * Revision 1.5 2000/05/14 17:50:54 gerd
- * Updates because of changes in the token type.
- *
- * Revision 1.4 2000/05/11 22:09:17 gerd
- * Fixed the remaining problems with conditional sections.
- * This seems to be also a weakness of the XML spec!
- *
- * Revision 1.3 2000/05/09 00:02:44 gerd
- * Conditional sections are now recognized by the parser.
- * There seem some open questions; see the TODO comments!
- *
- * Revision 1.2 2000/05/08 22:01:44 gerd
- * Introduced entity managers (see markup_entity.ml).
- * The XML declaration is now recognized by the parser. If such
- * a declaration is found, the method process_xmldecl of the currently
- * active entity is called. If the first token is not an XML declaration,
- * the method process_missing_xmldecl is called instead.
- * Some minor changes.
- *
- * Revision 1.1 2000/05/06 23:21:49 gerd
- * Initial revision.
- *
- *
- * ======================================================================
- *
- * COPIED FROM REVISION 1.19 OF markup_yacc.mly
- *
- * Revision 1.19 2000/05/01 15:20:08 gerd
- * "End tag matches start tag" is checked before "End tag in the
- * same entity as start tag".
- *
- * Revision 1.18 2000/04/30 18:23:08 gerd
- * Bigger change: Introduced the concept of virtual roots. First,
- * this reduces the number of checks. Second, it makes it possible to
- * return the virtual root to the caller instead of the real root (new
- * config options 'virtual_root' and 'processing_instructions_inline').
- * Minor changes because of better CR/CRLF handling.
- *
- * Revision 1.17 2000/03/13 23:47:46 gerd
- * Updated because of interface changes. (See markup_yacc_shadow.mli
- * rev. 1.8)
- *
- * Revision 1.16 2000/01/20 20:54:43 gerd
- * New config.errors_with_line_numbers.
- *
- * Revision 1.15 1999/12/17 22:27:58 gerd
- * Bugfix: The value of 'p_internal_subset' (an instance
- * variable of the parser object) is to true when the internal subset
- * begins, and is set to false when this subset ends. The error was
- * that references to external entities within this subset did not
- * set 'p_internal_subset' to false; this is now corrected by introducing
- * the 'p_internal_subset_stack'.
- * This is a typical example of how the code gets more and
- * more complicated and that it is very difficult to really understand
- * what is going on.
- *
- * Revision 1.14 1999/11/09 22:23:37 gerd
- * Removed the invocation of "init_dtd" of the root document.
- * This method is no longer available. The DTD is also passed to the
- * document object by the root element, so nothing essential changes.
- *
- * Revision 1.13 1999/10/25 23:37:09 gerd
- * Bugfix: The warning "More than one ATTLIST declaration for element
- * type ..." is only generated if an ATTLIST is found while there are already
- * attributes for the element.
- *
- * Revision 1.12 1999/09/01 23:08:38 gerd
- * New frontend function: parse_wf_document. This simply uses
- * a DTD that allows anything, and by the new parameter "extend_dtd" it is
- * avoided that element, attlist, and notation declarations are added to this
- * DTD. The idea is that this function simulates a well-formedness parser.
- * Tag_beg, Tag_end carry the entity_id. The "elstack" stores the
- * entity_id of the stacked tag. This was necessary because otherwise there
- * are some examples to produces incorrectly nested elements.
- * p_internal_subset is a variable that stores whether the internal
- * subset is being parsed. This is important beacause entity declarations in
- * internal subsets are not allowed to contain parameter references.
- * It is checked if the "elstack" is empty after all has been parsed.
- * Processing instructions outside DTDs and outside elements are now
- * added to the document.
- * The rules of mixed and regexp style content models have been
- * separated. The code is now much simpler.
- * Entity references outside elements are detected and rejected.
- *
- * Revision 1.11 1999/09/01 16:26:08 gerd
- * Improved the quality of error messages.
- *
- * Revision 1.10 1999/08/31 19:13:31 gerd
- * Added checks on proper PE nesting. The idea is that tokens such
- * as Decl_element and Decl_rangle carry an entity ID with them. This ID
- * is simply an object of type < >, i.e. you can only test on identity.
- * The lexer always produces tokens with a dummy ID because it does not
- * know which entity is the current one. The entity layer replaces the dummy
- * ID with the actual ID. The parser checks that the IDs of pairs such as
- * Decl_element and Decl_rangle are the same; otherwise a Validation_error
- * is produced.
- *
- * Revision 1.9 1999/08/15 20:42:01 gerd
- * Corrected a misleading message.
- *
- * Revision 1.8 1999/08/15 20:37:34 gerd
- * Improved error messages.
- * Bugfix: While parsing document entities, the subclass document_entity is
- * now used instead of external_entity. The rules in document entities are a bit
- * stronger.
- *
- * Revision 1.7 1999/08/15 14:03:59 gerd
- * Empty documents are not allowed.
- * "CDATA section not allowed here" is a WF_error, not a Validation_
- * error.
- *
- * Revision 1.6 1999/08/15 02:24:19 gerd
- * Removed some grammar rules that were used for testing.
- * Documents without DTD can now have arbitrary elements (formerly
- * they were not allowed to have any element).
- *
- * Revision 1.5 1999/08/14 22:57:20 gerd
- * It is allowed that external entities are empty because the
- * empty string is well-parsed for both declarations and contents. Empty
- * entities can be referenced anywhere because the references are replaced
- * by nothing. Because of this, the Begin_entity...End_entity brace is only
- * inserted if the entity is non-empty. (Otherwise references to empty
- * entities would not be allowed anywhere.)
- * As a consequence, the grammar has been changed such that a
- * single Eof is equivalent to Begin_entity,End_entity without content.
- *
- * Revision 1.4 1999/08/14 22:20:01 gerd
- * The "config" slot has now a component "warner" which is
- * an object with a "warn" method. This is used to warn about characters
- * that cannot be represented in the Latin 1 alphabet.
- * Furthermore, there is a new component "debugging_mode".
- * Some Parse_error exceptions have been changed into Validation_error.
- * The interfaces of functions/classes imported from other modules
- * have changed; the invocations have been adapted.
- * Contents may contain CDATA sections that have been forgotten.
- *
- * Revision 1.3 1999/08/11 15:00:41 gerd
- * The Begin_entity ... End_entity brace is also possible in
- * 'contents'.
- * The configuration passed to the parsing object contains always
- * the resolver that is actually used.
- *
- * Revision 1.2 1999/08/10 21:35:12 gerd
- * The XML/encoding declaration at the beginning of entities is
- * evaluated. In particular, entities have now a method "xml_declaration"
- * which returns the name/value pairs of such a declaration. The "encoding"
- * setting is interpreted by the entity itself; "version", and "standalone"
- * are interpreted by Markup_yacc.parse_document_entity. Other settings
- * are ignored (this does not conform to the standard; the standard prescribes
- * that "version" MUST be given in the declaration of document; "standalone"
- * and "encoding" CAN be declared; no other settings are allowed).
- * TODO: The user should be warned if the standard is not exactly
- * fulfilled. -- The "standalone" property is not checked yet.
- *
- * Revision 1.1 1999/08/10 00:35:52 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff