+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- * PXP: The polymorphic XML parser for Objective Caml.
- * Copyright by Gerd Stolpmann. See LICENSE for details.
- *)
-
-
-(* TODO:
- * - Wie verhindert man, dass ein internal entity eine XML-Dekl. im
- * replacement text akzeptiert?
- *)
-
-
-open Pxp_types
-open Pxp_lexer_types
-open Pxp_aux
-open Pxp_reader
-
-(* Hierarchy of parsing layers:
- *
- * - Parser: Pxp_yacc
- * + gets input stream from the main entity object
- * + checks most of the grammar
- * + creates the DTD object as side-effect
- * + creates the element tree as side-effect
- * + creates further entity objects that are entered into the DTD
- * - Entity layer: Pxp_entity
- * + gets input stream from the lexers, or another entity object
- * + handles entity references: if a reference is encountered the
- * input stream is redirected such that the tokens come from the
- * referenced entity object
- * + handles conditional sections
- * - Lexer layer: Pxp_lexers
- * + gets input from lexbuffers created by resolvers
- * + different lexers for different lexical contexts
- * + a lexer returns pairs (token,lexid), where token is the scanned
- * token, and lexid is the name of the lexer that must be used for
- * the next token
- * - Resolver layer: Pxp_entity
- * + a resolver creates the lexbuf from some character source
- * + a resolver recodes the input and handles the encoding scheme
- *)
-
-(**********************************************************************)
-
-(* Variables of type 'state' are used to insert Begin_entity and End_entity
- * tokens into the stream.
- * - At_beginning: Nothing has been read so far
- * - First_token tok: A Begin_entity has been inserted; and the next token
- * is 'tok' which is not Eof. (Begin_entity/End_entity must not be inserted
- * if the entity is empty.)
- * - In_stream: After the first token has been read, but befor Eof.
- * - At_end: Eof has been read, and End_entity has been returned.
- *)
-
-type state =
- At_beginning
- | Inserted_begin_entity
- | At_end
-;;
-
-
-(**********************************************************************)
-
-class virtual entity the_dtd the_name the_warner
- init_errors_with_line_numbers init_encoding =
- object (self)
- (* This class prescribes the type of all entity objects. Furthermore,
- * the default 'next_token' mechanism is implemented.
- *)
-
- (* 'init_errors_with_line_numbers': whether error messages contain line
- * numbers or not.
- * Calculating line numbers is expensive.
- *)
-
- val mutable dtd = the_dtd
- val mutable name = the_name
- val mutable warner = the_warner
-
- val encoding = (init_encoding : rep_encoding)
- val lexerset = Pxp_lexers.get_lexer_set init_encoding
-
- method encoding = encoding
- (* method lexerset = lexerset *)
-
- val mutable manager = None
- (* The current entity_manager, see below *)
-
- method private manager =
- ( match manager with
- None -> assert false
- | Some m -> m
- : < current_entity : entity;
- pop_entity : unit;
- push_entity : entity -> unit >
- )
-
- method set_manager m = manager <- Some m
-
-
- val mutable lexbuf = Lexing.from_string ""
- (* The lexical buffer currently used as character source. *)
-
- val mutable prolog = None
- (* Stores the initial <?xml ...?> token as PI_xml *)
-
- val mutable prolog_pairs = []
- (* If prolog <> None, these are the (name,value) pairs of the
- * processing instruction.
- *)
-
-
- val mutable lex_id = Document
- (* The name of the lexer that should be used for the next token *)
-
- method set_lex_id id = lex_id <- lex_id
-
-
-
- val mutable force_parameter_entity_parsing = false
- (* 'true' forces that inner entities will always be embraced by
- * Begin_entity and End_entity.
- * 'false': the inner entity itself decides this
- *)
-
- val mutable check_text_declaration = true
- (* 'true': It is checked that the <?xml..?> declaration matches the
- * production TextDecl.
- *)
-
- val mutable normalize_newline = true
- (* Whether this entity converts CRLF or CR to LF, or not *)
-
-
- val mutable line = 1 (* current line *)
- val mutable column = 0 (* current column *)
- val mutable pos = 0 (* current absolute character position *)
- val errors_with_line_numbers = init_errors_with_line_numbers
-
- val mutable p_line = 1
- val mutable p_column = 1
-
- method line = p_line
- method column = p_column
-
-
- val mutable counts_as_external = false
-
- method counts_as_external = counts_as_external
- (* Whether the entity counts as external (for the standalone check). *)
-
- method set_counts_as_external =
- counts_as_external <- true
-
-
- val mutable last_token = Bof
- (* XXX
- * These two variables are used to check that between certain pairs of
- * tokens whitespaces exist. 'last_token' is simply the last token,
- * but not Ignore, and not PERef (which both represent whitespace).
- * 'space_seen' records whether Ignore or PERef was seen between this
- * token and 'last_token'.
- *)
-
- val mutable deferred_token = None
- (* If you set this to Some tl, the next invocations of
- * next_token_from_entity will return the tokens in tl.
- * This makes it possible to insert tokens into the stream.
- *)
-
- val mutable debug = false
-
- method is_ndata = false
- (* Returns if this entity is an NDATA (unparsed) entity *)
-
- method name = name
-
- method virtual open_entity : bool -> lexers -> unit
- (* open_entity force_parsing lexid:
- * opens the entity, and the first token is scanned by the lexer
- * 'lexid'. 'force_parsing' forces that Begin_entity and End_entity
- * tokens embrace the inner tokens of the entity; otherwise this
- * depends on the entity.
- * By opening an entity, reading tokens from it, and finally closing
- * the entity, the inclusion methods "Included",
- * "Included if validating", and "Included as PE" can be carried out.
- * Which method is chosen depends on the 'lexid', i.e. the lexical
- * context: 'lexid = Content' performs "Included (if validating)" (we
- * are always validating); 'lexid = Declaration' performs
- * "Included as PE". The difference is which tokens are recognized,
- * and how spaces are handled.
- * 'force_parsing' causes that a Begin_entity token is inserted before
- * and an End_entity token is inserted after the entity. The yacc
- * rules allow the Begin_entity ... End_entity brace only at certain
- * positions; this is used to restrict the possible positions where
- * entities may be included, and to guarantee that the entity matches
- * a certain production of the grammar ("parsed entities").
- * 'open_entity' is currently invoked with 'force_parsing = true'
- * for toplevel nodes, for inclusion of internal general entities,
- * and for inclusion of parameter entities into document entities.
- * 'force_parsing = false' is used for all other cases: External
- * entities add the Begin_entity/End_entity tokens anyway; internal
- * entities do not. Especially internal parameter entities referenced
- * from non-document entities do not add these tokens.
- *)
-
- method virtual close_entity : lexers
- (* close_entity:
- * closes the entity and returns the name of the lexer that must
- * be used to scan the next token.
- *)
-
- method virtual replacement_text : (string * bool)
- (* replacement_text:
- * returns the replacement text of the entity, and as second value,
- * whether the replacement text was constructed by referencing
- * external entities (directly or indirectly).
- * This method implements the inclusion method "Included in Literal".
- *)
-
-
- method lexbuf = lexbuf
-
-
- method xml_declaration =
- (* return the (name,value) pairs of the initial <?xml name=value ...?>
- * processing instruction.
- *)
- match prolog with
- None ->
- None
- | Some p ->
- Some prolog_pairs
-
-
- method set_debugging_mode m =
- debug <- m
-
- method private virtual set_encoding : string -> unit
-
-
- method full_name =
- name
-
-
- method next_token =
- (* read next token from this entity *)
-
- match deferred_token with
- Some toklist ->
- ( match toklist with
- [] ->
- deferred_token <- None;
- self # next_token
- | tok :: toklist' ->
- deferred_token <- Some toklist';
- if debug then
- prerr_endline ("- Entity " ^ name ^ ": " ^ string_of_tok tok ^ " (deferred)");
- tok
- )
- | None -> begin
- let this_line = line
- and this_column = column in
- let this_pos = pos in
- p_line <- this_line;
- p_column <- this_column;
- (* Read the next token from the appropriate lexer lex_id, and get the
- * name lex_id' of the next lexer to be used.
- *)
- let tok, lex_id' =
- match lex_id with
- Document -> lexerset.scan_document lexbuf
- | Document_type -> lexerset.scan_document_type lexbuf
- | Content -> lexerset.scan_content lexbuf
- | Within_tag -> lexerset.scan_within_tag lexbuf
- | Declaration -> lexerset.scan_declaration lexbuf
- | Content_comment -> lexerset.scan_content_comment lexbuf
- | Decl_comment -> lexerset.scan_decl_comment lexbuf
- | Document_comment -> lexerset.scan_document_comment lexbuf
- | Ignored_section -> assert false
- (* Ignored_section: only used by method next_ignored_token *)
- in
- if debug then
- prerr_endline ("- Entity " ^ name ^ ": " ^ string_of_tok tok);
- (* Find out the number of lines and characters of the last line: *)
- let n_lines, n_columns =
- if errors_with_line_numbers then
- count_lines (Lexing.lexeme lexbuf)
- else
- 0, (Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf)
- in
- line <- this_line + n_lines;
- column <- if n_lines = 0 then this_column + n_columns else n_columns;
- pos <- Lexing.lexeme_end lexbuf;
- lex_id <- lex_id';
- (* Throw Ignore and Comment away; Interpret entity references: *)
- (* NOTE: Of course, references to general entities are not allowed
- * everywhere; parameter references, too. This is already done by the
- * lexers, i.e. &name; and %name; are recognized only where they
- * are allowed.
- *)
-
- (* TODO: last_token is only used to detect Bof. Can be simplified *)
-
- let at_bof = (last_token = Bof) in
- last_token <- tok;
-
- let tok' =
- match tok with
-
- (* Entity references: *)
-
- | ERef n ->
- let en, extdecl = dtd # gen_entity n in
- if dtd # standalone_declaration && extdecl then
- raise
- (Validation_error
- ("Reference to entity `" ^ n ^
- "' violates standalone declaration"));
- en # set_debugging_mode debug;
- en # open_entity true lex_id;
- self # manager # push_entity en;
- en # next_token;
- | PERef n ->
- let en = dtd # par_entity n in
- en # set_debugging_mode debug;
- en # open_entity force_parameter_entity_parsing lex_id;
- self # manager # push_entity en;
- en # next_token;
-
- (* Convert LineEnd to CharData *)
- | LineEnd s ->
- if normalize_newline then
- CharData "\n"
- else
- CharData s
-
- (* Also normalize CDATA sections *)
- | Cdata value as cd ->
- if normalize_newline then
- Cdata(normalize_line_separators lexerset value)
- else
- cd
-
- (* If there are CRLF sequences in a PI value, normalize them, too *)
- | PI(name,value) as pi ->
- if normalize_newline then
- PI(name, normalize_line_separators lexerset value)
- else
- pi
-
- (* Attribute values: If they are already normalized, they are turned
- * into Attval_nl_normalized. This is detected by other code.
- *)
- | Attval value as av ->
- if normalize_newline then
- av
- else
- Attval_nl_normalized value
-
- (* Another CRLF normalization case: Unparsed_string *)
- | Unparsed_string value as ustr ->
- if normalize_newline then
- Unparsed_string(normalize_line_separators lexerset value)
- else
- ustr
-
- (* These tokens require that the entity_id parameter is set: *)
- | Doctype _ -> Doctype (self :> entity_id)
- | Doctype_rangle _ ->Doctype_rangle(self :> entity_id)
- | Dtd_begin _ -> Dtd_begin (self :> entity_id)
- | Dtd_end _ -> Dtd_end (self :> entity_id)
- | Decl_element _ -> Decl_element (self :> entity_id)
- | Decl_attlist _ -> Decl_attlist (self :> entity_id)
- | Decl_entity _ -> Decl_entity (self :> entity_id)
- | Decl_notation _ ->Decl_notation (self :> entity_id)
- | Decl_rangle _ -> Decl_rangle (self :> entity_id)
- | Lparen _ -> Lparen (self :> entity_id)
- | Rparen _ -> Rparen (self :> entity_id)
- | RparenPlus _ -> RparenPlus (self :> entity_id)
- | RparenStar _ -> RparenStar (self :> entity_id)
- | RparenQmark _ -> RparenQmark (self :> entity_id)
- | Conditional_begin _ -> Conditional_begin (self :> entity_id)
- | Conditional_body _ -> Conditional_body (self :> entity_id)
- | Conditional_end _ -> Conditional_end (self :> entity_id)
- | Tag_beg (n,_) -> Tag_beg (n, (self :> entity_id))
- | Tag_end (n,_) -> Tag_end (n, (self :> entity_id))
-
- (* End of file: *)
-
- | Eof ->
- if debug then begin
- prerr_endline ("- Entity " ^ name ^ " # handle_eof");
- let tok = self # handle_eof in
- prerr_endline ("- Entity " ^ name ^ " # handle_eof: returns " ^ string_of_tok tok);
- tok
- end
- else
- self # handle_eof;
-
- (* The default case. *)
-
- | _ ->
- tok
-
- in
- if at_bof & tok <> Eof
- then begin
- if debug then
- prerr_endline ("- Entity " ^ name ^ " # handle_bof");
- self # handle_bof tok'
- end
- else
- tok'
- end
-
-
- (* 'handle_bof' and 'handle_eof' can be used as hooks. Behaviour:
- *
- * - Normally, the first token t is read in, and 'handle_bof t' is
- * called. The return value of this method is what is returned to
- * the user.
- * - If the EOF has been reached, 'handle_eof' is called.
- * - BUT: If the first token is already EOF, 'handle_eof' is called
- * ONLY, and 'handle_bof' is NOT called.
- *
- * The default implementations:
- * - handle_bof: does nothing
- * - handle_eof: Pops the previous entity from the stack, switches back
- * to this entity, and returns the next token of this entity.
- *)
-
-
- method private handle_bof tok =
- tok
-
-
- method private handle_eof =
- let mng = self # manager in
- begin try
- mng # pop_entity;
- let next_lex_id = self # close_entity in
- let en = mng # current_entity in
- en # set_lex_id next_lex_id;
- en # next_token
- with
- Stack.Empty ->
- (* The outermost entity is at EOF *)
- Eof
- end
-
-
- method next_ignored_token =
- (* used after <![ IGNORE *)
-
- (* TODO: Do we need a test on deferred tokens here? *)
-
- let this_line = line
- and this_column = column in
- let this_pos = pos in
- let tok, lex_id' = lexerset.scan_ignored_section lexbuf in
- if debug then
- prerr_endline ("- Entity " ^ name ^ ": " ^ string_of_tok tok ^ " (Ignored)");
- let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
- line <- this_line + n_lines;
- column <- if n_lines = 0 then this_column + n_columns else n_columns;
- pos <- Lexing.lexeme_end lexbuf;
- match tok with
- | Conditional_begin _ -> Conditional_begin (self :> entity_id)
- | Conditional_end _ -> Conditional_end (self :> entity_id)
- | _ -> tok
-
-
- method process_xmldecl pl =
- (* The parser calls this method just after the XML declaration
- * <?xml ...?> has been detected.
- * 'pl': This is the argument of the PI_xml token.
- *)
- if debug then
- prerr_endline ("- Entity " ^ name ^ " # process_xmldecl");
- prolog <- Some pl;
- prolog_pairs <- decode_xml_pi pl;
- if check_text_declaration then
- check_text_xml_pi prolog_pairs;
- begin
- try
- let e = List.assoc "encoding" prolog_pairs in
- self # set_encoding e
- with
- Not_found ->
- self # set_encoding ""
- end;
-
-
- method process_missing_xmldecl =
- (* The parser calls this method if the XML declaration is missing *)
- if debug then
- prerr_endline ("- Entity " ^ name ^ " # process_missing_xmldecl");
- self # set_encoding ""
-
-
- (* Methods for NDATA entities only: *)
- method ext_id = (assert false : ext_id)
- method notation = (assert false : string)
-
- end
-;;
-
-
-class ndata_entity the_name the_ext_id the_notation init_encoding =
- object (self)
- (* An NDATA entity is very restricted; more or less you can only find out
- * its external ID and its notation.
- *)
-
- val mutable name = the_name
- val mutable ext_id = the_ext_id
- val mutable notation = the_notation
- val encoding = (init_encoding : rep_encoding)
-
- method name = (name : string)
- method ext_id = (ext_id : ext_id)
- method notation = (notation : string)
-
- method is_ndata = true
-
- method encoding = encoding
-
-
- val mutable counts_as_external = false
-
- method counts_as_external = counts_as_external
- (* Whether the entity counts as external (for the standalone check). *)
-
- method set_counts_as_external =
- counts_as_external <- true
-
-
- method set_manager (m : < current_entity : entity;
- pop_entity : unit;
- push_entity : entity -> unit >) =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : unit )
-
- method set_lex_id (id : lexers) =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : unit )
-
- method line =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : int )
-
- method column =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : int )
-
- method full_name =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : string )
-
- method private set_encoding (_:string) =
- assert false
-
- method xml_declaration = (None : (string*string) list option)
-
- method set_debugging_mode (_:bool) = ()
-
- method open_entity (_:bool) (_:lexers) =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : unit )
-
- method close_entity =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : lexers )
-
- method replacement_text =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : (string * bool) )
-
- method lexbuf =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : Lexing.lexbuf )
-
- method next_token =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : token )
-
- method next_ignored_token =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : token )
-
- method process_xmldecl (pl:prolog_token list) =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : unit )
-
- method process_missing_xmldecl =
- ( raise (Validation_error ("Invalid reference to NDATA entity " ^ name))
- : unit )
-
- end
-;;
-
-
-class external_entity the_resolver the_dtd the_name the_warner the_ext_id
- the_p_special_empty_entities
- init_errors_with_line_numbers
- init_encoding
- =
- object (self)
- inherit entity
- the_dtd the_name the_warner init_errors_with_line_numbers
- init_encoding
- as super
-
- (* An external entity gets the lexbuf that is used as character source
- * from a resolver.
- * Furthermore, before the first token an Begin_entity is inserted, and
- * before Eof an End_entity token is inserted into the stream. This done
- * always regardless of the argument 'force_parsing' of the method
- * 'open_entity'.
- *
- * 'the_p_internal_subset': see class internal_entity
- * 'the_p_special_empty_entities': if true, a Begin_entity/End_entity
- * brace is left out if the entity is otherwise empty.
- *)
-
- val resolver = (the_resolver : resolver)
- val ext_id = (the_ext_id : ext_id)
-
- val p_special_empty_entities = (the_p_special_empty_entities : bool)
-
- val mutable resolver_is_open = false
- (* Track if the resolver is open. This is also used to find recursive
- * references of entities.
- *)
-
- val mutable state = At_beginning
-
- initializer
- counts_as_external <- true;
-
-
- method private set_encoding e =
- assert resolver_is_open;
- resolver # change_encoding e
-
-
- method full_name =
- name ^
- match ext_id with
- System s -> " = SYSTEM \"" ^ s ^ "\""
- | Public(p,s) -> " = PUBLIC \"" ^ p ^ "\" \"" ^ s ^ "\""
- | Anonymous -> " = ANONYMOUS"
-
-
- method open_entity force_parsing init_lex_id =
- (* Note that external entities are always parsed, i.e. Begin_entity
- * and End_entity tokens embrace the inner tokens to force that
- * the entity is only called where the syntax allows it.
- *)
- if resolver_is_open then
- raise(Validation_error("Recursive reference to entity `" ^ name ^ "'"));
- let lex =
- try
- resolver # open_in ext_id
- with
- Pxp_reader.Not_competent ->
- raise(Error ("No input method available for this external entity: " ^
- self # full_name))
- | Pxp_reader.Not_resolvable Not_found ->
- raise(Error ("Unable to open the external entity: " ^
- self # full_name))
- | Pxp_reader.Not_resolvable e ->
- raise(Error ("Unable to open the external entity: " ^
- self # full_name ^ "; reason: " ^
- string_of_exn e))
- in
- resolver_is_open <- true;
- lexbuf <- lex;
- prolog <- None;
- lex_id <- init_lex_id;
- state <- At_beginning;
- line <- 1;
- column <- 0;
- pos <- 0;
- last_token <- Bof;
- normalize_newline <- true;
-
-
- method private handle_bof tok =
- (* This hook is only called if the stream is not empty. *)
- deferred_token <- Some [ tok ];
- state <- Inserted_begin_entity;
- Begin_entity
-
-
- method private handle_eof =
- (* This hook is called if the end of the stream is reached *)
- match state with
- At_beginning ->
- (* This is only possible if the stream is empty. *)
- if p_special_empty_entities then begin
- (* Continue immediately with the next token *)
- state <- At_end;
- super # handle_eof
- end
- else begin
- (* Insert Begin_entity / End_entity *)
- deferred_token <- Some [ End_entity ];
- state <- At_end;
- Begin_entity;
- (* After these two token have been processed, the lexer
- * is called again, and it will return another Eof.
- *)
- end
- | Inserted_begin_entity ->
- (* Insert End_entity, too. *)
- state <- At_end;
- End_entity;
- | At_end ->
- (* Continue with the next token: *)
- super # handle_eof
-
-
- method close_entity =
- if not resolver_is_open then
- failwith ("External entity " ^ name ^ " not open");
- resolver # close_in;
- resolver_is_open <- false;
- lex_id
-
-
- method replacement_text =
- (* Return the replacement text of the entity. The method used for this
- * is more or less the same as for internal entities; i.e. character
- * and parameter entities are resolved immediately. In addition to that,
- * external entities may begin with an "xml" processing instruction
- * which is considered not to be part of the replacement text.
- *)
- if resolver_is_open then
- raise(Validation_error("Recursive reference to entity `" ^ name ^ "'"));
- let lex = resolver # open_in ext_id in
- resolver_is_open <- true;
- lexbuf <- lex;
- prolog <- None;
- (* arbitrary: lex_id <- init_lex_id; *)
- state <- At_beginning;
- line <- 1;
- column <- 0;
- pos <- 0;
- last_token <- Bof;
- (* First check if the first token of 'lex' is <?xml...?> *)
- begin match lexerset.scan_only_xml_decl lex with
- PI_xml pl ->
- self # process_xmldecl pl
- | Eof ->
- (* This only means that the first token was not <?xml...?>;
- * the "Eof" token represents the empty string.
- *)
- self # process_missing_xmldecl
- | _ ->
- (* Must not happen. *)
- assert false
- end;
- (* Then create the replacement text. *)
- let rec scan_and_expand () =
- match lexerset.scan_dtd_string lexbuf with
- ERef n -> "&" ^ n ^ ";" ^ scan_and_expand()
- | CRef(-1) -> "\n" ^ scan_and_expand()
- | CRef(-2) -> "\n" ^ scan_and_expand()
- | CRef(-3) -> "\n" ^ scan_and_expand()
- | CRef k -> character encoding warner k ^ scan_and_expand()
- | CharData x -> x ^ scan_and_expand()
- | PERef n ->
- let en = dtd # par_entity n in
- let (x,_) = en # replacement_text in
- x ^ scan_and_expand()
- | Eof ->
- ""
- | _ ->
- assert false
- in
- let rtext = scan_and_expand() in
- resolver # close_in;
- resolver_is_open <- false;
- rtext, true
- (* TODO:
- * - The replaced text is not parsed [VALIDATION WEAKNESS]
- *)
- end
-;;
-
-
-class document_entity the_resolver the_dtd the_name the_warner the_ext_id
- init_errors_with_line_numbers
- init_encoding
- =
- object (self)
- inherit external_entity the_resolver the_dtd the_name the_warner
- the_ext_id false init_errors_with_line_numbers
- init_encoding
-
- (* A document entity is an external entity that does not allow
- * conditional sections, and that forces that internal parameter entities
- * are properly nested.
- *)
-
- initializer
- force_parameter_entity_parsing <- true;
- check_text_declaration <- false;
-
- method counts_as_external = false
- (* Document entities count never as external! *)
- end
-;;
-
-
-class internal_entity the_dtd the_name the_warner the_literal_value
- the_p_internal_subset init_errors_with_line_numbers
- init_is_parameter_entity
- init_encoding
- =
- (* An internal entity uses a "literal entity value" as character source.
- * This value is first expanded and preprocessed, i.e. character and
- * parameter references are expanded.
- *
- * 'the_p_internal_subset': indicates that the entity is declared in the
- * internal subset. Such entity declarations are not allowed to contain
- * references to parameter entities.
- * 'init_is_parameter_entity': whether this is a parameter entity or not
- *)
-
- object (self)
- inherit entity
- the_dtd the_name the_warner init_errors_with_line_numbers
- init_encoding
- as super
-
- val p_internal_subset = the_p_internal_subset
-
- val mutable replacement_text = ""
- val mutable contains_external_references = false
- val mutable p_parsed_actually = false
- val mutable is_open = false
- val mutable state = At_beginning
- val mutable is_parameter_entity = init_is_parameter_entity
-
-
- initializer
- let lexbuf = Lexing.from_string the_literal_value in
- let rec scan_and_expand () =
- match lexerset.scan_dtd_string lexbuf with
- ERef n -> "&" ^ n ^ ";" ^ scan_and_expand()
- | CRef(-1) -> "\r\n" ^ scan_and_expand()
- | CRef(-2) -> "\r" ^ scan_and_expand()
- | CRef(-3) -> "\n" ^ scan_and_expand()
- | CRef k -> character encoding warner k ^ scan_and_expand()
- | CharData x -> x ^ scan_and_expand()
- | PERef n ->
- if p_internal_subset then
- raise(WF_error("Restriction of the internal subset: parameter entity not allowed here"));
- let en = dtd # par_entity n in
- let (x, extref) = en # replacement_text in
- contains_external_references <-
- contains_external_references or extref;
- x ^ scan_and_expand()
- | Eof ->
- ""
- | _ ->
- assert false
- in
- is_open <- true;
- replacement_text <- scan_and_expand();
- is_open <- false;
- normalize_newline <- false;
- counts_as_external <- false;
-
-
- method process_xmldecl (pl:prolog_token list) =
- raise(Validation_error("The encoding cannot be changed in internal entities"))
-
-
- method process_missing_xmldecl =
- ()
-
-
- method private set_encoding e =
- (* Ignored if e = "" *)
- assert(e = "");
-
-
- method open_entity force_parsing init_lex_id =
- if is_open then
- raise(Validation_error("Recursive reference to entity `" ^ name ^ "'"));
-
- p_parsed_actually <- force_parsing;
- lexbuf <- Lexing.from_string
- (if is_parameter_entity then
- (" " ^ replacement_text ^ " ")
- else
- replacement_text);
- prolog <- None;
- lex_id <- init_lex_id;
- state <- At_beginning;
- is_open <- true;
- line <- 1;
- column <- 0;
- pos <- 0;
- last_token <- Eof;
-
-
- method private handle_bof tok =
- (* This hook is only called if the stream is not empty. *)
- if p_parsed_actually then begin
- deferred_token <- Some [ tok ];
- state <- Inserted_begin_entity;
- Begin_entity
- end
- else begin
- state <- At_end;
- tok
- end
-
-
- method private handle_eof =
- (* This hook is called if the end of the stream is reached *)
- match state with
- At_beginning ->
- (* This is only possible if the stream is empty. *)
- if p_parsed_actually then begin
- (* Insert Begin_entity / End_entity *)
- deferred_token <- Some [ End_entity ];
- state <- At_end;
- Begin_entity;
- (* After these two token have been processed, the lexer
- * is called again, and it will return another Eof.
- *)
- end
- else begin
- (* Continue immediately with the next token *)
- state <- At_end;
- super # handle_eof
- end
- | Inserted_begin_entity ->
- (* Insert End_entity, too. *)
- state <- At_end;
- End_entity;
- | At_end ->
- (* Continue with the next token: *)
- super # handle_eof
-
-
- method close_entity =
- if not is_open then
- failwith ("Internal entity " ^ name ^ " not open");
- is_open <- false;
- lex_id
-
-
- method replacement_text =
- if is_open then
- raise(Validation_error("Recursive reference to entity `" ^ name ^ "'"));
- replacement_text, contains_external_references
- end
-;;
-
-(**********************************************************************)
-
-(* An 'entity_manager' is a stack of entities, where the topmost entity
- * is the currently active entity, the second entity is the entity that
- * referred to the active entity, and so on.
- *
- * The entity_manager can communicate with the currently active entity.
- *
- * The entity_manager provides an interface for the parser; the functions
- * returning the current token and the next token are exported.
- *)
-
-class entity_manager (init_entity : entity) =
- object (self)
- val mutable entity_stack = Stack.create()
- val mutable current_entity = init_entity
- val mutable current_entity's_full_name = lazy (init_entity # full_name)
-
- val mutable yy_get_next_ref = ref (fun () -> assert false)
-
- initializer
- init_entity # set_manager (self :>
- < current_entity : entity;
- pop_entity : unit;
- push_entity : entity -> unit >
- );
- yy_get_next_ref := (fun () -> init_entity # next_token)
-
- method push_entity e =
- e # set_manager (self :>
- < current_entity : entity;
- pop_entity : unit;
- push_entity : entity -> unit >
- );
- Stack.push (current_entity, current_entity's_full_name) entity_stack;
- current_entity <- e;
- current_entity's_full_name <- lazy (e # full_name);
- yy_get_next_ref := (fun () -> e # next_token);
-
- method pop_entity =
- (* May raise Stack.Empty *)
- let e, e_name = Stack.pop entity_stack in
- current_entity <- e;
- current_entity's_full_name <- e_name;
- yy_get_next_ref := (fun () -> e # next_token);
-
-
-
- method position_string =
- (* Gets a string describing the position of the last token;
- * includes an entity backtrace
- *)
- let b = Buffer.create 200 in
- Buffer.add_string b
- ("In entity " ^ current_entity # full_name
- ^ ", at line " ^ string_of_int (current_entity # line)
- ^ ", position " ^ string_of_int (current_entity # column)
- ^ ":\n");
- Stack.iter
- (fun (e, e_name) ->
- Buffer.add_string b
- ("Called from entity " ^ Lazy.force e_name
- ^ ", line " ^ string_of_int (e # line)
- ^ ", position " ^ string_of_int (e # column)
- ^ ":\n");
- )
- entity_stack;
- Buffer.contents b
-
-
- method position =
- (* Returns the triple (full_name, line, column) of the last token *)
- Lazy.force current_entity's_full_name,
- current_entity # line,
- current_entity # column
-
-
- method current_entity_counts_as_external =
- (* Whether the current entity counts as external to the main
- * document for the purpose of stand-alone checks.
- *)
- (* TODO: improve performance *)
- let is_external = ref false in
- let check (e, _) =
- if e # counts_as_external then begin
- is_external := true;
- end;
- in
- check (current_entity,());
- Stack.iter check entity_stack;
- !is_external
-
-
- method current_entity = current_entity
-
- method yy_get_next_ref = yy_get_next_ref
-
- end
-;;
-
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:29 lpadovan
- * Initial revision
- *
- * Revision 1.6 2000/07/14 13:55:00 gerd
- * Cosmetic changes.
- *
- * Revision 1.5 2000/07/09 17:51:50 gerd
- * Entities return now the beginning of a token as its
- * position.
- * New method 'position' for entity_manager.
- *
- * Revision 1.4 2000/07/09 01:05:04 gerd
- * Exported methods 'ext_id' and 'notation' anyway.
- *
- * Revision 1.3 2000/07/08 16:28:05 gerd
- * Updated: Exception 'Not_resolvable' is taken into account.
- *
- * Revision 1.2 2000/07/04 22:12:47 gerd
- * Update: Case ext_id = Anonymous.
- * Update: Handling of the exception Not_competent when reading
- * from a resolver.
- *
- * 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_entity.ml:
- *
- * Revision 1.27 2000/05/29 21:14:57 gerd
- * Changed the type 'encoding' into a polymorphic variant.
- *
- * Revision 1.26 2000/05/28 17:24:55 gerd
- * Bugfixes.
- *
- * Revision 1.25 2000/05/27 19:23:32 gerd
- * The entities store whether they count as external with
- * respect to the standalone check: New methods counts_as_external
- * and set_counts_as_external.
- * The entity manager can find out whether the current
- * entity counts as external: method current_entity_counts_as_external.
- *
- * Revision 1.24 2000/05/20 20:31:40 gerd
- * Big change: Added support for various encodings of the
- * internal representation.
- *
- * Revision 1.23 2000/05/14 21:51:24 gerd
- * Change: Whitespace is handled by the grammar, and no longer
- * by the entity.
- *
- * Revision 1.22 2000/05/14 17:50:54 gerd
- * Updates because of changes in the token type.
- *
- * Revision 1.21 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.20 2000/05/08 21:58:22 gerd
- * Introduced entity_manager as communication object between
- * the parser and the currently active entity.
- * New hooks handle_bof and handle_eof.
- * Removed "delegated entities". The entity manager contains
- * the stack of open entities.
- * Changed the way Begin_entity and End_entity are inserted.
- * This is now done by handle_bof and handle_eof.
- * The XML declaration is no longer detected by the entity.
- * This is now done by the parser.
- *
- * Revision 1.19 2000/05/01 15:18:44 gerd
- * Improved CRLF handling in the replacement text of entities.
- * Changed one error message.
- *
- * Revision 1.18 2000/04/30 18:18:39 gerd
- * Bugfixes: The conversion of CR and CRLF to LF is now hopefully
- * done right. The new variable "normalize_newline" indicates whether
- * normalization must happen for that type of entity. The normalization
- * if actually carried out separately for every token that needs it.
- *
- * Revision 1.17 2000/03/13 23:42:38 gerd
- * Removed the resolver classes, and put them into their
- * own module (Markup_reader).
- *
- * Revision 1.16 2000/02/22 01:06:58 gerd
- * Bugfix: Resolvers are properly re-initialized. This bug caused
- * that entities could not be referenced twice in the same document.
- *
- * Revision 1.15 2000/01/20 20:54:11 gerd
- * New config.errors_with_line_numbers.
- *
- * Revision 1.14 2000/01/08 18:59:03 gerd
- * Corrected the string resolver.
- *
- * Revision 1.13 1999/09/01 22:58:23 gerd
- * Method warn_not_latin1 raises Illegal_character if the character
- * does not match the Char production.
- * External entities that are not document entities check if the
- * <?xml...?> declaration at the beginning matches the TextDecl production.
- * Method xml_declaration has type ... list option, not ... list.
- * Tag_beg and Tag_end now carry an entity_id with them.
- * The code to check empty entities has changed. That the Begin_entity/
- * End_entity pair is not to be added must be explicitly turned on. See the
- * description of empty entity handling in design.txt.
- * In internal subsets entity declarations are not allowed to refer
- * to parameter entities. The internal_entity class can do this now.
- * The p_parsed parameter of internal_entity has gone. It was simply
- * superflous.
- *
- * Revision 1.12 1999/09/01 16:24:13 gerd
- * The method replacement_text returns the text as described for
- * "included in literal". The former behaviour has been dropped to include
- * a leading and a trailing space character for parameter entities.
- * Bugfix: When general entities are included, they are always parsed.
- *
- * Revision 1.11 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.10 1999/08/19 01:06:41 gerd
- * Improved error messages: external entities print their
- * ext id, too
- *
- * Revision 1.9 1999/08/15 20:35:48 gerd
- * Improved error messages.
- * Before the tokens Plus, Star, Qmark space is not allowed any longer.
- * Detection of recursive entity references is a bit cleaner.
- *
- * Revision 1.8 1999/08/15 15:33:44 gerd
- * Revised whitespace checking: At certain positions there must be
- * white space. These checks cannot be part of the lexer, as %entity; counts
- * as white space. They cannot be part of the yacc parser because one look-ahead
- * token would not suffice if we did that. So these checks must be done by the
- * entity layer. Luckily, the rules are simple: There are simply a number of
- * token pairs between which white space must occur independently of where
- * these token have been found. Two variables, "space_seen", and "last_token"
- * have been added in order to check these rules.
- *
- * Revision 1.7 1999/08/15 00:41:06 gerd
- * The [ token of conditional sections is now allowed to occur
- * in a different entity.
- *
- * Revision 1.6 1999/08/15 00:29:02 gerd
- * The method "attlist_replacement_text" has gone. There is now a
- * more general "replacement_text" method that computes the replacement
- * text for both internal and external entities. Additionally, this method
- * returns whether references to external entities have been resolved;
- * this is checked in the cases where formerly "attlist_replacement_text"
- * was used as it is not allowed everywhere.
- * Entities have a new slot "need_spaces" that indicates that the
- * next token must be white space or a parameter reference. The problem
- * was that "<!ATTLIST%e;" is legal because when including parameter
- * entities white space is added implicitly. Formerly, the white space
- * was expected by the underlying lexer; now the lexer does not check
- * anymore that "<!ATTLIST" is followed by white space because the lexer
- * cannot handle parameter references. Because of this, the check on
- * white space must be done by the entity.
- *
- * Revision 1.5 1999/08/14 22:57:19 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:11:19 gerd
- * Several objects have now a "warner" as argument which is
- * an object with a "warn" method. This is used to warn about characters
- * that cannot be represented in the Latin 1 alphabet.
- * Previously, the resolvers had features in order to warn about
- * such characters; this has been removed.
- * UTF-8 streams can be read even if they contain characters
- * that cannot be represented by 16 bits.
- * The buffering used in the resolvers is now solved in a
- * cleaner way; the number of characters that are expected to be read
- * from a source can be limited. This removes a bug with UTF-16 streams
- * that previously lead to wrong exceptions; and the buffering is more
- * efficient, too.
- *
- * Revision 1.3 1999/08/11 14:58:53 gerd
- * Some more names for encodings are allowed, such as "utf8" instead
- * of the standard name "UTF-8".
- * 'resolve_as_file' interprets relative file names as relative to
- * the "parent" resolver.
- *
- * Revision 1.2 1999/08/10 21:35:07 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:51 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff