+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- * PXP: The polymorphic XML parser for Objective Caml.
- * Copyright by Gerd Stolpmann. See LICENSE for details.
- * Some auxiliary functions
- *)
-
-(**********************************************************************)
-(* Lexing *)
-
-
-open Pxp_types
-open Pxp_lexer_types
-open Pxp_lexers
-open Netconversion
-
-let character enc warner k =
- assert (k>=0);
- if (k >= 0xd800 & k < 0xe000) or (k >= 0xfffe & k <= 0xffff) or k > 0x10ffff
- or (k < 8) or (k = 11) or (k = 12) or (k >= 14 & k <= 31)
- then
- raise (WF_error("Code point " ^ string_of_int k ^
- " outside the accepted range of code points"));
-
- try
- makechar (enc : rep_encoding :> encoding) k
- with
- Not_found ->
- warner # warn ("Code point cannot be represented in internal encoding: "
- ^ string_of_int k);
- ""
-;;
-
-
-let check_name warner name =
- (* produces a warning for names beginning with "xml". *)
- if String.length name >= 3 then begin
- match String.sub name 0 3 with
- ("xml" | "xmL" | "xMl" | "xML" | "Xml" | "XmL" | "XMl" | "XML") ->
- warner # warn ("Name is reserved for future extensions: " ^ name)
- | _ ->
- ()
- end
-;;
-
-
-let tokens_of_content_string lexerset s =
- (* tokenizes general entities and character entities *)
- let lexbuf = Lexing.from_string s in
- let rec next_token () =
- match lexerset.scan_content_string lexbuf with
- Eof -> []
- | tok -> tok :: next_token()
- in
- next_token()
-;;
-
-
-let rec expand_attvalue_with_rec_check lexerset dtd s warner entities norm_crlf =
- (* recursively expands general entities and character entities;
- * checks "standalone" document declaration;
- * normalizes whitespace
- *)
- let toklist = tokens_of_content_string lexerset s in
- let rec expand tl =
- match tl with
- [] -> ""
- | ERef n :: tl' ->
- if List.mem n entities then
- raise(WF_error("Recursive reference to general entity `" ^ 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"));
- let rtext, rtext_contains_ext_refs = en # replacement_text in
- if rtext_contains_ext_refs then
- raise(Validation_error("Found reference to external entity in attribute value"));
- expand_attvalue_with_rec_check
- lexerset dtd rtext warner (n :: entities) false ^ expand tl'
- | CRef(-1) :: tl' ->
- if norm_crlf then
- " " ^ expand tl'
- else
- " " ^ expand tl'
- | CRef n :: tl' ->
- character lexerset.lex_encoding warner n ^ expand tl'
- | CharData "<" :: tl' ->
- raise
- (WF_error
- ("Attribute value contains character '<' literally"))
- | CharData x :: tl' ->
- x ^ expand tl'
- | _ -> assert false
- in
- expand toklist
-;;
-
-
-let expand_attvalue lexerset dtd s warner norm_crlf =
- (* norm_crlf: whether the sequence CRLF is recognized as one character or
- * not (i.e. two characters)
- *)
- expand_attvalue_with_rec_check lexerset dtd s warner [] norm_crlf
-;;
-
-
-let count_lines s =
- (* returns number of lines in s, number of columns of the last line *)
- let l = String.length s in
-
- let rec count n k no_cr no_lf =
- let next_cr =
- if no_cr then
- (-1)
- else
- try String.index_from s k '\013' with Not_found -> (-1) in
- let next_lf =
- if no_lf then
- (-1)
- else
- try String.index_from s k '\010' with Not_found -> (-1) in
- if next_cr >= 0 & (next_lf < 0 or next_cr < next_lf) then begin
- if next_cr+1 < l & s.[next_cr+1] = '\010' then
- count (n+1) (next_cr+2) false (next_lf < 0)
- else
- count (n+1) (next_cr+1) false (next_lf < 0)
- end
- else if next_lf >= 0 then begin
- count (n+1) (next_lf+1) (next_cr < 0) false
- end
- else
- n, (l - k)
-
- in
- count 0 0 false false
-;;
-
-
-let tokens_of_xml_pi lexers s =
- let lexbuf = Lexing.from_string (s ^ " ") in
- let rec collect () =
- let t = lexers.scan_xml_pi lexbuf in
- match t with
- Pro_eof -> []
- | _ -> t :: collect()
- in
- collect()
-;;
-
-
-let decode_xml_pi pl =
- (* 'pl' must consist of name="value" or name='value' pairs which are returned
- * as list of pairs.
- * The "value" is returned as it is; no substitution of &entities; happens.
- *)
- let rec decode pl =
- match pl with
- Pro_name name :: Pro_eq :: Pro_string value :: pl' ->
- (name, value) :: decode pl'
- | [] ->
- []
- | _ ->
- raise (WF_error("Bad XML processing instruction"))
- in
- decode pl
-;;
-
-
-let decode_doc_xml_pi pl =
- match pl with
- [ "version", v ] -> (v, None, None)
- | [ "version", v; "encoding", e ] -> (v, Some e, None)
- | [ "version", v; "standalone", s ] -> (v, None, Some s)
- | [ "version", v; "encoding", e; "standalone", s ] -> (v, Some e, Some s)
- | _ ->
- raise(WF_error("Bad XML declaration"))
-;;
-
-
-let check_text_xml_pi pl =
- match pl with
- | [ "version", v; "encoding", e ] -> ()
- | [ "encoding", e ] -> ()
- | _ ->
- raise(WF_error("Bad XML declaration"))
-;;
-
-
-let check_version_num s =
- let l = String.length s in
- for i = 0 to l - 1 do
- match s.[i] with
- ('a'..'z'|'A'..'Z'|'0'..'9'|
- '-'|'_'|'.'|':') -> ()
- | _ ->
- raise(WF_error("Bad XML version string"))
- done
-;;
-
-
-let check_public_id s =
- let l = String.length s in
- for i = 0 to l - 1 do
- match s.[i] with
- (' '|'\013'|'\010'|'a'..'z'|'A'..'Z'|'0'..'9'|
- '-'|'\''|'('|')'|'+'|','|'.'|'/'|':'|'='|'?'|
- ';'|'!'|'*'|'#'|'@'|'$'|'_'|'%') -> ()
- | _ ->
- raise(WF_error("Illegal character in PUBLIC identifier"))
- done
-;;
-
-
-(**********************************************************************)
-(* list functions *)
-
-
-let rec check_dups l =
- match l with
- [] -> false
- | c :: l' ->
- if List.mem c l' then true else check_dups l'
-;;
-
-
-let rec count pred l =
- match l with
- [] -> 0
- | x :: l' ->
- if pred x then 1 + (count pred l') else count pred l'
-;;
-
-
-(**********************************************************************)
-(* attributes *)
-
-let check_attribute_value_lexically lexerset x t v =
- (* raises x if the attribute value v does not match the lexical rules
- * for attribute type t:
- * - t = A_id: v must be a <name>
- * - t = A_idref: v must match <name>
- * - t = A_idrefs: v must match <names>
- * - t = A_entity: v must match <name>
- * - t = A_entities: v must match <names>
- * - t = A_nmtoken: v must match <nmtoken>
- * - t = A_nmtokens: v must match <nmtokens>
- * - t = A_notation _: v must match <name>
- * - t = A_enum _: v must match <nmtoken>
- * - t = A_cdata: not checked
- *)
- let lexbuf = Lexing.from_string v in
- let rec get_name_list() =
- match lexerset.scan_name_string lexbuf with
- Eof -> []
- | Ignore -> get_name_list()
- | tok -> tok :: get_name_list()
- in
- let l = get_name_list() in
- match t with
- (A_id | A_idref | A_entity | A_notation _) ->
- begin match l with
- [ Name n ] -> ()
- | _ -> raise (Lazy.force x)
- end
- | (A_idrefs | A_entities) ->
- if List.exists (fun tok ->
- match tok with
- Name _ -> false
- | _ -> true) l then
- raise (Lazy.force x)
- | (A_nmtoken | A_enum _) ->
- begin match l with
- [ Name n ] -> ()
- | [ Nametoken n ] -> ()
- | _ -> raise (Lazy.force x)
- end
- | A_nmtokens ->
- if List.exists (fun tok ->
- match tok with
- Name _ -> false
- | Nametoken _ -> false
- | _ -> true
- ) l then
- raise (Lazy.force x)
- | _ -> ()
-;;
-
-
-let split_attribute_value lexerset v =
- (* splits 'v' into a list of names or nmtokens. The white space separating
- * the names/nmtokens in 'v' is suppressed and not returned.
- *)
- let lexbuf = Lexing.from_string v in
- let rec get_name_list() =
- match lexerset.scan_name_string lexbuf with
- Eof -> []
- | Ignore -> get_name_list()
- | Name s -> s :: get_name_list()
- | Nametoken s -> s :: get_name_list()
- | _ -> raise(Validation_error("Illegal attribute value"))
- in
- get_name_list()
-;;
-
-
-let normalize_line_separators lexerset s =
- let lexbuf = Lexing.from_string s in
- let rec get_string() =
- match lexerset.scan_for_crlf lexbuf with
- Eof -> ""
- | CharData s -> s ^ get_string()
- | _ -> assert false
- in
- get_string()
-;;
-
-
-let value_of_attribute lexerset dtd n atype v =
- (* The attribute with name 'n', type 'atype' and string value 'v' is
- * decomposed, and the att_value is returned:
- * - It is checked whether 'v' conforms to the lexical rules for attributes
- * of type 'atype'
- * - If 'atype <> A_cdata', leading and trailing spaces are removed from 'v'.
- * - If 'atype = A_notation d', it is checked if 'v' matches one of the
- * notation names contained in d.
- * - If 'atype = A_enum d', it is checked whether 'v' matches one of the
- * tokens from d
- * - If 'atype' refers to a "single-value" type, the value is retured as
- * Value u, where u is the normalized value. If 'atype' refers to a
- * "list" type, the value if returned as Valuelist l, where l contains
- * the tokens.
- *
- * Note that this function does not implement all normalization rules.
- * It is expected that the string passed as 'v' is already preprocessed;
- * i.e. character and entity references are resolved, and the substitution
- * of white space characters by space characters has already been performed.
- * If these requirements are met, the value returned by this function
- * will be perfectly normalized.
- *
- * Further checks:
- * - ENTITY and ENTITIES values: It is checked whether there is an
- * unparsed general entity
- * [ Other checks planned: ID, IDREF, IDREFS but not yet implemented ]
- *)
-
- let lexical_error() =
- lazy (raise(Validation_error("Attribute `" ^ n ^ "' is lexically malformed"))) in
-
- let remove_leading_and_trailing_spaces u =
- (* Precondition: 'u' matches <name> or <nmtoken> *)
- match split_attribute_value lexerset u with
- [ u' ] -> u'
- | _ -> assert false
- in
-
- let check_ndata_entity u =
- let en, extdecl = dtd # gen_entity u in (* or Validation_error *)
- if not (en # is_ndata) then
- raise(Validation_error("Reference to entity `" ^ u ^
- "': NDATA entity expected"));
- if dtd # standalone_declaration && extdecl then
- raise(Validation_error("Reference to entity `" ^ u ^
- "' violates standalone declaration"));
- in
-
- match atype with
- A_cdata ->
- Value v
-
- | (A_id | A_idref | A_nmtoken) ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- Value (remove_leading_and_trailing_spaces v)
- | A_entity ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- let v' = remove_leading_and_trailing_spaces v in
- check_ndata_entity v';
- Value v'
-
- | (A_idrefs | A_nmtokens) ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- Valuelist (split_attribute_value lexerset v)
-
- | A_entities ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- let l = split_attribute_value lexerset v in
- List.iter check_ndata_entity l;
- Valuelist l
-
- | A_notation nl ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- let v' = remove_leading_and_trailing_spaces v in
- if not (List.mem v' nl) then
- raise(Validation_error
- ("Attribute `" ^ n ^
- "' does not match one of the declared notation names"));
- Value v'
-
- | A_enum enuml ->
- check_attribute_value_lexically lexerset (lexical_error()) atype v;
- let v' = remove_leading_and_trailing_spaces v in
- if not (List.mem v' enuml) then
- raise(Validation_error
- ("Attribute `" ^ n ^
- "' does not match one of the declared enumerator tokens"));
- Value v'
-;;
-
-
-let normalization_changes_value lexerset atype v =
- (* Returns true if:
- * - 'atype' is a "single-value" type, and the normalization of the string
- * value 'v' of this type discards leading and/or trailing spaces
- * - 'atype' is a "list" type, and the normalization of the string value
- * 'v' of this type discards leading and/or trailing spaces, or spaces
- * separating the tokens of the list (i.e. the normal form is that
- * the tokens are separated by exactly one space character).
- *
- * Note: It is assumed that TABs, CRs, and LFs in 'v' are already converted
- * to spaces.
- *)
-
- match atype with
- A_cdata ->
- false
-
- | (A_id | A_idref | A_entity | A_nmtoken | A_notation _ | A_enum _) ->
- (* Return 'true' if the first or last character is a space.
- * The following check works for both ISO-8859-1 and UTF-8.
- *)
- v <> "" && (v.[0] = ' ' || v.[String.length v - 1] = ' ')
-
- | (A_idrefs | A_entities | A_nmtokens) ->
- (* Split the list, and concatenate the tokens as required by
- * the normal form. Return 'true' if this operation results in
- * a different string than 'v'.
- * This check works for both ISO-8859-1 and UTF-8.
- *)
- let l = split_attribute_value lexerset v in
- let v' = String.concat " " l in
- v <> v'
-;;
-
-
-(**********************************************************************)
-
-let write_markup_string ~(from_enc:rep_encoding) ~to_enc os s =
- (* Write the 'from_enc'-encoded string 's' as 'to_enc'-encoded string to
- * 'os'. All characters are written as they are.
- *)
- let s' =
- if to_enc = (from_enc :> encoding)
- then s
- else recode_string
- ~in_enc:(from_enc :> encoding)
- ~out_enc:to_enc
- ~subst:(fun n ->
- failwith
- ("Pxp_aux.write_markup_string: Cannot represent " ^
- "code point " ^ string_of_int n))
- s
- in
- write os s' 0 (String.length s')
-;;
-
-
-let write_data_string ~(from_enc:rep_encoding) ~to_enc os content =
- (* Write the 'from_enc'-encoded string 's' as 'to_enc'-encoded string to
- * 'os'. The characters '&', '<', '>', '"', '%' and every character that
- * cannot be represented in 'to_enc' are paraphrased as entity reference
- * "&...;".
- *)
- let convert_ascii s =
- (* Convert the ASCII-encoded string 's'. Note that 'from_enc' is
- * always ASCII-compatible
- *)
- if to_enc = (from_enc :> encoding)
- then s
- else
- recode_string
- ~in_enc:(from_enc :> encoding)
- ~out_enc:to_enc
- ~subst:(fun n -> assert false)
- s
- in
-
- let write_ascii s =
- (* Write the ASCII-encoded string 's' *)
- let s' = convert_ascii s in
- write os s' 0 (String.length s')
- in
-
- let write_part j l =
- (* Writes the substring of 'content' beginning at pos 'j' with length 'l'
- *)
- if to_enc = (from_enc :> encoding) then
- write os content j l
- else begin
- let s' = recode_string
- ~in_enc:(from_enc :> encoding)
- ~out_enc:to_enc
- ~subst:(fun n ->
- convert_ascii ("&#" ^ string_of_int n ^ ";"))
- (String.sub content j l)
- in
- write os s' 0 (String.length s')
- end
- in
-
- let i = ref 0 in
- for k = 0 to String.length content - 1 do
- match content.[k] with
- ('&' | '<' | '>' | '"' | '%') as c ->
- if !i < k then
- write_part !i (k - !i);
- begin match c with
- '&' -> write_ascii "&"
- | '<' -> write_ascii "<"
- | '>' -> write_ascii ">"
- | '"' -> write_ascii """
- | '%' -> write_ascii "%" (* reserved in DTDs *)
- | _ -> assert false
- end;
- i := k+1
- | _ -> ()
- done;
- if !i < String.length content then
- write_part !i (String.length content - !i)
-;;
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:29 lpadovan
- * Initial revision
- *
- * Revision 1.6 2000/08/14 22:24:55 gerd
- * Moved the module Pxp_encoding to the netstring package under
- * the new name Netconversion.
- *
- * Revision 1.5 2000/07/25 00:30:01 gerd
- * Added support for pxp:dtd PI options.
- *
- * Revision 1.4 2000/07/16 18:31:09 gerd
- * The exception Illegal_character has been dropped.
- *
- * Revision 1.3 2000/07/16 16:33:57 gerd
- * New function write_markup_string: Handles the encoding
- * of the string.
- *
- * Revision 1.2 2000/07/08 22:15:45 gerd
- * [Merging 0.2.10:] write_data_string: The character '%' is special, too.
- *
- * 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_aux.ml:
- *
- * Revision 1.12 2000/05/27 19:08:30 gerd
- * Added functionality to check standalone declaration:
- *
- * expand_attvalue: Checks whether included entities violate the
- * stand-alone declaration.
- *
- * value_of_attribute: Checks whether ENTITY/ENTITIES values violate
- * this declaration. (Furthermore, it is checked whether the NDATA
- * entity exists - this has been forgotten in previous versions.)
- *
- * value_of_attribute/check_attribute_value_lexically: improved.
- *
- * New function normalization_changes_value: helps detecting
- * one case which violates the standalone declaration.
- *
- * Revision 1.11 2000/05/20 20:31:40 gerd
- * Big change: Added support for various encodings of the
- * internal representation.
- *
- * Revision 1.10 2000/05/01 20:41:56 gerd
- * New function write_data_string.
- *
- * Revision 1.9 2000/04/30 18:11:31 gerd
- * New function normalize_line_separators.
- * In function expand_attvalue: New argument norm_crlf. If the attvalue
- * is read directly from a file, the sequence CR LF must be converted to a
- * single space. If the attvalue is read from a replacement text, CR LF has
- * already converted to a single LF, and CR LF, if still occurring, must be
- * converted to two spaces. The caller can indicate the case by passing
- * true/false as norm_crlf.
- *
- * Revision 1.8 1999/09/01 22:51:07 gerd
- * Added functions.
- * 'character' raises Illegal_character if characters are found that
- * do not match the production Char.
- *
- * Revision 1.7 1999/09/01 16:17:37 gerd
- * Added function 'check_name'.
- *
- * Revision 1.6 1999/08/15 20:33:19 gerd
- * Added: a function that checks public identifiers. Only certain
- * characters may occur in these identifiers.
- * Control characters are rejected by the "character" function.
- * Bugfix: recursive entity references are detected in attribute
- * expansion
- *
- * Revision 1.5 1999/08/15 02:18:02 gerd
- * That '<' is not allowed in attribute values, is a violation
- * of well-formedness, not of the validity; so WF_error is raised.
- *
- * Revision 1.4 1999/08/15 00:20:37 gerd
- * When expanding attribute values, references to parameter
- * entities are now resolved by the method "replacement_text" which
- * has an additional return value, and no longer by "attlist_replacement_text".
- * The new return value indicates whether references to external entities
- * have been resolved (directly or indirectly); this is allowed at some
- * locations but not in attribute values.
- *
- * Revision 1.3 1999/08/14 22:05:53 gerd
- * Several functions 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.
- *
- * Revision 1.2 1999/08/10 21:35:06 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:50 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff