mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-27 07:37:33 +00:00
9499da3817
Switch license to standard GPLv3+ text. (xmltok-scan-char-ref, xmltok-char-number): Use string-to-number rather than string-to-int.
1929 lines
62 KiB
EmacsLisp
1929 lines
62 KiB
EmacsLisp
;;; xmltok.el --- XML tokenization
|
|
|
|
;; Copyright (C) 2003, 2007 Free Software Foundation, Inc.
|
|
|
|
;; Author: James Clark
|
|
;; Keywords: XML
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 3, or (at your option)
|
|
;; any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; This implements an XML 1.0 parser. It also implements the XML
|
|
;; Namespaces Recommendation. It is designed to be conforming, but it
|
|
;; works a bit differently from a normal XML parser. An XML document
|
|
;; consists of the prolog and an instance. The prolog is parsed as a
|
|
;; single unit using `xmltok-forward-prolog'. The instance is
|
|
;; considered as a sequence of tokens, where a token is something like
|
|
;; a start-tag, a comment, a chunk of data or a CDATA section. The
|
|
;; tokenization of the instance is stateless: the tokenization of one
|
|
;; part of the instance does not depend on tokenization of the
|
|
;; preceding part of the instance. This allows the instance to be
|
|
;; parsed incrementally. The main entry point is `xmltok-forward':
|
|
;; this can be called at any point in the instance provided it is
|
|
;; between tokens. The other entry point is `xmltok-forward-special'
|
|
;; which skips over tokens other comments, processing instructions or
|
|
;; CDATA sections (i.e. the constructs in an instance that can contain
|
|
;; less than signs that don't start a token).
|
|
;;
|
|
;; This is a non-validating XML 1.0 processor. It does not resolve
|
|
;; parameter entities (including the external DTD subset) and it does
|
|
;; not resolve external general entities.
|
|
;;
|
|
;; It is non-conformant by design in the following respects.
|
|
;;
|
|
;; 1. It expects the client to detect aspects of well-formedness that
|
|
;; are not internal to a single token, specifically checking that
|
|
;; end-tags match start-tags and that the instance contains exactly
|
|
;; one element.
|
|
;;
|
|
;; 2. It expects the client to detect duplicate attributes. Detection
|
|
;; of duplicate attributes after expansion of namespace prefixes
|
|
;; requires the namespace processing state. Detection of duplicate
|
|
;; attributes before expansion of namespace prefixes does not, but is
|
|
;; redundant given that the client will do detection of duplicate
|
|
;; attributes after expansion of namespace prefixes.
|
|
;;
|
|
;; 3. It allows the client to recover from well-formedness errors.
|
|
;; This is essential for use in applications where the document is
|
|
;; being parsed during the editing process.
|
|
;;
|
|
;; 4. It does not support documents that do not conform to the lexical
|
|
;; requirements of the XML Namespaces Recommendation (e.g. a document
|
|
;; with a colon in an entity name).
|
|
;;
|
|
;; There are also a number of things that have not yet been
|
|
;; implemented that make it non-conformant.
|
|
;;
|
|
;; 1. It does not implement default attributes. ATTLIST declarations
|
|
;; are parsed, but no checking is done on the content of attribute
|
|
;; value literals specifying default attribute values, and default
|
|
;; attribute values are not reported to the client.
|
|
;;
|
|
;; 2. It does not implement internal entities containing elements. If
|
|
;; an internal entity is referenced and parsing its replacement text
|
|
;; yields one or more tags, then it will skip the reference and
|
|
;; report this to the client.
|
|
;;
|
|
;; 3. It does not check the syntax of public identifiers in the DTD.
|
|
;;
|
|
;; 4. It allows some non-ASCII characters in certain situations where
|
|
;; it should not. For example, it only enforces XML 1.0's
|
|
;; restrictions on name characters strictly for ASCII characters. The
|
|
;; problem here is XML's character model is based squarely on Unicode,
|
|
;; whereas Emacs's is not (as of version 21). It is not clear what
|
|
;; the right thing to do is.
|
|
|
|
;;; Code:
|
|
|
|
(defvar xmltok-type nil)
|
|
(defvar xmltok-start nil)
|
|
(defvar xmltok-name-colon nil)
|
|
(defvar xmltok-name-end nil)
|
|
(defvar xmltok-replacement nil
|
|
"String containing replacement for a character or entity reference.")
|
|
|
|
(defvar xmltok-attributes nil
|
|
"List containing attributes of last scanned element.
|
|
Each member of the list is a vector representing an attribute, which
|
|
can be accessed using the functions `xmltok-attribute-name-start',
|
|
`xmltok-attribute-name-colon', `xmltok-attribute-name-end',
|
|
`xmltok-attribute-value-start', `xmltok-attribute-value-end',
|
|
`xmltok-attribute-raw-normalized-value', `xmltok-attribute-refs'.")
|
|
|
|
(defvar xmltok-namespace-attributes nil
|
|
"List containing namespace declarations of last scanned element.
|
|
List has same format as `xmltok-attributes'.")
|
|
|
|
(defvar xmltok-dtd nil
|
|
"Information about the DTD used by `xmltok-forward'.
|
|
`xmltok-forward-prolog' sets this up.
|
|
|
|
It consists of an alist of general entity names vs definitions. The
|
|
first member of the alist is t if references to entities not in the
|
|
alist are well-formed \(e.g. because there's an external subset that
|
|
wasn't parsed).
|
|
|
|
Each general entity name is a string. The definition is either nil, a
|
|
symbol, a string, a cons cell. If the definition is nil, then it
|
|
means that it's an internal entity but the result of parsing it is
|
|
unknown. If it is a symbol, then the symbol is either `unparsed',
|
|
meaning the entity is an unparsed entity, `external', meaning the
|
|
entity is or references an external entity, `element', meaning the
|
|
entity includes one or more elements, or `not-well-formed', meaning
|
|
the replacement text is not well-formed. If the definition is a
|
|
string, then the replacement text of the entity is that string; this
|
|
happens only during the parsing of the prolog. If the definition is a
|
|
cons cell \(ER . AR), then ER specifies the string that results from
|
|
referencing the entity in element content and AR is either nil,
|
|
meaning the replacement text included a <, or a string which is the
|
|
normalized attribute value.")
|
|
|
|
(defvar xmltok-dependent-regions nil
|
|
"List of descriptors of regions that a parsed token depends on.
|
|
|
|
A token depends on a region if the region occurs after the token and a
|
|
change in the region may require the token to be reparsed. This only
|
|
happens with markup that is not well-formed. For example, if a <?
|
|
occurs without a matching ?>, then the <? is returned as a
|
|
not-well-formed token. However, this token is dependent on region
|
|
from the end of the token to the end of the buffer: if this ever
|
|
contains ?> then the buffer must be reparsed from the <?.
|
|
|
|
A region descriptor is a list (FUN START END ARG ...), where FUN is a
|
|
function to be called when the region changes, START and END are
|
|
integers giving the start and end of the region, and ARG... are
|
|
additional arguments to be passed to FUN. FUN will be called with 5
|
|
arguments followed by the additional arguments if any: the position of
|
|
the start of the changed area in the region, the position of the end
|
|
of the changed area in the region, the length of the changed area
|
|
before the change, the position of the start of the region, the
|
|
position of the end of the region. FUN must return non-nil if the
|
|
region needs reparsing. FUN will be called in a save-excursion with
|
|
match-data saved.
|
|
|
|
`xmltok-forward', `xmltok-forward-special' and `xmltok-forward-prolog'
|
|
may add entries to the beginning of this list, but will not clear it.
|
|
`xmltok-forward' and `xmltok-forward-special' will only add entries
|
|
when returning tokens of type not-well-formed.")
|
|
|
|
(defvar xmltok-errors nil
|
|
"List of errors detected by `xmltok-forward' and `xmltok-forward-prolog'.
|
|
When `xmltok-forward' and `xmltok-forward-prolog' detect a
|
|
well-formedness error, they will add an entry to the beginning of this
|
|
list. Each entry is a vector [MESSAGE START END], where MESSAGE is a
|
|
string giving the error message and START and END are integers
|
|
indicating the position of the error.")
|
|
|
|
(defmacro xmltok-save (&rest body)
|
|
`(let (xmltok-type
|
|
xmltok-start
|
|
xmltok-name-colon
|
|
xmltok-name-end
|
|
xmltok-replacement
|
|
xmltok-attributes
|
|
xmltok-namespace-attributes
|
|
xmltok-dependent-regions
|
|
xmltok-errors)
|
|
,@body))
|
|
|
|
(put 'xmltok-save 'lisp-indent-function 0)
|
|
(def-edebug-spec xmltok-save t)
|
|
|
|
(defsubst xmltok-attribute-name-start (att)
|
|
(aref att 0))
|
|
|
|
(defsubst xmltok-attribute-name-colon (att)
|
|
(aref att 1))
|
|
|
|
(defsubst xmltok-attribute-name-end (att)
|
|
(aref att 2))
|
|
|
|
(defsubst xmltok-attribute-value-start (att)
|
|
(aref att 3))
|
|
|
|
(defsubst xmltok-attribute-value-end (att)
|
|
(aref att 4))
|
|
|
|
(defsubst xmltok-attribute-raw-normalized-value (att)
|
|
"Return an object representing the normalized value of ATT.
|
|
This can t indicating that the normalized value is the same as the
|
|
buffer substring from the start to the end of the value or nil
|
|
indicating that the value is not well-formed or a string."
|
|
(aref att 5))
|
|
|
|
(defsubst xmltok-attribute-refs (att)
|
|
"Return a list of the entity and character references in ATT.
|
|
Each member is a vector [TYPE START END] where TYPE is either char-ref
|
|
or entity-ref and START and END are integers giving the start and end
|
|
of the reference. Nested entity references are not included in the list."
|
|
(aref att 6))
|
|
|
|
(defun xmltok-attribute-prefix (att)
|
|
(let ((colon (xmltok-attribute-name-colon att)))
|
|
(and colon
|
|
(buffer-substring-no-properties (xmltok-attribute-name-start att)
|
|
colon))))
|
|
|
|
(defun xmltok-attribute-local-name (att)
|
|
(let ((colon (xmltok-attribute-name-colon att)))
|
|
(buffer-substring-no-properties (if colon
|
|
(1+ colon)
|
|
(xmltok-attribute-name-start att))
|
|
(xmltok-attribute-name-end att))))
|
|
|
|
(defun xmltok-attribute-value (att)
|
|
(let ((rnv (xmltok-attribute-raw-normalized-value att)))
|
|
(and rnv
|
|
(if (stringp rnv)
|
|
rnv
|
|
(buffer-substring-no-properties (xmltok-attribute-value-start att)
|
|
(xmltok-attribute-value-end att))))))
|
|
|
|
(defun xmltok-start-tag-prefix ()
|
|
(and xmltok-name-colon
|
|
(buffer-substring-no-properties (1+ xmltok-start)
|
|
xmltok-name-colon)))
|
|
|
|
(defun xmltok-start-tag-local-name ()
|
|
(buffer-substring-no-properties (1+ (or xmltok-name-colon
|
|
xmltok-start))
|
|
xmltok-name-end))
|
|
|
|
(defun xmltok-end-tag-prefix ()
|
|
(and xmltok-name-colon
|
|
(buffer-substring-no-properties (+ 2 xmltok-start)
|
|
xmltok-name-colon)))
|
|
|
|
(defun xmltok-end-tag-local-name ()
|
|
(buffer-substring-no-properties (if xmltok-name-colon
|
|
(1+ xmltok-name-colon)
|
|
(+ 2 xmltok-start))
|
|
xmltok-name-end))
|
|
|
|
(defun xmltok-start-tag-qname ()
|
|
(buffer-substring-no-properties (+ xmltok-start 1) xmltok-name-end))
|
|
|
|
(defun xmltok-end-tag-qname ()
|
|
(buffer-substring-no-properties (+ xmltok-start 2) xmltok-name-end))
|
|
|
|
(defsubst xmltok-make-attribute (name-begin
|
|
name-colon
|
|
name-end
|
|
&optional
|
|
value-begin
|
|
value-end
|
|
raw-normalized-value)
|
|
"Make an attribute. RAW-NORMALIZED-VALUE is nil if the value is
|
|
not well-formed, t if the normalized value is the string between
|
|
VALUE-BEGIN and VALUE-END, otherwise a STRING giving the value."
|
|
(vector name-begin
|
|
name-colon
|
|
name-end
|
|
value-begin
|
|
value-end
|
|
raw-normalized-value
|
|
nil))
|
|
|
|
(defsubst xmltok-error-message (err)
|
|
(aref err 0))
|
|
|
|
(defsubst xmltok-error-start (err)
|
|
(aref err 1))
|
|
|
|
(defsubst xmltok-error-end (err)
|
|
(aref err 2))
|
|
|
|
(defsubst xmltok-make-error (message start end)
|
|
(vector message start end))
|
|
|
|
(defun xmltok-add-error (message &optional start end)
|
|
(setq xmltok-errors
|
|
(cons (xmltok-make-error message
|
|
(or start xmltok-start)
|
|
(or end (point)))
|
|
xmltok-errors)))
|
|
|
|
(defun xmltok-add-dependent (fun &optional start end &rest args)
|
|
(setq xmltok-dependent-regions
|
|
(cons (cons fun
|
|
(cons (or start xmltok-start)
|
|
(cons (or end (point-max))
|
|
args)))
|
|
xmltok-dependent-regions)))
|
|
|
|
(defun xmltok-forward ()
|
|
(setq xmltok-start (point))
|
|
(let* ((case-fold-search nil)
|
|
(space-count (skip-chars-forward " \t\r\n"))
|
|
(ch (char-after)))
|
|
(cond ((eq ch ?\<)
|
|
(cond ((> space-count 0)
|
|
(setq xmltok-type 'space))
|
|
(t
|
|
(goto-char (1+ (point)))
|
|
(xmltok-scan-after-lt))))
|
|
((eq ch ?\&)
|
|
(cond ((> space-count 0)
|
|
(setq xmltok-type 'space))
|
|
(t
|
|
(goto-char (1+ (point)))
|
|
(xmltok-scan-after-amp
|
|
(lambda (start end)
|
|
(xmltok-handle-entity start end))))))
|
|
((re-search-forward "[<&]\\|\\(]]>\\)" nil t)
|
|
(cond ((not (match-beginning 1))
|
|
(goto-char (match-beginning 0))
|
|
;; must have got a non-space char
|
|
(setq xmltok-type 'data))
|
|
((= (match-beginning 1) xmltok-start)
|
|
(xmltok-add-error "Found `]]>' not closing a CDATA section")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(goto-char (match-beginning 0))
|
|
(setq xmltok-type
|
|
(if (= (point) (+ xmltok-start space-count))
|
|
'space
|
|
'data)))))
|
|
((eq ch nil)
|
|
(setq xmltok-type
|
|
(if (> space-count 0)
|
|
'space
|
|
nil)))
|
|
(t
|
|
(goto-char (point-max))
|
|
(setq xmltok-type 'data)))))
|
|
|
|
(defun xmltok-forward-special (bound)
|
|
"Scan forward past the first special token starting at or after point.
|
|
Return nil if there is no special token that starts before BOUND.
|
|
CDATA sections, processing instructions and comments (and indeed
|
|
anything starting with < following by ? or !) count
|
|
as special. Return the type of the token."
|
|
(when (re-search-forward "<[?!]" (1+ bound) t)
|
|
(setq xmltok-start (match-beginning 0))
|
|
(goto-char (1+ xmltok-start))
|
|
(let ((case-fold-search nil))
|
|
(xmltok-scan-after-lt))))
|
|
|
|
(eval-when-compile
|
|
|
|
;; A symbolic regexp is represented by a list whose CAR is the string
|
|
;; containing the regexp and whose cdr is a list of symbolic names
|
|
;; for the groups in the string.
|
|
|
|
;; Construct a symbolic regexp from a regexp.
|
|
(defun xmltok-r (str)
|
|
(cons str nil))
|
|
|
|
;; Concatenate zero of more regexps and symbolic regexps.
|
|
(defun xmltok+ (&rest args)
|
|
(let (strs names)
|
|
(while args
|
|
(let ((arg (car args)))
|
|
(if (stringp arg)
|
|
(setq strs (cons arg strs))
|
|
(setq strs (cons (car arg) strs))
|
|
(setq names (cons (cdr arg) names)))
|
|
(setq args (cdr args))))
|
|
(cons (apply 'concat (nreverse strs))
|
|
(apply 'append (nreverse names))))))
|
|
|
|
(eval-when-compile
|
|
;; Make a symbolic group named NAME from the regexp R.
|
|
;; R may be a symbolic regexp or an ordinary regexp.
|
|
(defmacro xmltok-g (name &rest r)
|
|
(let ((sym (make-symbol "r")))
|
|
`(let ((,sym (xmltok+ ,@r)))
|
|
(if (stringp ,sym)
|
|
(cons (concat "\\(" ,sym "\\)") (cons ',name nil))
|
|
(cons (concat "\\(" (car ,sym) "\\)") (cons ',name (cdr ,sym)))))))
|
|
|
|
(defun xmltok-p (&rest r) (xmltok+ "\\(?:"
|
|
(apply 'xmltok+ r)
|
|
"\\)"))
|
|
|
|
;; Get the group index of ELEM in a LIST of symbols.
|
|
(defun xmltok-get-index (elem list)
|
|
(or elem
|
|
(error "Missing group name"))
|
|
(let ((found nil)
|
|
(i 1))
|
|
(while list
|
|
(cond ((eq elem (car list))
|
|
(setq found i)
|
|
(setq list nil))
|
|
(t
|
|
(setq i (1+ i))
|
|
(setq list (cdr list)))))
|
|
(or found
|
|
(error "Bad group name %s" elem))))
|
|
|
|
;; Define a macro SYM using a symbolic regexp R.
|
|
;; SYM can be called in three ways:
|
|
;; (SYM regexp)
|
|
;; expands to the regexp in R
|
|
;; (SYM start G)
|
|
;; expands to
|
|
;; (match-beginning N)
|
|
;; where N is the group index of G in R.
|
|
;; (SYM end G)
|
|
;; expands to
|
|
;; (match-end N)
|
|
;; where N is the group index of G in R.
|
|
(defmacro xmltok-defregexp (sym r)
|
|
`(defalias ',sym
|
|
(let ((r ,r))
|
|
`(macro lambda (action &optional group-name)
|
|
(cond ((eq action 'regexp)
|
|
,(car r))
|
|
((or (eq action 'start) (eq action 'beginning))
|
|
(list 'match-beginning (xmltok-get-index group-name
|
|
',(cdr r))))
|
|
((eq action 'end)
|
|
(list 'match-end (xmltok-get-index group-name
|
|
',(cdr r))))
|
|
((eq action 'string)
|
|
(list 'match-string
|
|
(xmltok-get-index group-name ',(cdr r))))
|
|
((eq action 'string-no-properties)
|
|
(list 'match-string-no-properties
|
|
(xmltok-get-index group-name ',(cdr r))))
|
|
(t (error "Invalid action: %s" action))))))))
|
|
|
|
|
|
(eval-when-compile
|
|
(let* ((or "\\|")
|
|
(open "\\(?:")
|
|
(gopen "\\(")
|
|
(close "\\)")
|
|
(name-start-char "[_[:alpha:]]")
|
|
(name-continue-not-start-char "[-.[:digit:]]")
|
|
(name-continue-char "[-._[:alnum:]]")
|
|
(* "*")
|
|
(+ "+")
|
|
(opt "?")
|
|
(question "\\?")
|
|
(s "[ \r\t\n]")
|
|
(s+ (concat s +))
|
|
(s* (concat s *))
|
|
(ncname (concat name-start-char name-continue-char *))
|
|
(entity-ref
|
|
(xmltok+ (xmltok-g entity-name ncname)
|
|
(xmltok-g entity-ref-close ";") opt))
|
|
(decimal-ref
|
|
(xmltok+ (xmltok-g decimal "[0-9]" +)
|
|
(xmltok-g decimal-ref-close ";") opt))
|
|
(hex-ref
|
|
(xmltok+ "x" open
|
|
(xmltok-g hex "[0-9a-fA-F]" +)
|
|
(xmltok-g hex-ref-close ";") opt
|
|
close opt))
|
|
(char-ref
|
|
(xmltok+ (xmltok-g number-sign "#")
|
|
open decimal-ref or hex-ref close opt))
|
|
(start-tag-close
|
|
(xmltok+ open (xmltok-g start-tag-close s* ">")
|
|
or open (xmltok-g empty-tag-slash s* "/")
|
|
(xmltok-g empty-tag-close ">") opt close
|
|
or (xmltok-g start-tag-s s+)
|
|
close))
|
|
(start-tag
|
|
(xmltok+ (xmltok-g start-tag-name
|
|
ncname (xmltok-g start-tag-colon ":" ncname) opt)
|
|
start-tag-close opt))
|
|
(end-tag
|
|
(xmltok+ (xmltok-g end-tag-slash "/")
|
|
open (xmltok-g end-tag-name
|
|
ncname
|
|
(xmltok-g end-tag-colon ":" ncname) opt)
|
|
(xmltok-g end-tag-close s* ">") opt
|
|
close opt))
|
|
(comment
|
|
(xmltok+ (xmltok-g markup-declaration "!")
|
|
(xmltok-g comment-first-dash "-"
|
|
(xmltok-g comment-open "-") opt) opt))
|
|
(cdata-section
|
|
(xmltok+ "!"
|
|
(xmltok-g marked-section-open "\\[")
|
|
open "C"
|
|
open "D"
|
|
open "A"
|
|
open "T"
|
|
open "A"
|
|
(xmltok-g cdata-section-open "\\[" ) opt
|
|
close opt ; A
|
|
close opt ; T
|
|
close opt ; A
|
|
close opt ; D
|
|
close opt)) ; C
|
|
(processing-instruction
|
|
(xmltok-g processing-instruction-question question)))
|
|
|
|
(xmltok-defregexp xmltok-ncname (xmltok+ open ncname close))
|
|
|
|
(xmltok-defregexp xmltok-after-amp
|
|
(xmltok+ entity-ref or char-ref))
|
|
(xmltok-defregexp xmltok-after-lt
|
|
(xmltok+ start-tag
|
|
or end-tag
|
|
;; cdata-section must come before comment
|
|
;; because we treat <! as a comment
|
|
;; and Emacs doesn't do fully greedy matching
|
|
;; by default
|
|
or cdata-section
|
|
or comment
|
|
or processing-instruction))
|
|
(xmltok-defregexp
|
|
xmltok-attribute
|
|
(let* ((lit1
|
|
(xmltok+ "'"
|
|
"[^<'&\r\n\t]*"
|
|
(xmltok-g complex1 "[&\r\n\t][^<']*") opt
|
|
"'"))
|
|
(lit2 (cons (replace-regexp-in-string "'" "\"" (car lit1))
|
|
'(complex2)))
|
|
(literal (xmltok-g literal lit1 or lit2))
|
|
(name (xmltok+ open (xmltok-g xmlns "xmlns") or ncname close
|
|
(xmltok-g colon ":" ncname) opt)))
|
|
(xmltok+ (xmltok-g name name)
|
|
s* "="
|
|
;; If the literal isn't followed by what it should be,
|
|
;; then the closing delimiter is probably really the
|
|
;; opening delimiter of another literal, so don't
|
|
;; absorb the literal in this case.
|
|
open s* literal start-tag-close close opt)))
|
|
(xmltok-defregexp
|
|
xmltok-xml-declaration
|
|
(let* ((literal-content "[-._:a-zA-Z0-9]+")
|
|
(literal
|
|
(concat open "\"" literal-content "\""
|
|
or "'" literal-content "'" close))
|
|
(version-att
|
|
(xmltok+ open
|
|
s+ (xmltok-g version-name "version")
|
|
s* "="
|
|
s* (xmltok-g version-value literal)
|
|
close opt))
|
|
(encoding-att
|
|
(xmltok+ open
|
|
s+ (xmltok-g encoding-name "encoding")
|
|
s* "="
|
|
s* (xmltok-g encoding-value literal)
|
|
close opt))
|
|
(yes-no
|
|
(concat open "yes" or "no" close))
|
|
(standalone-att
|
|
(xmltok+ open
|
|
s+ (xmltok-g standalone-name "standalone")
|
|
s* "="
|
|
s* (xmltok-g standalone-value
|
|
"\"" yes-no "\"" or "'" yes-no "'")
|
|
close opt)))
|
|
(xmltok+ "<" question "xml"
|
|
version-att
|
|
encoding-att
|
|
standalone-att
|
|
s* question ">")))
|
|
(xmltok-defregexp
|
|
xmltok-prolog
|
|
(let* ((single-char (xmltok-g single-char "[[|,(\"'>]"))
|
|
(internal-subset-close (xmltok-g internal-subset-close
|
|
"][ \t\r\n]*>"))
|
|
(starts-with-close-paren
|
|
(xmltok-g close-paren
|
|
")"
|
|
(xmltok-p
|
|
(xmltok-g close-paren-occur "[+?]")
|
|
or
|
|
(xmltok-g close-paren-star "\\*"))
|
|
opt))
|
|
(starts-with-percent
|
|
(xmltok-g percent
|
|
"%" (xmltok-g param-entity-ref
|
|
ncname
|
|
(xmltok-g param-entity-ref-close
|
|
";") opt) opt))
|
|
(starts-with-nmtoken-not-name
|
|
(xmltok-g nmtoken
|
|
(xmltok-p name-continue-not-start-char or ":")
|
|
(xmltok-p name-continue-char or ":") *))
|
|
(nmtoken-after-colon
|
|
(xmltok+
|
|
(xmltok-p name-continue-not-start-char or ":")
|
|
(xmltok-p name-continue-char or ":") *
|
|
or
|
|
name-start-char
|
|
name-continue-char *
|
|
":"
|
|
(xmltok-p name-continue-char or ":") *))
|
|
(after-ncname
|
|
(xmltok+ (xmltok-g ncname-nmtoken
|
|
":" (xmltok-p nmtoken-after-colon))
|
|
or (xmltok-p (xmltok-g colon ":" ncname)
|
|
(xmltok-g colon-name-occur "[?+*]") opt)
|
|
or (xmltok-g ncname-occur "[?+*]")
|
|
or (xmltok-g ncname-colon ":")))
|
|
(starts-with-name
|
|
(xmltok-g name ncname (xmltok-p after-ncname) opt))
|
|
(starts-with-hash
|
|
(xmltok-g pound
|
|
"#" (xmltok-g hash-name ncname)))
|
|
(markup-declaration
|
|
(xmltok-g markup-declaration
|
|
"!" (xmltok-p (xmltok-g comment-first-dash "-"
|
|
(xmltok-g comment-open "-") opt)
|
|
or (xmltok-g named-markup-declaration
|
|
ncname)) opt))
|
|
(after-lt
|
|
(xmltok+ markup-declaration
|
|
or (xmltok-g processing-instruction-question
|
|
question)
|
|
or (xmltok-g instance-start
|
|
ncname)))
|
|
(starts-with-lt (xmltok-g less-than "<" (xmltok-p after-lt) opt)))
|
|
(xmltok+ starts-with-lt
|
|
or single-char
|
|
or starts-with-close-paren
|
|
or starts-with-percent
|
|
or starts-with-name
|
|
or starts-with-nmtoken-not-name
|
|
or starts-with-hash
|
|
or internal-subset-close)))))
|
|
|
|
(defconst xmltok-ncname-regexp (xmltok-ncname regexp))
|
|
|
|
(defun xmltok-scan-after-lt ()
|
|
(cond ((not (looking-at (xmltok-after-lt regexp)))
|
|
(xmltok-add-error "`<' that is not markup must be entered as `<'")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(goto-char (match-end 0))
|
|
(cond ((xmltok-after-lt start start-tag-close)
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end start-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start start-tag-colon))
|
|
(setq xmltok-attributes nil)
|
|
(setq xmltok-namespace-attributes nil)
|
|
(setq xmltok-type 'start-tag))
|
|
((xmltok-after-lt start end-tag-close)
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end end-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start end-tag-colon))
|
|
(setq xmltok-type 'end-tag))
|
|
((xmltok-after-lt start start-tag-s)
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end start-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start start-tag-colon))
|
|
(setq xmltok-namespace-attributes nil)
|
|
(setq xmltok-attributes nil)
|
|
(xmltok-scan-attributes)
|
|
xmltok-type)
|
|
((xmltok-after-lt start empty-tag-close)
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end start-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start start-tag-colon))
|
|
(setq xmltok-attributes nil)
|
|
(setq xmltok-namespace-attributes nil)
|
|
(setq xmltok-type 'empty-element))
|
|
((xmltok-after-lt start cdata-section-open)
|
|
(setq xmltok-type
|
|
(if (search-forward "]]>" nil t)
|
|
'cdata-section
|
|
(xmltok-add-error "No closing ]]>")
|
|
(xmltok-add-dependent 'xmltok-unclosed-reparse-p
|
|
nil
|
|
nil
|
|
"]]>")
|
|
'not-well-formed)))
|
|
((xmltok-after-lt start processing-instruction-question)
|
|
(xmltok-scan-after-processing-instruction-open))
|
|
((xmltok-after-lt start comment-open)
|
|
(xmltok-scan-after-comment-open))
|
|
((xmltok-after-lt start empty-tag-slash)
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end start-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start start-tag-colon))
|
|
(setq xmltok-attributes nil)
|
|
(setq xmltok-namespace-attributes nil)
|
|
(xmltok-add-error "Expected `/>'" (1- (point)))
|
|
(setq xmltok-type 'partial-empty-element))
|
|
((xmltok-after-lt start start-tag-name)
|
|
(xmltok-add-error "Missing `>'"
|
|
nil
|
|
(1+ xmltok-start))
|
|
(setq xmltok-name-end
|
|
(xmltok-after-lt end start-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start start-tag-colon))
|
|
(setq xmltok-namespace-attributes nil)
|
|
(setq xmltok-attributes nil)
|
|
(setq xmltok-type 'partial-start-tag))
|
|
((xmltok-after-lt start end-tag-name)
|
|
(setq xmltok-name-end (xmltok-after-lt end end-tag-name))
|
|
(setq xmltok-name-colon
|
|
(xmltok-after-lt start end-tag-colon))
|
|
(cond ((and (not xmltok-name-colon)
|
|
(eq (char-after) ?:))
|
|
(goto-char (1+ (point)))
|
|
(xmltok-add-error "Expected name following `:'"
|
|
(1- (point))))
|
|
(t
|
|
(xmltok-add-error "Missing `>'"
|
|
nil
|
|
(1+ xmltok-start))))
|
|
(setq xmltok-type 'partial-end-tag))
|
|
((xmltok-after-lt start end-tag-slash)
|
|
(xmltok-add-error "Expected name following `</'")
|
|
(setq xmltok-name-end nil)
|
|
(setq xmltok-name-colon nil)
|
|
(setq xmltok-type 'partial-end-tag))
|
|
((xmltok-after-lt start marked-section-open)
|
|
(xmltok-add-error "Expected `CDATA[' after `<!['"
|
|
xmltok-start
|
|
(+ 3 xmltok-start))
|
|
(setq xmltok-type 'not-well-formed))
|
|
((xmltok-after-lt start comment-first-dash)
|
|
(xmltok-add-error "Expected `-' after `<!-'"
|
|
xmltok-start
|
|
(+ 3 xmltok-start))
|
|
(setq xmltok-type 'not-well-formed))
|
|
((xmltok-after-lt start markup-declaration)
|
|
(xmltok-add-error "Expected `[CDATA[' or `--' after `<!'"
|
|
xmltok-start
|
|
(+ 2 xmltok-start))
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(xmltok-add-error "Not well-formed")
|
|
(setq xmltok-type 'not-well-formed))))))
|
|
|
|
;; XXX This should be unified with
|
|
;; xmltok-scan-prolog-after-processing-instruction-open
|
|
;; XXX maybe should include rest of line (up to any <,>) in unclosed PI
|
|
(defun xmltok-scan-after-processing-instruction-open ()
|
|
(cond ((not (search-forward "?>" nil t))
|
|
(xmltok-add-error "No closing ?>"
|
|
xmltok-start
|
|
(+ xmltok-start 2))
|
|
(xmltok-add-dependent 'xmltok-unclosed-reparse-p
|
|
nil
|
|
nil
|
|
"?>")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(cond ((not (save-excursion
|
|
(goto-char (+ 2 xmltok-start))
|
|
(and (looking-at (xmltok-ncname regexp))
|
|
(setq xmltok-name-end (match-end 0)))))
|
|
(setq xmltok-name-end (+ xmltok-start 2))
|
|
(xmltok-add-error "<? not followed by name"
|
|
(+ xmltok-start 2)
|
|
(+ xmltok-start 3)))
|
|
((not (or (memq (char-after xmltok-name-end)
|
|
'(?\n ?\t ?\r ? ))
|
|
(= xmltok-name-end (- (point) 2))))
|
|
(xmltok-add-error "Target not followed by whitespace"
|
|
xmltok-name-end
|
|
(1+ xmltok-name-end)))
|
|
((and (= xmltok-name-end (+ xmltok-start 5))
|
|
(save-excursion
|
|
(goto-char (+ xmltok-start 2))
|
|
(let ((case-fold-search t))
|
|
(looking-at "xml"))))
|
|
(xmltok-add-error "Processing instruction target is xml"
|
|
(+ xmltok-start 2)
|
|
(+ xmltok-start 5))))
|
|
(setq xmltok-type 'processing-instruction))))
|
|
|
|
(defun xmltok-scan-after-comment-open ()
|
|
(setq xmltok-type
|
|
(cond ((not (search-forward "--" nil t))
|
|
(xmltok-add-error "No closing -->")
|
|
(xmltok-add-dependent 'xmltok-unclosed-reparse-p
|
|
nil
|
|
nil
|
|
;; not --> because
|
|
;; -- is not allowed
|
|
;; in comments in XML
|
|
"--")
|
|
'not-well-formed)
|
|
((eq (char-after) ?>)
|
|
(goto-char (1+ (point)))
|
|
'comment)
|
|
(t
|
|
(xmltok-add-dependent
|
|
'xmltok-semi-closed-reparse-p
|
|
nil
|
|
(point)
|
|
"--"
|
|
2)
|
|
;; just include the <!-- in the token
|
|
(goto-char (+ xmltok-start 4))
|
|
;; Need do this after the goto-char because
|
|
;; marked error should just apply to <!--
|
|
(xmltok-add-error "First following `--' not followed by `>'")
|
|
'not-well-formed))))
|
|
|
|
(defun xmltok-scan-attributes ()
|
|
(let ((recovering nil)
|
|
(atts-needing-normalization nil))
|
|
(while (cond ((or (looking-at (xmltok-attribute regexp))
|
|
;; use non-greedy group
|
|
(when (looking-at (concat "[^<>\n]+?"
|
|
(xmltok-attribute regexp)))
|
|
(unless recovering
|
|
(xmltok-add-error "Malformed attribute"
|
|
(point)
|
|
(save-excursion
|
|
(goto-char (xmltok-attribute start
|
|
name))
|
|
(skip-chars-backward "\r\n\t ")
|
|
(point))))
|
|
t))
|
|
(setq recovering nil)
|
|
(goto-char (match-end 0))
|
|
(let ((att (xmltok-add-attribute)))
|
|
(when att
|
|
(setq atts-needing-normalization
|
|
(cons att atts-needing-normalization))))
|
|
(cond ((xmltok-attribute start start-tag-s) t)
|
|
((xmltok-attribute start start-tag-close)
|
|
(setq xmltok-type 'start-tag)
|
|
nil)
|
|
((xmltok-attribute start empty-tag-close)
|
|
(setq xmltok-type 'empty-element)
|
|
nil)
|
|
((xmltok-attribute start empty-tag-slash)
|
|
(setq xmltok-type 'partial-empty-element)
|
|
(xmltok-add-error "Expected `/>'"
|
|
(1- (point)))
|
|
nil)
|
|
((looking-at "[ \t\r\n]*[\"']")
|
|
(goto-char (match-end 0))
|
|
(xmltok-add-error "Missing closing delimiter"
|
|
(1- (point)))
|
|
(setq recovering t)
|
|
t)
|
|
((looking-at "[ \t]*\\([^ \t\r\n\"'=<>/]+\\)[ \t\r\n/>]")
|
|
(goto-char (match-end 1))
|
|
(xmltok-add-error "Attribute value not quoted"
|
|
(match-beginning 1))
|
|
(setq recovering t)
|
|
t)
|
|
(t
|
|
(xmltok-add-error "Missing attribute value"
|
|
(1- (point)))
|
|
(setq recovering t)
|
|
t)))
|
|
((looking-at "[^<>\n]*/>")
|
|
(let ((start (point)))
|
|
(goto-char (match-end 0))
|
|
(unless recovering
|
|
(xmltok-add-error "Malformed empty-element"
|
|
start
|
|
(- (point) 2))))
|
|
(setq xmltok-type 'empty-element)
|
|
nil)
|
|
((looking-at "[^<>\n]*>")
|
|
(let ((start (point)))
|
|
(goto-char (match-end 0))
|
|
(unless recovering
|
|
(xmltok-add-error "Malformed start-tag"
|
|
start
|
|
(1- (point)))))
|
|
(setq xmltok-type 'start-tag)
|
|
nil)
|
|
(t
|
|
(when recovering
|
|
(skip-chars-forward "^<>\n"))
|
|
(xmltok-add-error "Missing `>'"
|
|
xmltok-start
|
|
(1+ xmltok-start))
|
|
(setq xmltok-type 'partial-start-tag)
|
|
nil)))
|
|
(while atts-needing-normalization
|
|
(xmltok-normalize-attribute (car atts-needing-normalization))
|
|
(setq atts-needing-normalization (cdr atts-needing-normalization))))
|
|
(setq xmltok-attributes
|
|
(nreverse xmltok-attributes))
|
|
(setq xmltok-namespace-attributes
|
|
(nreverse xmltok-namespace-attributes)))
|
|
|
|
(defun xmltok-add-attribute ()
|
|
"Return the attribute if it needs normalizing, otherwise nil."
|
|
(let* ((needs-normalizing nil)
|
|
(att
|
|
(if (xmltok-attribute start literal)
|
|
(progn
|
|
(setq needs-normalizing
|
|
(or (xmltok-attribute start complex1)
|
|
(xmltok-attribute start complex2)))
|
|
(xmltok-make-attribute (xmltok-attribute start name)
|
|
(xmltok-attribute start colon)
|
|
(xmltok-attribute end name)
|
|
(1+ (xmltok-attribute start literal))
|
|
(1- (xmltok-attribute end literal))
|
|
(not needs-normalizing)))
|
|
(xmltok-make-attribute (xmltok-attribute start name)
|
|
(xmltok-attribute start colon)
|
|
(xmltok-attribute end name)))))
|
|
(if (xmltok-attribute start xmlns)
|
|
(setq xmltok-namespace-attributes
|
|
(cons att xmltok-namespace-attributes))
|
|
(setq xmltok-attributes
|
|
(cons att xmltok-attributes)))
|
|
(and needs-normalizing
|
|
att)))
|
|
|
|
(defun xmltok-normalize-attribute (att)
|
|
(let ((end (xmltok-attribute-value-end att))
|
|
(well-formed t)
|
|
(value-parts nil)
|
|
(refs nil))
|
|
(save-excursion
|
|
(goto-char (xmltok-attribute-value-start att))
|
|
(while (progn
|
|
(let ((n (skip-chars-forward "^\r\t\n&" end)))
|
|
(when (> n 0)
|
|
(setq value-parts
|
|
(cons (buffer-substring-no-properties (- (point) n)
|
|
(point))
|
|
value-parts))))
|
|
(when (< (point) end)
|
|
(goto-char (1+ (point)))
|
|
(cond ((eq (char-before) ?\&)
|
|
(let ((xmltok-start (1- (point)))
|
|
xmltok-type xmltok-replacement)
|
|
(xmltok-scan-after-amp
|
|
(lambda (start end)
|
|
(xmltok-handle-entity start end t)))
|
|
(cond ((or (eq xmltok-type 'char-ref)
|
|
(eq xmltok-type 'entity-ref))
|
|
(setq refs
|
|
(cons (vector xmltok-type
|
|
xmltok-start
|
|
(point))
|
|
refs))
|
|
(if xmltok-replacement
|
|
(setq value-parts
|
|
(cons xmltok-replacement
|
|
value-parts))
|
|
(setq well-formed nil)))
|
|
(t (setq well-formed nil)))))
|
|
(t (setq value-parts
|
|
(cons " " value-parts)))))
|
|
(< (point) end))))
|
|
(when well-formed
|
|
(aset att 5 (apply 'concat (nreverse value-parts))))
|
|
(aset att 6 (nreverse refs))))
|
|
|
|
(defun xmltok-scan-after-amp (entity-handler)
|
|
(cond ((not (looking-at (xmltok-after-amp regexp)))
|
|
(xmltok-add-error "`&' that is not markup must be entered as `&'")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(goto-char (match-end 0))
|
|
(cond ((xmltok-after-amp start entity-ref-close)
|
|
(funcall entity-handler
|
|
(xmltok-after-amp start entity-name)
|
|
(xmltok-after-amp end entity-name))
|
|
(setq xmltok-type 'entity-ref))
|
|
((xmltok-after-amp start decimal-ref-close)
|
|
(xmltok-scan-char-ref (xmltok-after-amp start decimal)
|
|
(xmltok-after-amp end decimal)
|
|
10))
|
|
((xmltok-after-amp start hex-ref-close)
|
|
(xmltok-scan-char-ref (xmltok-after-amp start hex)
|
|
(xmltok-after-amp end hex)
|
|
16))
|
|
((xmltok-after-amp start number-sign)
|
|
(xmltok-add-error "Missing character number")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(xmltok-add-error "Missing closing `;'")
|
|
(setq xmltok-type 'not-well-formed))))))
|
|
|
|
(defconst xmltok-entity-error-messages
|
|
'((unparsed . "Referenced entity is unparsed")
|
|
(not-well-formed . "Referenced entity is not well-formed")
|
|
(external nil . "Referenced entity is external")
|
|
(element nil . "Referenced entity contains <")))
|
|
|
|
(defun xmltok-handle-entity (start end &optional attributep)
|
|
(let* ((name (buffer-substring-no-properties start end))
|
|
(name-def (assoc name xmltok-dtd))
|
|
(def (cdr name-def)))
|
|
(cond ((setq xmltok-replacement (and (consp def)
|
|
(if attributep
|
|
(cdr def)
|
|
(car def)))))
|
|
((null name-def)
|
|
(unless (eq (car xmltok-dtd) t)
|
|
(xmltok-add-error "Referenced entity has not been defined"
|
|
start
|
|
end)))
|
|
((and attributep (consp def))
|
|
(xmltok-add-error "Referenced entity contains <"
|
|
start
|
|
end))
|
|
(t
|
|
(let ((err (cdr (assq def xmltok-entity-error-messages))))
|
|
(when (consp err)
|
|
(setq err (if attributep (cdr err) (car err))))
|
|
(when err
|
|
(xmltok-add-error err start end)))))))
|
|
|
|
(defun xmltok-scan-char-ref (start end base)
|
|
(setq xmltok-replacement
|
|
(let ((n (string-to-number (buffer-substring-no-properties start end)
|
|
base)))
|
|
(cond ((and (integerp n) (xmltok-valid-char-p n))
|
|
(setq n (xmltok-unicode-to-char n))
|
|
(and n (string n)))
|
|
(t
|
|
(xmltok-add-error "Invalid character code" start end)
|
|
nil))))
|
|
(setq xmltok-type 'char-ref))
|
|
|
|
(defun xmltok-char-number (start end)
|
|
(let* ((base (if (eq (char-after (+ start 2)) ?x)
|
|
16
|
|
10))
|
|
(n (string-to-number
|
|
(buffer-substring-no-properties (+ start (if (= base 16) 3 2))
|
|
(1- end))
|
|
base)))
|
|
(and (integerp n)
|
|
(xmltok-valid-char-p n)
|
|
n)))
|
|
|
|
(defun xmltok-unclosed-reparse-p (change-start
|
|
change-end
|
|
pre-change-length
|
|
start
|
|
end
|
|
delimiter)
|
|
(let ((len-1 (1- (length delimiter))))
|
|
(goto-char (max start (- change-start len-1)))
|
|
(search-forward delimiter (min end (+ change-end len-1)) t)))
|
|
|
|
;; Handles a <!-- with the next -- not followed by >
|
|
|
|
(defun xmltok-semi-closed-reparse-p (change-start
|
|
change-end
|
|
pre-change-length
|
|
start
|
|
end
|
|
delimiter
|
|
delimiter-length)
|
|
(or (<= (- end delimiter-length) change-end)
|
|
(xmltok-unclosed-reparse-p change-start
|
|
change-end
|
|
pre-change-length
|
|
start
|
|
end
|
|
delimiter)))
|
|
|
|
(defun xmltok-valid-char-p (n)
|
|
"Return non-nil if n is the Unicode code of a valid XML character."
|
|
(cond ((< n #x20) (memq n '(#xA #xD #x9)))
|
|
((< n #xD800) t)
|
|
((< n #xE000) nil)
|
|
((< n #xFFFE) t)
|
|
(t (and (> n #xFFFF)
|
|
(< n #x110000)))))
|
|
|
|
(defun xmltok-unicode-to-char (n)
|
|
"Return the character corresponding to Unicode scalar value N.
|
|
Return nil if unsupported in Emacs."
|
|
(decode-char 'ucs n))
|
|
|
|
;;; Prolog parsing
|
|
|
|
(defvar xmltok-contains-doctype nil)
|
|
(defvar xmltok-doctype-external-subset-flag nil)
|
|
(defvar xmltok-internal-subset-start nil)
|
|
(defvar xmltok-had-param-entity-ref nil)
|
|
(defvar xmltok-prolog-regions nil)
|
|
(defvar xmltok-standalone nil
|
|
"Non-nil if there was an XML declaration specifying standalone=\"yes\",")
|
|
(defvar xmltok-markup-declaration-doctype-flag nil)
|
|
|
|
(defconst xmltok-predefined-entity-alist
|
|
'(("lt" "<" . "<")
|
|
("gt" ">" . ">")
|
|
("amp" "&" . "&")
|
|
("apos" "'" . "'")
|
|
("quot" "\"" . "\"")))
|
|
|
|
(defun xmltok-forward-prolog ()
|
|
"Move forward to the end of the XML prolog.
|
|
|
|
Returns a list of vectors [TYPE START END] where TYPE is a symbol and
|
|
START and END are integers giving the start and end of the region of
|
|
that type. TYPE can be one of xml-declaration,
|
|
xml-declaration-attribute-name, xml-declaration-attribute-value,
|
|
comment, processing-instruction-left, processing-instruction-right,
|
|
markup-declaration-open. markup-declaration-close,
|
|
internal-subset-open, internal-subset-close, hash-name, keyword,
|
|
literal, encoding-name.
|
|
Adds to `xmltok-errors' and `xmltok-dependent-regions' as appropriate."
|
|
(let ((case-fold-search nil)
|
|
xmltok-start
|
|
xmltok-type
|
|
xmltok-prolog-regions
|
|
xmltok-contains-doctype
|
|
xmltok-internal-subset-start
|
|
xmltok-had-param-entity-ref
|
|
xmltok-standalone
|
|
xmltok-doctype-external-subset-flag
|
|
xmltok-markup-declaration-doctype-flag)
|
|
(setq xmltok-dtd xmltok-predefined-entity-alist)
|
|
(xmltok-scan-xml-declaration)
|
|
(xmltok-next-prolog-token)
|
|
(while (condition-case err
|
|
(when (xmltok-parse-prolog-item)
|
|
(xmltok-next-prolog-token))
|
|
(xmltok-markup-declaration-parse-error
|
|
(xmltok-skip-markup-declaration))))
|
|
(when xmltok-internal-subset-start
|
|
(xmltok-add-error "No closing ]"
|
|
(1- xmltok-internal-subset-start)
|
|
xmltok-internal-subset-start))
|
|
(xmltok-parse-entities)
|
|
;; XXX prune dependent-regions for those entirely in prolog
|
|
(nreverse xmltok-prolog-regions)))
|
|
|
|
(defconst xmltok-bad-xml-decl-regexp
|
|
"[ \t\r\n]*<\\?xml\\(?:[ \t\r\n]\\|\\?>\\)")
|
|
|
|
;;;###autoload
|
|
(defun xmltok-get-declared-encoding-position (&optional limit)
|
|
"Return the position of the encoding in the XML declaration at point.
|
|
If there is a well-formed XML declaration starting at point and it
|
|
contains an encoding declaration, then return (START . END)
|
|
where START and END are the positions of the start and the end
|
|
of the encoding name; if there is no encoding declaration return
|
|
the position where and encoding declaration could be inserted.
|
|
If there is XML that is not well-formed that looks like an XML declaration,
|
|
return nil. Otherwise, return t.
|
|
If LIMIT is non-nil, then do not consider characters beyond LIMIT."
|
|
(cond ((let ((case-fold-search nil))
|
|
(and (looking-at (xmltok-xml-declaration regexp))
|
|
(or (not limit) (<= (match-end 0) limit))))
|
|
(let ((end (xmltok-xml-declaration end encoding-value)))
|
|
(if end
|
|
(cons (1+ (xmltok-xml-declaration start encoding-value))
|
|
(1- end))
|
|
(or (xmltok-xml-declaration end version-value)
|
|
(+ (point) 5)))))
|
|
((not (let ((case-fold-search t))
|
|
(looking-at xmltok-bad-xml-decl-regexp))))))
|
|
|
|
(defun xmltok-scan-xml-declaration ()
|
|
(when (looking-at (xmltok-xml-declaration regexp))
|
|
(xmltok-add-prolog-region 'xml-declaration (point) (match-end 0))
|
|
(goto-char (match-end 0))
|
|
(when (xmltok-xml-declaration start version-name)
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-name
|
|
(xmltok-xml-declaration start version-name)
|
|
(xmltok-xml-declaration end version-name))
|
|
(let ((start (xmltok-xml-declaration start version-value))
|
|
(end (xmltok-xml-declaration end version-value)))
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-value
|
|
start
|
|
end)))
|
|
;; XXX need to check encoding name
|
|
;; Should start with letter, not contain colon
|
|
(when (xmltok-xml-declaration start encoding-name)
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-name
|
|
(xmltok-xml-declaration start encoding-name)
|
|
(xmltok-xml-declaration end encoding-name))
|
|
(let ((start (xmltok-xml-declaration start encoding-value))
|
|
(end (xmltok-xml-declaration end encoding-value)))
|
|
(xmltok-add-prolog-region 'encoding-name
|
|
(1+ start)
|
|
(1- end))
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-value
|
|
start
|
|
end)))
|
|
(when (xmltok-xml-declaration start standalone-name)
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-name
|
|
(xmltok-xml-declaration start standalone-name)
|
|
(xmltok-xml-declaration end standalone-name))
|
|
(let ((start (xmltok-xml-declaration start standalone-value))
|
|
(end (xmltok-xml-declaration end standalone-value)))
|
|
(xmltok-add-prolog-region 'xml-declaration-attribute-value
|
|
start
|
|
end)
|
|
(setq xmltok-standalone
|
|
(string= (buffer-substring-no-properties (1+ start) (1- end))
|
|
"yes"))))
|
|
t))
|
|
|
|
(defconst xmltok-markup-declaration-alist
|
|
'(("ELEMENT" . xmltok-parse-element-declaration)
|
|
("ATTLIST" . xmltok-parse-attlist-declaration)
|
|
("ENTITY" . xmltok-parse-entity-declaration)
|
|
("NOTATION" . xmltok-parse-notation-declaration)))
|
|
|
|
(defun xmltok-parse-prolog-item ()
|
|
(cond ((eq xmltok-type 'comment)
|
|
(xmltok-add-prolog-region 'comment
|
|
xmltok-start
|
|
(point))
|
|
t)
|
|
((eq xmltok-type 'processing-instruction))
|
|
((eq xmltok-type 'named-markup-declaration)
|
|
(setq xmltok-markup-declaration-doctype-flag nil)
|
|
(xmltok-add-prolog-region 'markup-declaration-open
|
|
xmltok-start
|
|
(point))
|
|
(let* ((name (buffer-substring-no-properties
|
|
(+ xmltok-start 2)
|
|
(point)))
|
|
(fun (cdr (assoc name xmltok-markup-declaration-alist))))
|
|
(cond (fun
|
|
(unless xmltok-internal-subset-start
|
|
(xmltok-add-error
|
|
"Declaration allowed only in internal subset"))
|
|
(funcall fun))
|
|
((string= name "DOCTYPE")
|
|
(xmltok-parse-doctype))
|
|
(t
|
|
(xmltok-add-error "Unknown markup declaration"
|
|
(+ xmltok-start 2))
|
|
(xmltok-next-prolog-token)
|
|
(xmltok-markup-declaration-parse-error))))
|
|
t)
|
|
((or (eq xmltok-type 'end-prolog)
|
|
(not xmltok-type))
|
|
nil)
|
|
((eq xmltok-type 'internal-subset-close)
|
|
(xmltok-add-prolog-region 'internal-subset-close
|
|
xmltok-start
|
|
(1+ xmltok-start))
|
|
(xmltok-add-prolog-region 'markup-declaration-close
|
|
(1- (point))
|
|
(point))
|
|
(if xmltok-internal-subset-start
|
|
(setq xmltok-internal-subset-start nil)
|
|
(xmltok-add-error "]> outside internal subset"))
|
|
t)
|
|
((eq xmltok-type 'param-entity-ref)
|
|
(if xmltok-internal-subset-start
|
|
(setq xmltok-had-param-entity-ref t)
|
|
(xmltok-add-error "Parameter entity reference outside document type declaration"))
|
|
t)
|
|
;; If we don't do this, we can get thousands of errors when
|
|
;; a plain text file is parsed.
|
|
((not xmltok-internal-subset-start)
|
|
(when (let ((err (car xmltok-errors)))
|
|
(or (not err)
|
|
(<= (xmltok-error-end err) xmltok-start)))
|
|
(goto-char xmltok-start))
|
|
nil)
|
|
((eq xmltok-type 'not-well-formed) t)
|
|
(t
|
|
(xmltok-add-error "Token allowed only inside markup declaration")
|
|
t)))
|
|
|
|
(defun xmltok-parse-doctype ()
|
|
(setq xmltok-markup-declaration-doctype-flag t)
|
|
(xmltok-next-prolog-token)
|
|
(when xmltok-internal-subset-start
|
|
(xmltok-add-error "DOCTYPE declaration not allowed in internal subset")
|
|
(xmltok-markup-declaration-parse-error))
|
|
(when xmltok-contains-doctype
|
|
(xmltok-add-error "Duplicate DOCTYPE declaration")
|
|
(xmltok-markup-declaration-parse-error))
|
|
(setq xmltok-contains-doctype t)
|
|
(xmltok-require-token 'name 'prefixed-name)
|
|
(xmltok-require-next-token "SYSTEM" "PUBLIC" ?\[ ?>)
|
|
(cond ((eq xmltok-type ?\[)
|
|
(setq xmltok-internal-subset-start (point)))
|
|
((eq xmltok-type ?>))
|
|
(t
|
|
(setq xmltok-doctype-external-subset-flag t)
|
|
(xmltok-parse-external-id)
|
|
(xmltok-require-token ?\[ ?>)
|
|
(when (eq xmltok-type ?\[)
|
|
(setq xmltok-internal-subset-start (point))))))
|
|
|
|
(defun xmltok-parse-attlist-declaration ()
|
|
(xmltok-require-next-token 'prefixed-name 'name)
|
|
(while (progn
|
|
(xmltok-require-next-token ?> 'name 'prefixed-name)
|
|
(if (eq xmltok-type ?>)
|
|
nil
|
|
(xmltok-require-next-token ?\(
|
|
"CDATA"
|
|
"ID"
|
|
"IDREF"
|
|
"IDREFS"
|
|
"ENTITY"
|
|
"ENTITIES"
|
|
"NMTOKEN"
|
|
"NMTOKENS"
|
|
"NOTATION")
|
|
(cond ((eq xmltok-type ?\()
|
|
(xmltok-parse-nmtoken-group))
|
|
((string= (xmltok-current-token-string)
|
|
"NOTATION")
|
|
(xmltok-require-next-token ?\()
|
|
(xmltok-parse-nmtoken-group)))
|
|
(xmltok-require-next-token "#IMPLIED"
|
|
"#REQUIRED"
|
|
"#FIXED"
|
|
'literal)
|
|
(when (string= (xmltok-current-token-string) "#FIXED")
|
|
(xmltok-require-next-token 'literal))
|
|
t))))
|
|
|
|
(defun xmltok-parse-nmtoken-group ()
|
|
(while (progn
|
|
(xmltok-require-next-token 'nmtoken 'prefixed-name 'name)
|
|
(xmltok-require-next-token ?| ?\))
|
|
(eq xmltok-type ?|))))
|
|
|
|
(defun xmltok-parse-element-declaration ()
|
|
(xmltok-require-next-token 'name 'prefixed-name)
|
|
(xmltok-require-next-token "EMPTY" "ANY" ?\()
|
|
(when (eq xmltok-type ?\()
|
|
(xmltok-require-next-token "#PCDATA"
|
|
'name
|
|
'prefixed-name
|
|
'name-occur
|
|
?\()
|
|
(cond ((eq xmltok-type 'hash-name)
|
|
(xmltok-require-next-token ?| ?\) 'close-paren-star)
|
|
(while (eq xmltok-type ?|)
|
|
(xmltok-require-next-token 'name 'prefixed-name)
|
|
(xmltok-require-next-token 'close-paren-star ?|)))
|
|
(t (xmltok-parse-model-group))))
|
|
(xmltok-require-next-token ?>))
|
|
|
|
(defun xmltok-parse-model-group ()
|
|
(xmltok-parse-model-group-member)
|
|
(xmltok-require-next-token ?|
|
|
?,
|
|
?\)
|
|
'close-paren-star
|
|
'close-paren-occur)
|
|
(when (memq xmltok-type '(?, ?|))
|
|
(let ((connector xmltok-type))
|
|
(while (progn
|
|
(xmltok-next-prolog-token)
|
|
(xmltok-parse-model-group-member)
|
|
(xmltok-require-next-token connector
|
|
?\)
|
|
'close-paren-star
|
|
'close-paren-occur)
|
|
(eq xmltok-type connector))))))
|
|
|
|
(defun xmltok-parse-model-group-member ()
|
|
(xmltok-require-token 'name
|
|
'prefixed-name
|
|
'name-occur
|
|
?\()
|
|
(when (eq xmltok-type ?\()
|
|
(xmltok-next-prolog-token)
|
|
(xmltok-parse-model-group)))
|
|
|
|
(defun xmltok-parse-entity-declaration ()
|
|
(let (paramp name)
|
|
(xmltok-require-next-token 'name ?%)
|
|
(when (eq xmltok-type ?%)
|
|
(setq paramp t)
|
|
(xmltok-require-next-token 'name))
|
|
(setq name (xmltok-current-token-string))
|
|
(xmltok-require-next-token 'literal "SYSTEM" "PUBLIC")
|
|
(cond ((eq xmltok-type 'literal)
|
|
(let ((replacement (xmltok-parse-entity-value)))
|
|
(unless paramp
|
|
(xmltok-define-entity name replacement)))
|
|
(xmltok-require-next-token ?>))
|
|
(t
|
|
(xmltok-parse-external-id)
|
|
(if paramp
|
|
(xmltok-require-token ?>)
|
|
(xmltok-require-token ?> "NDATA")
|
|
(if (eq xmltok-type ?>)
|
|
(xmltok-define-entity name 'external)
|
|
(xmltok-require-next-token 'name)
|
|
(xmltok-require-next-token ?>)
|
|
(xmltok-define-entity name 'unparsed)))))))
|
|
|
|
(defun xmltok-define-entity (name value)
|
|
(when (and (or (not xmltok-had-param-entity-ref)
|
|
xmltok-standalone)
|
|
(not (assoc name xmltok-dtd)))
|
|
(setq xmltok-dtd
|
|
(cons (cons name value) xmltok-dtd))))
|
|
|
|
(defun xmltok-parse-entity-value ()
|
|
(let ((lim (1- (point)))
|
|
(well-formed t)
|
|
value-parts
|
|
start)
|
|
(save-excursion
|
|
(goto-char (1+ xmltok-start))
|
|
(setq start (point))
|
|
(while (progn
|
|
(skip-chars-forward "^%&" lim)
|
|
(when (< (point) lim)
|
|
(goto-char (1+ (point)))
|
|
(cond ((eq (char-before) ?%)
|
|
(xmltok-add-error "Parameter entity references are not allowed in the internal subset"
|
|
(1- (point))
|
|
(point))
|
|
(setq well-formed nil))
|
|
(t
|
|
(let ((xmltok-start (1- (point)))
|
|
xmltok-type xmltok-replacement)
|
|
(xmltok-scan-after-amp (lambda (start end)))
|
|
(cond ((eq xmltok-type 'char-ref)
|
|
(setq value-parts
|
|
(cons (buffer-substring-no-properties
|
|
start
|
|
xmltok-start)
|
|
value-parts))
|
|
(setq value-parts
|
|
(cons xmltok-replacement
|
|
value-parts))
|
|
(setq start (point)))
|
|
((eq xmltok-type 'not-well-formed)
|
|
(setq well-formed nil))))))
|
|
t))))
|
|
(if (not well-formed)
|
|
nil
|
|
(apply 'concat
|
|
(nreverse (cons (buffer-substring-no-properties start lim)
|
|
value-parts))))))
|
|
|
|
(defun xmltok-parse-notation-declaration ()
|
|
(xmltok-require-next-token 'name)
|
|
(xmltok-require-next-token "SYSTEM" "PUBLIC")
|
|
(let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
|
|
(xmltok-require-next-token 'literal)
|
|
(cond (publicp
|
|
(xmltok-require-next-token 'literal ?>)
|
|
(unless (eq xmltok-type ?>)
|
|
(xmltok-require-next-token ?>)))
|
|
(t (xmltok-require-next-token ?>)))))
|
|
|
|
(defun xmltok-parse-external-id ()
|
|
(xmltok-require-token "SYSTEM" "PUBLIC")
|
|
(let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
|
|
(xmltok-require-next-token 'literal)
|
|
(when publicp
|
|
(xmltok-require-next-token 'literal)))
|
|
(xmltok-next-prolog-token))
|
|
|
|
(defun xmltok-require-next-token (&rest types)
|
|
(xmltok-next-prolog-token)
|
|
(apply 'xmltok-require-token types))
|
|
|
|
(defun xmltok-require-token (&rest types)
|
|
;; XXX Generate a more helpful error message
|
|
(while (and (not (let ((type (car types)))
|
|
(if (stringp (car types))
|
|
(string= (xmltok-current-token-string) type)
|
|
(eq type xmltok-type))))
|
|
(setq types (cdr types))))
|
|
(unless types
|
|
(when (and xmltok-type
|
|
(not (eq xmltok-type 'not-well-formed)))
|
|
(xmltok-add-error "Unexpected token"))
|
|
(xmltok-markup-declaration-parse-error))
|
|
(let ((region-type (xmltok-prolog-region-type (car types))))
|
|
(when region-type
|
|
(xmltok-add-prolog-region region-type
|
|
xmltok-start
|
|
(point)))))
|
|
|
|
(defun xmltok-current-token-string ()
|
|
(buffer-substring-no-properties xmltok-start (point)))
|
|
|
|
(put 'xmltok-markup-declaration-parse-error
|
|
'error-conditions
|
|
'(error xmltok-markup-declaration-parse-error))
|
|
|
|
(put 'xmltok-markup-declaration-parse-error
|
|
'error-message
|
|
"Syntax error in markup declaration")
|
|
|
|
(defun xmltok-markup-declaration-parse-error ()
|
|
(signal 'xmltok-markup-declaration-parse-error nil))
|
|
|
|
(defun xmltok-skip-markup-declaration ()
|
|
(while (cond ((eq xmltok-type ?>)
|
|
(xmltok-next-prolog-token)
|
|
nil)
|
|
((and xmltok-markup-declaration-doctype-flag
|
|
(eq xmltok-type ?\[))
|
|
(setq xmltok-internal-subset-start (point))
|
|
(xmltok-next-prolog-token)
|
|
nil)
|
|
((memq xmltok-type '(nil
|
|
end-prolog
|
|
named-markup-declaration
|
|
comment
|
|
processing-instruction))
|
|
nil)
|
|
((and xmltok-internal-subset-start
|
|
(eq xmltok-type 'internal-subset-close))
|
|
nil)
|
|
(t (xmltok-next-prolog-token) t)))
|
|
xmltok-type)
|
|
|
|
(defun xmltok-prolog-region-type (required)
|
|
(cond ((cdr (assq xmltok-type
|
|
'((literal . literal)
|
|
(?> . markup-declaration-close)
|
|
(?\[ . internal-subset-open)
|
|
(hash-name . hash-name)))))
|
|
((and (stringp required) (eq xmltok-type 'name))
|
|
'keyword)))
|
|
|
|
;; Return new token type.
|
|
|
|
(defun xmltok-next-prolog-token ()
|
|
(skip-chars-forward " \t\r\n")
|
|
(setq xmltok-start (point))
|
|
(cond ((not (and (looking-at (xmltok-prolog regexp))
|
|
(goto-char (match-end 0))))
|
|
(let ((ch (char-after)))
|
|
(cond (ch
|
|
(goto-char (1+ (point)))
|
|
(xmltok-add-error "Illegal char in prolog")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t (setq xmltok-type nil)))))
|
|
((or (xmltok-prolog start ncname-occur)
|
|
(xmltok-prolog start colon-name-occur))
|
|
(setq xmltok-name-end (1- (point)))
|
|
(setq xmltok-name-colon (xmltok-prolog start colon))
|
|
(setq xmltok-type 'name-occur))
|
|
((xmltok-prolog start colon)
|
|
(setq xmltok-name-end (point))
|
|
(setq xmltok-name-colon (xmltok-prolog start colon))
|
|
(unless (looking-at "[ \t\r\n>),|[%]")
|
|
(xmltok-add-error "Missing space after name"))
|
|
(setq xmltok-type 'prefixed-name))
|
|
((or (xmltok-prolog start ncname-nmtoken)
|
|
(xmltok-prolog start ncname-colon))
|
|
(unless (looking-at "[ \t\r\n>),|[%]")
|
|
(xmltok-add-error "Missing space after name token"))
|
|
(setq xmltok-type 'nmtoken))
|
|
((xmltok-prolog start name)
|
|
(setq xmltok-name-end (point))
|
|
(setq xmltok-name-colon nil)
|
|
(unless (looking-at "[ \t\r\n>),|[%]")
|
|
(xmltok-add-error "Missing space after name"))
|
|
(setq xmltok-type 'name))
|
|
((xmltok-prolog start hash-name)
|
|
(setq xmltok-name-end (point))
|
|
(unless (looking-at "[ \t\r\n>)|%]")
|
|
(xmltok-add-error "Missing space after name"))
|
|
(setq xmltok-type 'hash-name))
|
|
((xmltok-prolog start processing-instruction-question)
|
|
(xmltok-scan-prolog-after-processing-instruction-open))
|
|
((xmltok-prolog start comment-open)
|
|
;; XXX if not-well-formed, ignore some stuff
|
|
(xmltok-scan-after-comment-open))
|
|
((xmltok-prolog start named-markup-declaration)
|
|
(setq xmltok-type 'named-markup-declaration))
|
|
((xmltok-prolog start instance-start)
|
|
(goto-char xmltok-start)
|
|
(setq xmltok-type 'end-prolog))
|
|
((xmltok-prolog start close-paren-star)
|
|
(setq xmltok-type 'close-paren-star))
|
|
((xmltok-prolog start close-paren-occur)
|
|
(setq xmltok-type 'close-paren-occur))
|
|
((xmltok-prolog start close-paren)
|
|
(unless (looking-at "[ \t\r\n>,|)]")
|
|
(xmltok-add-error "Missing space after )"))
|
|
(setq xmltok-type ?\)))
|
|
((xmltok-prolog start single-char)
|
|
(let ((ch (char-before)))
|
|
(cond ((memq ch '(?\" ?\'))
|
|
(xmltok-scan-prolog-literal))
|
|
(t (setq xmltok-type ch)))))
|
|
((xmltok-prolog start percent)
|
|
(cond ((xmltok-prolog start param-entity-ref-close)
|
|
(setq xmltok-name-end (1- (point)))
|
|
(setq xmltok-type 'param-entity-ref))
|
|
((xmltok-prolog start param-entity-ref)
|
|
(xmltok-add-error "Missing ;")
|
|
(setq xmltok-name-end (point))
|
|
(setq xmltok-type 'param-entity-ref))
|
|
((looking-at "[ \t\r\n%]")
|
|
(setq xmltok-type ?%))
|
|
(t
|
|
(xmltok-add-error "Expected name after %")
|
|
(setq xmltok-type 'not-well-formed))))
|
|
((xmltok-prolog start nmtoken)
|
|
(unless (looking-at "[ \t\r\n>),|[%]")
|
|
(xmltok-add-error "Missing space after name token"))
|
|
(setq xmltok-type 'nmtoken))
|
|
((xmltok-prolog start internal-subset-close)
|
|
(setq xmltok-type 'internal-subset-close))
|
|
((xmltok-prolog start pound)
|
|
(xmltok-add-error "Expected name after #")
|
|
(setq xmltok-type 'not-well-formed))
|
|
((xmltok-prolog start markup-declaration)
|
|
(xmltok-add-error "Expected name or -- after <!")
|
|
(setq xmltok-type 'not-well-formed))
|
|
((xmltok-prolog start comment-first-dash)
|
|
(xmltok-add-error "Expected <!--")
|
|
(setq xmltok-type 'not-well-formed))
|
|
((xmltok-prolog start less-than)
|
|
(xmltok-add-error "Incomplete markup")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t (error "Unhandled token in prolog %s"
|
|
(match-string-no-properties 0)))))
|
|
|
|
(defun xmltok-scan-prolog-literal ()
|
|
(let* ((delim (string (char-before)))
|
|
(safe-end (save-excursion
|
|
(skip-chars-forward (concat "^<>[]" delim))
|
|
(point)))
|
|
(end (save-excursion
|
|
(goto-char safe-end)
|
|
(search-forward delim nil t))))
|
|
(or (cond ((not end)
|
|
(xmltok-add-dependent 'xmltok-unclosed-reparse-p
|
|
nil
|
|
nil
|
|
delim)
|
|
nil)
|
|
((save-excursion
|
|
(goto-char end)
|
|
(looking-at "[ \t\r\n>%[]"))
|
|
(goto-char end)
|
|
(setq xmltok-type 'literal))
|
|
((eq (1+ safe-end) end)
|
|
(goto-char end)
|
|
(xmltok-add-error (format "Missing space after %s" delim)
|
|
safe-end)
|
|
(setq xmltok-type 'literal))
|
|
(t
|
|
(xmltok-add-dependent 'xmltok-semi-closed-reparse-p
|
|
xmltok-start
|
|
(1+ end)
|
|
delim
|
|
1)
|
|
nil))
|
|
(progn
|
|
(xmltok-add-error (format "Missing closing %s" delim))
|
|
(goto-char safe-end)
|
|
(skip-chars-backward " \t\r\n")
|
|
(setq xmltok-type 'not-well-formed)))))
|
|
|
|
(defun xmltok-scan-prolog-after-processing-instruction-open ()
|
|
(cond ((not (search-forward "?>" nil t))
|
|
(xmltok-add-error "No closing ?>"
|
|
xmltok-start
|
|
(+ xmltok-start 2))
|
|
(xmltok-add-dependent 'xmltok-unclosed-reparse-p
|
|
nil
|
|
nil
|
|
"?>")
|
|
(setq xmltok-type 'not-well-formed))
|
|
(t
|
|
(let* ((end (point))
|
|
(target
|
|
(save-excursion
|
|
(goto-char (+ xmltok-start 2))
|
|
(and (looking-at (xmltok-ncname regexp))
|
|
(or (memq (char-after (match-end 0))
|
|
'(?\n ?\t ?\r ? ))
|
|
(= (match-end 0) (- end 2)))
|
|
(match-string-no-properties 0)))))
|
|
(cond ((not target)
|
|
(xmltok-add-error "\
|
|
Processing instruction does not start with a name"
|
|
(+ xmltok-start 2)
|
|
(+ xmltok-start 3)))
|
|
((not (and (= (length target) 3)
|
|
(let ((case-fold-search t))
|
|
(string-match "xml" target)))))
|
|
((= xmltok-start 1)
|
|
(xmltok-add-error "Invalid XML declaration"
|
|
xmltok-start
|
|
(point)))
|
|
((save-excursion
|
|
(goto-char xmltok-start)
|
|
(looking-at (xmltok-xml-declaration regexp)))
|
|
(xmltok-add-error "XML declaration not at beginning of file"
|
|
xmltok-start
|
|
(point)))
|
|
(t
|
|
(xmltok-add-error "Processing instruction has target of xml"
|
|
(+ xmltok-start 2)
|
|
(+ xmltok-start 5))))
|
|
(xmltok-add-prolog-region 'processing-instruction-left
|
|
xmltok-start
|
|
(+ xmltok-start
|
|
2
|
|
(if target
|
|
(length target)
|
|
0)))
|
|
(xmltok-add-prolog-region 'processing-instruction-right
|
|
(if target
|
|
(save-excursion
|
|
(goto-char (+ xmltok-start
|
|
(length target)
|
|
2))
|
|
(skip-chars-forward " \t\r\n")
|
|
(point))
|
|
(+ xmltok-start 2))
|
|
(point)))
|
|
(setq xmltok-type 'processing-instruction))))
|
|
|
|
(defun xmltok-parse-entities ()
|
|
(let ((todo xmltok-dtd))
|
|
(when (and (or xmltok-had-param-entity-ref
|
|
xmltok-doctype-external-subset-flag)
|
|
(not xmltok-standalone))
|
|
(setq xmltok-dtd (cons t xmltok-dtd)))
|
|
(while todo
|
|
(xmltok-parse-entity (car todo))
|
|
(setq todo (cdr todo)))))
|
|
|
|
(defun xmltok-parse-entity (name-def)
|
|
(let ((def (cdr name-def))
|
|
;; in case its value is buffer local
|
|
(xmltok-dtd xmltok-dtd)
|
|
buf)
|
|
(when (stringp def)
|
|
(if (string-match "\\`[^&<\t\r\n]*\\'" def)
|
|
(setcdr name-def (cons def def))
|
|
(setcdr name-def 'not-well-formed) ; avoid infinite expansion loops
|
|
(setq buf (get-buffer-create
|
|
(format " *Entity %s*" (car name-def))))
|
|
(save-excursion
|
|
(set-buffer buf)
|
|
(erase-buffer)
|
|
(insert def)
|
|
(goto-char (point-min))
|
|
(setcdr name-def
|
|
(xmltok-parse-entity-replacement)))
|
|
(kill-buffer buf)))))
|
|
|
|
(defun xmltok-parse-entity-replacement ()
|
|
(let ((def (cons "" "")))
|
|
(while (let* ((start (point))
|
|
(found (re-search-forward "[<&\t\r\n]\\|]]>" nil t))
|
|
(ch (and found (char-before)))
|
|
(str (buffer-substring-no-properties
|
|
start
|
|
(if found
|
|
(match-beginning 0)
|
|
(point-max)))))
|
|
(setq def
|
|
(xmltok-append-entity-def def
|
|
(cons str str)))
|
|
(cond ((not found) nil)
|
|
((eq ch ?>)
|
|
(setq def 'not-well-formed)
|
|
nil)
|
|
((eq ch ?<)
|
|
(xmltok-save
|
|
(setq xmltok-start (1- (point)))
|
|
(xmltok-scan-after-lt)
|
|
(setq def
|
|
(xmltok-append-entity-def
|
|
def
|
|
(cond ((memq xmltok-type
|
|
'(start-tag
|
|
end-tag
|
|
empty-element))
|
|
'element)
|
|
((memq xmltok-type
|
|
'(comment
|
|
processing-instruction))
|
|
(cons "" nil))
|
|
((eq xmltok-type
|
|
'cdata-section)
|
|
(cons (buffer-substring-no-properties
|
|
(+ xmltok-start 9)
|
|
(- (point) 3))
|
|
nil))
|
|
(t 'not-well-formed)))))
|
|
t)
|
|
((eq ch ?&)
|
|
(let ((xmltok-start (1- (point)))
|
|
xmltok-type
|
|
xmltok-replacement
|
|
xmltok-errors)
|
|
(xmltok-scan-after-amp 'xmltok-handle-nested-entity)
|
|
(cond ((eq xmltok-type 'entity-ref)
|
|
(setq def
|
|
(xmltok-append-entity-def
|
|
def
|
|
xmltok-replacement)))
|
|
((eq xmltok-type 'char-ref)
|
|
(setq def
|
|
(xmltok-append-entity-def
|
|
def
|
|
(if xmltok-replacement
|
|
(cons xmltok-replacement
|
|
xmltok-replacement)
|
|
(and xmltok-errors 'not-well-formed)))))
|
|
(t
|
|
(setq def 'not-well-formed))))
|
|
t)
|
|
(t
|
|
(setq def
|
|
(xmltok-append-entity-def
|
|
def
|
|
(cons (match-string-no-properties 0)
|
|
" ")))
|
|
t))))
|
|
def))
|
|
|
|
(defun xmltok-handle-nested-entity (start end)
|
|
(let* ((name-def (assoc (buffer-substring-no-properties start end)
|
|
xmltok-dtd))
|
|
(def (cdr name-def)))
|
|
(when (stringp def)
|
|
(xmltok-parse-entity name-def)
|
|
(setq def (cdr name-def)))
|
|
(setq xmltok-replacement
|
|
(cond ((null name-def)
|
|
(if (eq (car xmltok-dtd) t)
|
|
nil
|
|
'not-well-formed))
|
|
((eq def 'unparsed) 'not-well-formed)
|
|
(t def)))))
|
|
|
|
(defun xmltok-append-entity-def (d1 d2)
|
|
(cond ((consp d1)
|
|
(if (consp d2)
|
|
(cons (concat (car d1) (car d2))
|
|
(and (cdr d1)
|
|
(cdr d2)
|
|
(concat (cdr d1) (cdr d2))))
|
|
d2))
|
|
((consp d2) d1)
|
|
(t
|
|
(let ((defs '(not-well-formed external element)))
|
|
(while (not (or (eq (car defs) d1)
|
|
(eq (car defs) d2)))
|
|
(setq defs (cdr defs)))
|
|
(car defs)))))
|
|
|
|
(defun xmltok-add-prolog-region (type start end)
|
|
(setq xmltok-prolog-regions
|
|
(cons (vector type start end)
|
|
xmltok-prolog-regions)))
|
|
|
|
(defun xmltok-merge-attributes ()
|
|
"Return a list merging `xmltok-attributes' and 'xmltok-namespace-attributes'.
|
|
The members of the merged list are in order of occurrence in the
|
|
document. The list may share list structure with `xmltok-attributes'
|
|
and `xmltok-namespace-attributes'."
|
|
(cond ((not xmltok-namespace-attributes)
|
|
xmltok-attributes)
|
|
((not xmltok-attributes)
|
|
xmltok-namespace-attributes)
|
|
(t
|
|
(let ((atts1 xmltok-attributes)
|
|
(atts2 xmltok-namespace-attributes)
|
|
merged)
|
|
(while (and atts1 atts2)
|
|
(cond ((< (xmltok-attribute-name-start (car atts1))
|
|
(xmltok-attribute-name-start (car atts2)))
|
|
(setq merged (cons (car atts1) merged))
|
|
(setq atts1 (cdr atts1)))
|
|
(t
|
|
(setq merged (cons (car atts2) merged))
|
|
(setq atts2 (cdr atts2)))))
|
|
(setq merged (nreverse merged))
|
|
(cond (atts1 (setq merged (nconc merged atts1)))
|
|
(atts2 (setq merged (nconc merged atts2))))
|
|
merged))))
|
|
|
|
;;; Testing
|
|
|
|
(defun xmltok-forward-test ()
|
|
(interactive)
|
|
(if (xmltok-forward)
|
|
(message "Scanned %s" xmltok-type)
|
|
(message "Scanned nothing")))
|
|
|
|
(defun xmltok-next-prolog-token-test ()
|
|
(interactive)
|
|
(if (xmltok-next-prolog-token)
|
|
(message "Scanned %s"
|
|
(if (integerp xmltok-type)
|
|
(string xmltok-type)
|
|
xmltok-type))
|
|
(message "Scanned end of file")))
|
|
|
|
(provide 'xmltok)
|
|
|
|
;; arch-tag: 747e5f3a-6fc3-4f8d-bd96-89f05aa99f5e
|
|
;;; xmltok.el ends here
|