ecf08f0621
dc4e6b1329; Update copyright years in more files64b3777631; Run set-copyright from admin.el8e1c56ae46; Add 2024 to copyright years # Conflicts: # doc/misc/modus-themes.org # doc/misc/texinfo.tex # etc/NEWS # etc/refcards/ru-refcard.tex # etc/themes/modus-operandi-theme.el # etc/themes/modus-themes.el # etc/themes/modus-vivendi-theme.el # lib/alloca.in.h # lib/binary-io.h # lib/c-ctype.h # lib/c-strcasecmp.c # lib/c-strncasecmp.c # lib/careadlinkat.c # lib/cloexec.c # lib/close-stream.c # lib/diffseq.h # lib/dup2.c # lib/filemode.h # lib/fpending.c # lib/fpending.h # lib/fsusage.c # lib/getgroups.c # lib/getloadavg.c # lib/gettext.h # lib/gettime.c # lib/gettimeofday.c # lib/group-member.c # lib/malloc.c # lib/md5-stream.c # lib/md5.c # lib/md5.h # lib/memmem.c # lib/memrchr.c # lib/nanosleep.c # lib/save-cwd.h # lib/sha1.c # lib/sig2str.c # lib/stdlib.in.h # lib/strtoimax.c # lib/strtol.c # lib/strtoll.c # lib/time_r.c # lib/xalloc-oversized.h # lisp/auth-source-pass.el # lisp/emacs-lisp/lisp-mnt.el # lisp/emacs-lisp/timer.el # lisp/info-look.el # lisp/jit-lock.el # lisp/loadhist.el # lisp/mail/rmail.el # lisp/net/ntlm.el # lisp/net/webjump.el # lisp/progmodes/asm-mode.el # lisp/progmodes/project.el # lisp/progmodes/sh-script.el # lisp/textmodes/flyspell.el # lisp/textmodes/reftex-toc.el # lisp/textmodes/reftex.el # lisp/textmodes/tex-mode.el # lisp/url/url-gw.el # m4/alloca.m4 # m4/clock_time.m4 # m4/d-type.m4 # m4/dirent_h.m4 # m4/dup2.m4 # m4/euidaccess.m4 # m4/fchmodat.m4 # m4/filemode.m4 # m4/fsusage.m4 # m4/getgroups.m4 # m4/getloadavg.m4 # m4/getrandom.m4 # m4/gettime.m4 # m4/gettimeofday.m4 # m4/gnulib-common.m4 # m4/group-member.m4 # m4/inttypes.m4 # m4/malloc.m4 # m4/manywarnings.m4 # m4/mempcpy.m4 # m4/memrchr.m4 # m4/mkostemp.m4 # m4/mktime.m4 # m4/nproc.m4 # m4/nstrftime.m4 # m4/pathmax.m4 # m4/pipe2.m4 # m4/pselect.m4 # m4/pthread_sigmask.m4 # m4/readlink.m4 # m4/realloc.m4 # m4/sig2str.m4 # m4/ssize_t.m4 # m4/stat-time.m4 # m4/stddef_h.m4 # m4/stdint.m4 # m4/stdio_h.m4 # m4/stdlib_h.m4 # m4/stpcpy.m4 # m4/strnlen.m4 # m4/strtoimax.m4 # m4/strtoll.m4 # m4/time_h.m4 # m4/timegm.m4 # m4/timer_time.m4 # m4/timespec.m4 # m4/unistd_h.m4 # m4/warnings.m4 # nt/configure.bat # nt/preprep.c # test/lisp/register-tests.el
567 lines
19 KiB
EmacsLisp
567 lines
19 KiB
EmacsLisp
;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: James Clark
|
|
;; Keywords: text, hypermedia, languages, XML, RelaxNG
|
|
|
|
;; 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 of the License, 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. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(require 'xmltok)
|
|
(require 'nxml-util)
|
|
(require 'nxml-ns)
|
|
(require 'rng-match)
|
|
(require 'rng-util)
|
|
(require 'rng-valid)
|
|
(require 'nxml-mode)
|
|
(require 'rng-loc)
|
|
(require 'sgml-mode)
|
|
|
|
(defcustom rng-nxml-auto-validate-flag t
|
|
"Non-nil means automatically turn on validation with `nxml-mode'."
|
|
:type 'boolean
|
|
:group 'relax-ng)
|
|
|
|
(defcustom rng-preferred-prefix-alist
|
|
'(("http://www.w3.org/1999/XSL/Transform" . "xsl")
|
|
("http://www.w3.org/1999/02/22-rdf-syntax-ns#" . "rdf")
|
|
("http://www.w3.org/1999/xlink" . "xlink")
|
|
("http://www.w3.org/2001/XmlSchema" . "xsd")
|
|
("http://www.w3.org/2001/XMLSchema-instance" . "xsi")
|
|
("http://purl.org/dc/elements/1.1/" . "dc")
|
|
("http://purl.org/dc/terms/" . "dcterms"))
|
|
"Alist of namespaces vs preferred prefixes."
|
|
:type '(repeat (cons :tag "With"
|
|
(string :tag "this namespace URI")
|
|
(string :tag "use this prefix")))
|
|
:group 'relax-ng)
|
|
|
|
(defvar rng-complete-end-tags-after-< t
|
|
"Non-nil means immediately after < complete on end-tag names.
|
|
Complete on start-tag names regardless.")
|
|
|
|
(defvar rng-nxml-easy-menu
|
|
'("XML"
|
|
["Show Outline Only" nxml-hide-all-text-content]
|
|
["Show Everything" nxml-show-all]
|
|
"---"
|
|
["Validation" rng-validate-mode
|
|
:style toggle
|
|
:selected rng-validate-mode]
|
|
["Electric Pairs" sgml-electric-tag-pair-mode
|
|
:style toggle
|
|
:selected sgml-electric-tag-pair-mode]
|
|
"---"
|
|
("Set Schema"
|
|
["Automatically" rng-auto-set-schema]
|
|
("For Document Type"
|
|
:filter (lambda (menu)
|
|
(mapcar (lambda (type-id)
|
|
(vector type-id
|
|
(list 'rng-set-document-type
|
|
type-id)))
|
|
(rng-possible-type-ids))))
|
|
["Any Well-Formed XML" rng-set-vacuous-schema]
|
|
["File..." rng-set-schema-file])
|
|
["Show Schema Location" rng-what-schema]
|
|
["Save Schema Location" rng-save-schema-location :help
|
|
"Save the location of the schema currently being used for this buffer"]
|
|
"---"
|
|
["First Error" rng-first-error :active rng-validate-mode]
|
|
["Next Error" rng-next-error :active rng-validate-mode]
|
|
"---"
|
|
["Customize nXML" (customize-group 'nxml)]))
|
|
|
|
;;;###autoload
|
|
(defun rng-nxml-mode-init ()
|
|
"Initialize `nxml-mode' to take advantage of `rng-validate-mode'.
|
|
This is typically called from `nxml-mode-hook'.
|
|
Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
|
|
(interactive)
|
|
(define-key nxml-mode-map "\C-c\C-v" 'rng-validate-mode)
|
|
(define-key nxml-mode-map "\C-c\C-s\C-w" 'rng-what-schema)
|
|
(define-key nxml-mode-map "\C-c\C-s\C-a" 'rng-auto-set-schema-and-validate)
|
|
(define-key nxml-mode-map "\C-c\C-s\C-f" 'rng-set-schema-file-and-validate)
|
|
(define-key nxml-mode-map "\C-c\C-s\C-l" 'rng-save-schema-location)
|
|
(define-key nxml-mode-map "\C-c\C-s\C-t" 'rng-set-document-type-and-validate)
|
|
(define-key nxml-mode-map "\C-c\C-n" 'rng-next-error)
|
|
(easy-menu-define rng-nxml-menu nxml-mode-map
|
|
"Menu for nxml-mode used with rng-validate-mode."
|
|
rng-nxml-easy-menu)
|
|
(add-to-list 'mode-line-process
|
|
'(rng-validate-mode (:eval (rng-compute-mode-line-string)))
|
|
'append)
|
|
(cond (rng-nxml-auto-validate-flag
|
|
(rng-validate-mode 1)
|
|
(add-hook 'completion-at-point-functions #'rng-completion-at-point nil t)
|
|
(add-hook 'nxml-in-mixed-content-hook #'rng-in-mixed-content-p nil t))
|
|
(t
|
|
(rng-validate-mode 0)
|
|
(remove-hook 'completion-at-point-functions #'rng-completion-at-point t)
|
|
(remove-hook 'nxml-in-mixed-content-hook #'rng-in-mixed-content-p t))))
|
|
|
|
(defun rng-completion-at-point ()
|
|
"Return completion data for the string before point using the current schema."
|
|
(and rng-validate-mode
|
|
(let ((lt-pos (save-excursion (search-backward "<" nil t)))
|
|
xmltok-dtd)
|
|
(and lt-pos
|
|
(= (rng-set-state-after lt-pos) lt-pos)
|
|
(or (rng-complete-tag lt-pos)
|
|
(rng-complete-end-tag lt-pos)
|
|
(rng-complete-attribute-name lt-pos)
|
|
(rng-complete-attribute-value lt-pos))))))
|
|
|
|
(defconst rng-in-start-tag-name-regex
|
|
(replace-regexp-in-string
|
|
"w"
|
|
xmltok-ncname-regexp
|
|
"<\\(?:w\\(?::w?\\)?\\)?\\="
|
|
t
|
|
t))
|
|
|
|
(defun rng-complete-tag (lt-pos)
|
|
(let ((extra-strings
|
|
(when (and (= lt-pos (1- (point)))
|
|
rng-complete-end-tags-after-<
|
|
rng-open-elements
|
|
(not (eq (car rng-open-elements) t))
|
|
(or rng-collecting-text
|
|
(rng-match-save
|
|
(rng-match-end-tag))))
|
|
(list (concat "/"
|
|
(if (caar rng-open-elements)
|
|
(concat (caar rng-open-elements)
|
|
":"
|
|
(cdar rng-open-elements))
|
|
(cdar rng-open-elements)))))))
|
|
(when (save-excursion
|
|
(re-search-backward rng-in-start-tag-name-regex
|
|
lt-pos
|
|
t))
|
|
(and rng-collecting-text (rng-flush-text))
|
|
(let ((target-names (rng-match-possible-start-tag-names)))
|
|
`(,(1+ lt-pos)
|
|
,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
|
|
,(apply-partially #'rng-complete-qname-function
|
|
target-names nil extra-strings)
|
|
:exit-function
|
|
,(lambda (completion status)
|
|
(cond
|
|
((not (eq status 'finished)) nil)
|
|
((rng-qname-p completion)
|
|
(let ((name (rng-expand-qname completion
|
|
t
|
|
#'rng-start-tag-expand-recover)))
|
|
(when (and name
|
|
(rng-match-start-tag-open name)
|
|
(or (not (rng-match-start-tag-close))
|
|
;; need a namespace decl on the root element
|
|
(and (car name)
|
|
(not rng-open-elements))))
|
|
;; attributes are required
|
|
(insert " "))))
|
|
((member completion extra-strings)
|
|
(insert ">"))))
|
|
:company-kind ,(lambda (_) 'property))))))
|
|
|
|
(defconst rng-in-end-tag-name-regex
|
|
(replace-regexp-in-string
|
|
"w"
|
|
xmltok-ncname-regexp
|
|
"</\\(?:w\\(?::w?\\)?\\)?\\="
|
|
t
|
|
t))
|
|
|
|
(defun rng-complete-end-tag (lt-pos)
|
|
(when (save-excursion
|
|
(re-search-backward rng-in-end-tag-name-regex
|
|
lt-pos
|
|
t))
|
|
(cond ((or (not rng-open-elements)
|
|
(eq (car rng-open-elements) t))
|
|
(message "No matching start-tag")
|
|
(ding))
|
|
(t
|
|
(let ((start-tag-name
|
|
(if (caar rng-open-elements)
|
|
(concat (caar rng-open-elements)
|
|
":"
|
|
(cdar rng-open-elements))
|
|
(cdar rng-open-elements))))
|
|
`(,(+ (match-beginning 0) 2)
|
|
,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
|
|
,(list start-tag-name) ;Sole completion candidate.
|
|
:exit-function
|
|
,(lambda (_completion status)
|
|
(when (eq status 'finished)
|
|
(unless (eq (char-after) ?>) (insert ">"))
|
|
(when (not (or rng-collecting-text
|
|
(rng-match-end-tag)))
|
|
(message "Element \"%s\" is incomplete"
|
|
start-tag-name))))))))))
|
|
|
|
(defconst rng-in-attribute-regex
|
|
(replace-regexp-in-string
|
|
"w"
|
|
xmltok-ncname-regexp
|
|
"<w\\(?::w\\)?\
|
|
\\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
|
|
[ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
|
|
[ \t\r\n]+\\(\\(?:w\\(?::w?\\)?\\)?\\)\\="
|
|
t
|
|
t))
|
|
|
|
(defvar rng-undeclared-prefixes nil)
|
|
|
|
(defun rng-complete-attribute-name (lt-pos)
|
|
(when (save-excursion
|
|
(re-search-backward rng-in-attribute-regex lt-pos t))
|
|
(let ((attribute-start (match-beginning 1))
|
|
rng-undeclared-prefixes)
|
|
(and (rng-adjust-state-for-attribute lt-pos
|
|
attribute-start)
|
|
(let ((target-names
|
|
(rng-match-possible-attribute-names))
|
|
(extra-strings
|
|
(mapcar (lambda (prefix)
|
|
(if prefix
|
|
(concat "xmlns:" prefix)
|
|
"xmlns"))
|
|
rng-undeclared-prefixes)))
|
|
`(,attribute-start
|
|
,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
|
|
,(apply-partially #'rng-complete-qname-function
|
|
target-names t extra-strings)
|
|
:exit-function
|
|
,(lambda (_completion status)
|
|
(when (and (eq status 'finished)
|
|
(not (looking-at "=")))
|
|
(insert "=\"\"")
|
|
(forward-char -1)))
|
|
:company-kind ,(lambda (_) 'enum-member)))))))
|
|
|
|
(defconst rng-in-attribute-value-regex
|
|
(replace-regexp-in-string
|
|
"w"
|
|
xmltok-ncname-regexp
|
|
"<w\\(?::w\\)?\
|
|
\\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
|
|
[ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
|
|
[ \t\r\n]+\\(w\\(:w\\)?\\)[ \t\r\n]*=[ \t\r\n]*\
|
|
\\(\"[^\"]*\\|'[^']*\\)\\="
|
|
t
|
|
t))
|
|
|
|
(defun rng-complete-attribute-value (lt-pos)
|
|
(when (save-excursion
|
|
(re-search-backward rng-in-attribute-value-regex lt-pos t))
|
|
(let* ((name-start (match-beginning 1))
|
|
(name-end (match-end 1))
|
|
(colon (match-beginning 2))
|
|
(value-start (1+ (match-beginning 3)))
|
|
(exit-function
|
|
(lambda (_completion status)
|
|
(when (eq status 'finished)
|
|
(let ((delim (char-before value-start)))
|
|
(unless (eq (char-after) delim) (insert delim))))))
|
|
(kind-function (lambda (_) 'value)))
|
|
(and (rng-adjust-state-for-attribute lt-pos
|
|
name-start)
|
|
(if (string= (buffer-substring-no-properties name-start
|
|
(or colon name-end))
|
|
"xmlns")
|
|
`(,value-start ,(point)
|
|
,(rng-strings-to-completion-table
|
|
(rng-possible-namespace-uris
|
|
(and colon
|
|
(buffer-substring-no-properties (1+ colon) name-end))))
|
|
:exit-function ,exit-function
|
|
:company-kind ,kind-function)
|
|
(rng-adjust-state-for-attribute-value name-start
|
|
colon
|
|
name-end)
|
|
`(,value-start ,(point)
|
|
,(rng-strings-to-completion-table
|
|
(rng-match-possible-value-strings))
|
|
:exit-function ,exit-function
|
|
:company-kind ,kind-function))))))
|
|
|
|
(defun rng-possible-namespace-uris (prefix)
|
|
(let ((ns (if prefix (nxml-ns-get-prefix prefix)
|
|
(nxml-ns-get-default))))
|
|
(if (and ns (memq prefix (nxml-ns-changed-prefixes)))
|
|
(list (nxml-namespace-name ns))
|
|
(mapcar #'nxml-namespace-name
|
|
(delq nxml-xml-namespace-uri
|
|
(rng-match-possible-namespace-uris))))))
|
|
|
|
(defconst rng-qname-regexp
|
|
(concat "\\`"
|
|
xmltok-ncname-regexp
|
|
"\\(?:" ":" xmltok-ncname-regexp "\\)" "?" "\\'"))
|
|
|
|
(defun rng-qname-p (string)
|
|
(and (string-match rng-qname-regexp string) t))
|
|
|
|
(defun rng-expand-qname (qname &optional defaultp recover-fun)
|
|
(setq qname (rng-split-qname qname))
|
|
(let ((prefix (car qname)))
|
|
(if prefix
|
|
(let ((ns (nxml-ns-get-prefix qname)))
|
|
(cond (ns (cons ns (cdr qname)))
|
|
(recover-fun (funcall recover-fun prefix (cdr qname)))))
|
|
(cons (and defaultp (nxml-ns-get-default)) (cdr qname)))))
|
|
|
|
(defun rng-start-tag-expand-recover (_prefix local-name)
|
|
(let ((ns (rng-match-infer-start-tag-namespace local-name)))
|
|
(and ns
|
|
(cons ns local-name))))
|
|
|
|
(defun rng-split-qname (qname)
|
|
(if (string-match ":" qname)
|
|
(cons (substring qname 0 (match-beginning 0))
|
|
(substring qname (match-end 0)))
|
|
(cons nil qname)))
|
|
|
|
(defun rng-in-mixed-content-p ()
|
|
"Return non-nil if point is in mixed content.
|
|
Return nil only if point is definitely not in mixed content.
|
|
If unsure, return non-nil."
|
|
(if (eq rng-current-schema rng-any-element)
|
|
t
|
|
(rng-set-state-after)
|
|
(rng-match-mixed-text)))
|
|
|
|
(defun rng-set-state-after (&optional pos)
|
|
"Set the state for after parsing the first token with endpoint >= POS.
|
|
This does not change the xmltok state or point. However, it does
|
|
set `xmltok-dtd'. Returns the position of the end of the token."
|
|
(unless pos (setq pos (point)))
|
|
(when (< rng-validate-up-to-date-end pos)
|
|
(message "Parsing...")
|
|
(while (and (rng-do-some-validation)
|
|
(< rng-validate-up-to-date-end pos))
|
|
;; Display percentage validated.
|
|
(force-mode-line-update)
|
|
(sit-for 0))
|
|
(message "Parsing...done"))
|
|
(save-excursion
|
|
(save-restriction
|
|
(widen)
|
|
(if (= pos (point-min))
|
|
(rng-set-initial-state)
|
|
(let ((state (get-text-property (1- pos) 'rng-state)))
|
|
(cond (state
|
|
(rng-restore-state state)
|
|
(goto-char pos))
|
|
(t
|
|
(let ((start (previous-single-property-change pos
|
|
'rng-state)))
|
|
(cond (start
|
|
(rng-restore-state (get-text-property (1- start)
|
|
'rng-state))
|
|
(goto-char start))
|
|
(t (rng-set-initial-state))))))))
|
|
(xmltok-save
|
|
(if (= (point) 1)
|
|
(xmltok-forward-prolog)
|
|
(setq xmltok-dtd rng-dtd))
|
|
(cond ((and (< pos (point))
|
|
;; This handles the case where the prolog ends
|
|
;; with a < without any following name-start
|
|
;; character. This will be treated by the parser
|
|
;; as part of the prolog, but we want to treat
|
|
;; it as the start of the instance.
|
|
(eq (char-after pos) ?<)
|
|
(<= (point)
|
|
(save-excursion
|
|
(goto-char (1+ pos))
|
|
(skip-chars-forward " \t\r\n")
|
|
(point))))
|
|
pos)
|
|
((< (point) pos)
|
|
(let ((rng-dt-namespace-context-getter
|
|
'(nxml-ns-get-context))
|
|
(rng-parsing-for-state t))
|
|
(rng-forward pos))
|
|
(point))
|
|
(t pos))))))
|
|
|
|
(defun rng-adjust-state-for-attribute (lt-pos start)
|
|
(xmltok-save
|
|
(save-excursion
|
|
(goto-char lt-pos)
|
|
(when (memq (xmltok-forward)
|
|
'(start-tag
|
|
partial-start-tag
|
|
empty-element
|
|
partial-empty-element))
|
|
(when (< start (point))
|
|
(setq xmltok-namespace-attributes
|
|
(rng-prune-attribute-at start
|
|
xmltok-namespace-attributes))
|
|
(setq xmltok-attributes
|
|
(rng-prune-attribute-at start
|
|
xmltok-attributes)))
|
|
(let ((rng-parsing-for-state t)
|
|
(rng-dt-namespace-context-getter '(nxml-ns-get-context)))
|
|
(rng-process-start-tag 'stop)
|
|
(rng-find-undeclared-prefixes)
|
|
t)))))
|
|
|
|
(defun rng-find-undeclared-prefixes ()
|
|
;; Start with the newly effective namespace declarations.
|
|
;; (Includes declarations added during recovery.)
|
|
(setq rng-undeclared-prefixes (nxml-ns-changed-prefixes))
|
|
(let ((iter xmltok-attributes)
|
|
(ns-state (nxml-ns-state))
|
|
att)
|
|
;; Add namespace prefixes used in this tag,
|
|
;; but not declared in the parent.
|
|
(nxml-ns-pop-state)
|
|
(while iter
|
|
(setq att (car iter))
|
|
(let ((prefix (xmltok-attribute-prefix att)))
|
|
(when (and prefix
|
|
(not (member prefix rng-undeclared-prefixes))
|
|
(not (nxml-ns-get-prefix prefix)))
|
|
(setq rng-undeclared-prefixes
|
|
(cons prefix rng-undeclared-prefixes))))
|
|
(setq iter (cdr iter)))
|
|
(nxml-ns-set-state ns-state)
|
|
;; Remove namespace prefixes explicitly declared.
|
|
(setq iter xmltok-namespace-attributes)
|
|
(while iter
|
|
(setq att (car iter))
|
|
(setq rng-undeclared-prefixes
|
|
(delete (and (xmltok-attribute-prefix att)
|
|
(xmltok-attribute-local-name att))
|
|
rng-undeclared-prefixes))
|
|
(setq iter (cdr iter)))))
|
|
|
|
(defun rng-prune-attribute-at (start atts)
|
|
(when atts
|
|
(let ((cur atts))
|
|
(while (if (eq (xmltok-attribute-name-start (car cur)) start)
|
|
(progn
|
|
(setq atts (delq (car cur) atts))
|
|
nil)
|
|
(setq cur (cdr cur)))))
|
|
atts))
|
|
|
|
(defun rng-adjust-state-for-attribute-value (name-start
|
|
colon
|
|
name-end)
|
|
(let* ((prefix (if colon
|
|
(buffer-substring-no-properties name-start colon)
|
|
nil))
|
|
(local-name (buffer-substring-no-properties (if colon
|
|
(1+ colon)
|
|
name-start)
|
|
name-end))
|
|
(ns (and prefix (nxml-ns-get-prefix prefix))))
|
|
(and (or (not prefix) ns)
|
|
(rng-match-attribute-name (cons ns local-name)))))
|
|
|
|
(defun rng-complete-qname-function (candidates attributes-flag extra-strings
|
|
string predicate flag)
|
|
(complete-with-action flag
|
|
(rng-generate-qname-list
|
|
string candidates attributes-flag extra-strings)
|
|
string predicate))
|
|
|
|
(defun rng-generate-qname-list (&optional string candidates attribute-flag extra-strings)
|
|
(let ((forced-prefix (and string
|
|
(string-match ":" string)
|
|
(> (match-beginning 0) 0)
|
|
(substring string
|
|
0
|
|
(match-beginning 0))))
|
|
(namespaces (mapcar #'car candidates))
|
|
ns-prefixes-alist ns-prefixes iter ns prefer)
|
|
(while namespaces
|
|
(setq ns (car namespaces))
|
|
(when ns
|
|
(setq ns-prefixes-alist
|
|
(cons (cons ns (nxml-ns-prefixes-for
|
|
ns
|
|
attribute-flag))
|
|
ns-prefixes-alist)))
|
|
(setq namespaces (delq ns (cdr namespaces))))
|
|
(setq iter ns-prefixes-alist)
|
|
(while iter
|
|
(setq ns-prefixes (car iter))
|
|
(setq ns (car ns-prefixes))
|
|
(when (null (cdr ns-prefixes))
|
|
;; No declared prefix for the namespace
|
|
(if forced-prefix
|
|
;; If namespace non-nil and prefix undeclared,
|
|
;; use forced prefix.
|
|
(when (and ns
|
|
(not (nxml-ns-get-prefix forced-prefix)))
|
|
(setcdr ns-prefixes (list forced-prefix)))
|
|
(setq prefer (rng-get-preferred-unused-prefix ns))
|
|
(when prefer
|
|
(setcdr ns-prefixes (list prefer)))
|
|
;; Unless it's an attribute with a non-nil namespace,
|
|
;; allow no prefix for this namespace.
|
|
(unless attribute-flag
|
|
(setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
|
|
(setq iter (cdr iter)))
|
|
(seq-uniq
|
|
(sort (apply #'append
|
|
(cons extra-strings
|
|
(mapcar (lambda (name)
|
|
(if (car name)
|
|
(mapcar (lambda (prefix)
|
|
(if prefix
|
|
(concat prefix
|
|
":"
|
|
(cdr name))
|
|
(cdr name)))
|
|
(cdr (assoc (car name)
|
|
ns-prefixes-alist)))
|
|
(list (cdr name))))
|
|
candidates)))
|
|
'string<))))
|
|
|
|
(defun rng-get-preferred-unused-prefix (ns)
|
|
(let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist))
|
|
iter prefix)
|
|
(when ns-prefix
|
|
(setq prefix (cdr ns-prefix))
|
|
(when (nxml-ns-get-prefix prefix)
|
|
;; try to find an unused prefix
|
|
(setq iter (memq ns-prefix rng-preferred-prefix-alist))
|
|
(while (and iter
|
|
(setq ns-prefix (assoc ns iter)))
|
|
(if (nxml-ns-get-prefix (cdr ns-prefix))
|
|
(setq iter (memq ns-prefix iter))
|
|
(setq prefix (cdr ns-prefix))
|
|
nil))))
|
|
prefix))
|
|
|
|
(defun rng-strings-to-completion-table (strings)
|
|
(mapcar #'rng-escape-string strings))
|
|
|
|
(provide 'rng-nxml)
|
|
|
|
;;; rng-nxml.el ends here
|