Update copyright year to 2014 by running admin/update-copyright.
[emacs.git] / lisp / nxml / rng-nxml.el
blobcf63e6f62c5e9f8d3aa889f29a8f2e832f9d75ba
1 ;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode
3 ;; Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc.
5 ;; Author: James Clark
6 ;; Keywords: XML, RelaxNG
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
27 (require 'easymenu)
28 (require 'xmltok)
29 (require 'nxml-util)
30 (require 'nxml-ns)
31 (require 'rng-match)
32 (require 'rng-util)
33 (require 'rng-valid)
34 (require 'nxml-mode)
35 (require 'rng-loc)
37 (defcustom rng-nxml-auto-validate-flag t
38 "Non-nil means automatically turn on validation with nxml-mode."
39 :type 'boolean
40 :group 'relax-ng)
42 (defcustom rng-preferred-prefix-alist
43 '(("http://www.w3.org/1999/XSL/Transform" . "xsl")
44 ("http://www.w3.org/1999/02/22-rdf-syntax-ns#" . "rdf")
45 ("http://www.w3.org/1999/xlink" . "xlink")
46 ("http://www.w3.org/2001/XmlSchema" . "xsd")
47 ("http://www.w3.org/2001/XMLSchema-instance" . "xsi")
48 ("http://purl.org/dc/elements/1.1/" . "dc")
49 ("http://purl.org/dc/terms/" . "dcterms"))
50 "Alist of namespaces vs preferred prefixes."
51 :type '(repeat (cons :tag "With"
52 (string :tag "this namespace URI")
53 (string :tag "use this prefix")))
54 :group 'relax-ng)
56 (defvar rng-complete-end-tags-after-< t
57 "Non-nil means immediately after < complete on end-tag names.
58 Complete on start-tag names regardless.")
60 (defvar rng-nxml-easy-menu
61 '("XML"
62 ["Show Outline Only" nxml-hide-all-text-content]
63 ["Show Everything" nxml-show-all]
64 "---"
65 ["Validation" rng-validate-mode
66 :style toggle
67 :selected rng-validate-mode]
68 "---"
69 ("Set Schema"
70 ["Automatically" rng-auto-set-schema]
71 ("For Document Type"
72 :filter (lambda (menu)
73 (mapcar (lambda (type-id)
74 (vector type-id
75 (list 'rng-set-document-type
76 type-id)))
77 (rng-possible-type-ids))))
78 ["Any Well-Formed XML" rng-set-vacuous-schema]
79 ["File..." rng-set-schema-file])
80 ["Show Schema Location" rng-what-schema]
81 ["Save Schema Location" rng-save-schema-location :help
82 "Save the location of the schema currently being used for this buffer"]
83 "---"
84 ["First Error" rng-first-error :active rng-validate-mode]
85 ["Next Error" rng-next-error :active rng-validate-mode]
86 "---"
87 ["Customize nXML" (customize-group 'nxml)]))
89 ;;;###autoload
90 (defun rng-nxml-mode-init ()
91 "Initialize `nxml-mode' to take advantage of `rng-validate-mode'.
92 This is typically called from `nxml-mode-hook'.
93 Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
94 (interactive)
95 (define-key nxml-mode-map "\C-c\C-v" 'rng-validate-mode)
96 (define-key nxml-mode-map "\C-c\C-s\C-w" 'rng-what-schema)
97 (define-key nxml-mode-map "\C-c\C-s\C-a" 'rng-auto-set-schema-and-validate)
98 (define-key nxml-mode-map "\C-c\C-s\C-f" 'rng-set-schema-file-and-validate)
99 (define-key nxml-mode-map "\C-c\C-s\C-l" 'rng-save-schema-location)
100 (define-key nxml-mode-map "\C-c\C-s\C-t" 'rng-set-document-type-and-validate)
101 (define-key nxml-mode-map "\C-c\C-n" 'rng-next-error)
102 (easy-menu-define rng-nxml-menu nxml-mode-map
103 "Menu for nxml-mode used with rng-validate-mode."
104 rng-nxml-easy-menu)
105 (add-to-list 'mode-line-process
106 '(rng-validate-mode (:eval (rng-compute-mode-line-string)))
107 'append)
108 (cond (rng-nxml-auto-validate-flag
109 (rng-validate-mode 1)
110 (add-hook 'nxml-completion-hook 'rng-complete nil t)
111 (add-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p nil t))
113 (rng-validate-mode 0)
114 (remove-hook 'nxml-completion-hook 'rng-complete t)
115 (remove-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p t))))
117 (defvar rng-tag-history nil)
118 (defvar rng-attribute-name-history nil)
119 (defvar rng-attribute-value-history nil)
121 (defvar rng-complete-target-names nil)
122 (defvar rng-complete-name-attribute-flag nil)
123 (defvar rng-complete-extra-strings nil)
125 (defun rng-complete ()
126 "Complete the string before point using the current schema.
127 Return non-nil if in a context it understands."
128 (interactive)
129 (and rng-validate-mode
130 (let ((lt-pos (save-excursion (search-backward "<" nil t)))
131 xmltok-dtd)
132 (and lt-pos
133 (= (rng-set-state-after lt-pos) lt-pos)
134 (or (rng-complete-tag lt-pos)
135 (rng-complete-end-tag lt-pos)
136 (rng-complete-attribute-name lt-pos)
137 (rng-complete-attribute-value lt-pos))))))
139 (defconst rng-in-start-tag-name-regex
140 (replace-regexp-in-string
142 xmltok-ncname-regexp
143 "<\\(?:w\\(?::w?\\)?\\)?\\="
147 (defun rng-complete-tag (lt-pos)
148 (let (rng-complete-extra-strings)
149 (when (and (= lt-pos (1- (point)))
150 rng-complete-end-tags-after-<
151 rng-open-elements
152 (not (eq (car rng-open-elements) t))
153 (or rng-collecting-text
154 (rng-match-save
155 (rng-match-end-tag))))
156 (setq rng-complete-extra-strings
157 (cons (concat "/"
158 (if (caar rng-open-elements)
159 (concat (caar rng-open-elements)
161 (cdar rng-open-elements))
162 (cdar rng-open-elements)))
163 rng-complete-extra-strings)))
164 (when (save-excursion
165 (re-search-backward rng-in-start-tag-name-regex
166 lt-pos
168 (and rng-collecting-text (rng-flush-text))
169 (let ((completion
170 (let ((rng-complete-target-names
171 (rng-match-possible-start-tag-names))
172 (rng-complete-name-attribute-flag nil))
173 (rng-complete-before-point (1+ lt-pos)
174 'rng-complete-qname-function
175 "Tag: "
177 'rng-tag-history)))
178 name)
179 (when completion
180 (cond ((rng-qname-p completion)
181 (setq name (rng-expand-qname completion
183 'rng-start-tag-expand-recover))
184 (when (and name
185 (rng-match-start-tag-open name)
186 (or (not (rng-match-start-tag-close))
187 ;; need a namespace decl on the root element
188 (and (car name)
189 (not rng-open-elements))))
190 ;; attributes are required
191 (insert " ")))
192 ((member completion rng-complete-extra-strings)
193 (insert ">")))))
194 t)))
196 (defconst rng-in-end-tag-name-regex
197 (replace-regexp-in-string
199 xmltok-ncname-regexp
200 "</\\(?:w\\(?::w?\\)?\\)?\\="
204 (defun rng-complete-end-tag (lt-pos)
205 (when (save-excursion
206 (re-search-backward rng-in-end-tag-name-regex
207 lt-pos
209 (cond ((or (not rng-open-elements)
210 (eq (car rng-open-elements) t))
211 (message "No matching start-tag")
212 (ding))
214 (let ((start-tag-name
215 (if (caar rng-open-elements)
216 (concat (caar rng-open-elements)
218 (cdar rng-open-elements))
219 (cdar rng-open-elements)))
220 (end-tag-name
221 (buffer-substring-no-properties (+ (match-beginning 0) 2)
222 (point))))
223 (cond ((or (> (length end-tag-name)
224 (length start-tag-name))
225 (not (string= (substring start-tag-name
227 (length end-tag-name))
228 end-tag-name)))
229 (message "Expected end-tag %s"
230 (rng-quote-string
231 (concat "</" start-tag-name ">")))
232 (ding))
234 (delete-region (- (point) (length end-tag-name))
235 (point))
236 (insert start-tag-name ">")
237 (when (not (or rng-collecting-text
238 (rng-match-end-tag)))
239 (message "Element %s is incomplete"
240 (rng-quote-string start-tag-name))))))))
243 (defconst rng-in-attribute-regex
244 (replace-regexp-in-string
246 xmltok-ncname-regexp
247 "<w\\(?::w\\)?\
248 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
249 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
250 [ \t\r\n]+\\(\\(?:w\\(?::w?\\)?\\)?\\)\\="
254 (defvar rng-undeclared-prefixes nil)
256 (defun rng-complete-attribute-name (lt-pos)
257 (when (save-excursion
258 (re-search-backward rng-in-attribute-regex lt-pos t))
259 (let ((attribute-start (match-beginning 1))
260 rng-undeclared-prefixes)
261 (and (rng-adjust-state-for-attribute lt-pos
262 attribute-start)
263 (let ((rng-complete-target-names
264 (rng-match-possible-attribute-names))
265 (rng-complete-extra-strings
266 (mapcar (lambda (prefix)
267 (if prefix
268 (concat "xmlns:" prefix)
269 "xmlns"))
270 rng-undeclared-prefixes))
271 (rng-complete-name-attribute-flag t))
272 (rng-complete-before-point attribute-start
273 'rng-complete-qname-function
274 "Attribute: "
276 'rng-attribute-name-history))
277 (insert "=\"")))
280 (defconst rng-in-attribute-value-regex
281 (replace-regexp-in-string
283 xmltok-ncname-regexp
284 "<w\\(?::w\\)?\
285 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
286 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
287 [ \t\r\n]+\\(w\\(:w\\)?\\)[ \t\r\n]*=[ \t\r\n]*\
288 \\(\"[^\"]*\\|'[^']*\\)\\="
292 (defun rng-complete-attribute-value (lt-pos)
293 (when (save-excursion
294 (re-search-backward rng-in-attribute-value-regex lt-pos t))
295 (let ((name-start (match-beginning 1))
296 (name-end (match-end 1))
297 (colon (match-beginning 2))
298 (value-start (1+ (match-beginning 3))))
299 (and (rng-adjust-state-for-attribute lt-pos
300 name-start)
301 (if (string= (buffer-substring-no-properties name-start
302 (or colon name-end))
303 "xmlns")
304 (rng-complete-before-point
305 value-start
306 (rng-strings-to-completion-alist
307 (rng-possible-namespace-uris
308 (and colon
309 (buffer-substring-no-properties (1+ colon) name-end))))
310 "Namespace URI: "
312 'rng-namespace-uri-history)
313 (rng-adjust-state-for-attribute-value name-start
314 colon
315 name-end)
316 (rng-complete-before-point
317 value-start
318 (rng-strings-to-completion-alist
319 (rng-match-possible-value-strings))
320 "Value: "
322 'rng-attribute-value-history))
323 (insert (char-before value-start))))
326 (defun rng-possible-namespace-uris (prefix)
327 (let ((ns (if prefix (nxml-ns-get-prefix prefix)
328 (nxml-ns-get-default))))
329 (if (and ns (memq prefix (nxml-ns-changed-prefixes)))
330 (list (nxml-namespace-name ns))
331 (mapcar 'nxml-namespace-name
332 (delq nxml-xml-namespace-uri
333 (rng-match-possible-namespace-uris))))))
335 (defconst rng-qname-regexp
336 (concat "\\`"
337 xmltok-ncname-regexp
338 "\\(?:" ":" xmltok-ncname-regexp "\\)" "?" "\\'"))
340 (defun rng-qname-p (string)
341 (and (string-match rng-qname-regexp string) t))
343 (defun rng-expand-qname (qname &optional defaultp recover-fun)
344 (setq qname (rng-split-qname qname))
345 (let ((prefix (car qname)))
346 (if prefix
347 (let ((ns (nxml-ns-get-prefix qname)))
348 (cond (ns (cons ns (cdr qname)))
349 (recover-fun (funcall recover-fun prefix (cdr qname)))))
350 (cons (and defaultp (nxml-ns-get-default)) (cdr qname)))))
352 (defun rng-start-tag-expand-recover (prefix local-name)
353 (let ((ns (rng-match-infer-start-tag-namespace local-name)))
354 (and ns
355 (cons ns local-name))))
357 (defun rng-split-qname (qname)
358 (if (string-match ":" qname)
359 (cons (substring qname 0 (match-beginning 0))
360 (substring qname (match-end 0)))
361 (cons nil qname)))
363 (defun rng-in-mixed-content-p ()
364 "Return non-nil if point is in mixed content.
365 Return nil only if point is definitely not in mixed content.
366 If unsure, return non-nil."
367 (if (eq rng-current-schema rng-any-element)
369 (rng-set-state-after)
370 (rng-match-mixed-text)))
372 (defun rng-set-state-after (&optional pos)
373 "Set the state for after parsing the first token with endpoint >= POS.
374 This does not change the xmltok state or point. However, it does
375 set `xmltok-dtd'. Returns the position of the end of the token."
376 (unless pos (setq pos (point)))
377 (when (< rng-validate-up-to-date-end pos)
378 (message "Parsing...")
379 (while (and (rng-do-some-validation)
380 (< rng-validate-up-to-date-end pos))
381 ;; Display percentage validated.
382 (force-mode-line-update)
383 (sit-for 0))
384 (message "Parsing...done"))
385 (save-excursion
386 (save-restriction
387 (widen)
388 (nxml-with-invisible-motion
389 (if (= pos 1)
390 (rng-set-initial-state)
391 (let ((state (get-text-property (1- pos) 'rng-state)))
392 (cond (state
393 (rng-restore-state state)
394 (goto-char pos))
396 (let ((start (previous-single-property-change pos
397 'rng-state)))
398 (cond (start
399 (rng-restore-state (get-text-property (1- start)
400 'rng-state))
401 (goto-char start))
402 (t (rng-set-initial-state))))))))
403 (xmltok-save
404 (if (= (point) 1)
405 (xmltok-forward-prolog)
406 (setq xmltok-dtd rng-dtd))
407 (cond ((and (< pos (point))
408 ;; This handles the case where the prolog ends
409 ;; with a < without any following name-start
410 ;; character. This will be treated by the parser
411 ;; as part of the prolog, but we want to treat
412 ;; it as the start of the instance.
413 (eq (char-after pos) ?<)
414 (<= (point)
415 (save-excursion
416 (goto-char (1+ pos))
417 (skip-chars-forward " \t\r\n")
418 (point))))
419 pos)
420 ((< (point) pos)
421 (let ((rng-dt-namespace-context-getter
422 '(nxml-ns-get-context))
423 (rng-parsing-for-state t))
424 (rng-forward pos))
425 (point))
426 (t pos)))))))
428 (defun rng-adjust-state-for-attribute (lt-pos start)
429 (xmltok-save
430 (save-excursion
431 (goto-char lt-pos)
432 (when (memq (xmltok-forward)
433 '(start-tag
434 partial-start-tag
435 empty-element
436 partial-empty-element))
437 (when (< start (point))
438 (setq xmltok-namespace-attributes
439 (rng-prune-attribute-at start
440 xmltok-namespace-attributes))
441 (setq xmltok-attributes
442 (rng-prune-attribute-at start
443 xmltok-attributes)))
444 (let ((rng-parsing-for-state t)
445 (rng-dt-namespace-context-getter '(nxml-ns-get-context)))
446 (rng-process-start-tag 'stop)
447 (rng-find-undeclared-prefixes)
448 t)))))
450 (defun rng-find-undeclared-prefixes ()
451 ;; Start with the newly effective namespace declarations.
452 ;; (Includes declarations added during recovery.)
453 (setq rng-undeclared-prefixes (nxml-ns-changed-prefixes))
454 (let ((iter xmltok-attributes)
455 (ns-state (nxml-ns-state))
456 att)
457 ;; Add namespace prefixes used in this tag,
458 ;; but not declared in the parent.
459 (nxml-ns-pop-state)
460 (while iter
461 (setq att (car iter))
462 (let ((prefix (xmltok-attribute-prefix att)))
463 (when (and prefix
464 (not (member prefix rng-undeclared-prefixes))
465 (not (nxml-ns-get-prefix prefix)))
466 (setq rng-undeclared-prefixes
467 (cons prefix rng-undeclared-prefixes))))
468 (setq iter (cdr iter)))
469 (nxml-ns-set-state ns-state)
470 ;; Remove namespace prefixes explicitly declared.
471 (setq iter xmltok-namespace-attributes)
472 (while iter
473 (setq att (car iter))
474 (setq rng-undeclared-prefixes
475 (delete (and (xmltok-attribute-prefix att)
476 (xmltok-attribute-local-name att))
477 rng-undeclared-prefixes))
478 (setq iter (cdr iter)))))
480 (defun rng-prune-attribute-at (start atts)
481 (when atts
482 (let ((cur atts))
483 (while (if (eq (xmltok-attribute-name-start (car cur)) start)
484 (progn
485 (setq atts (delq (car cur) atts))
486 nil)
487 (setq cur (cdr cur)))))
488 atts))
490 (defun rng-adjust-state-for-attribute-value (name-start
491 colon
492 name-end)
493 (let* ((prefix (if colon
494 (buffer-substring-no-properties name-start colon)
495 nil))
496 (local-name (buffer-substring-no-properties (if colon
497 (1+ colon)
498 name-start)
499 name-end))
500 (ns (and prefix (nxml-ns-get-prefix prefix))))
501 (and (or (not prefix) ns)
502 (rng-match-attribute-name (cons ns local-name)))))
504 (defun rng-complete-qname-function (string predicate flag)
505 (let ((alist (mapcar (lambda (name) (cons name nil))
506 (rng-generate-qname-list string))))
507 (cond ((not flag)
508 (try-completion string alist predicate))
509 ((eq flag t)
510 (all-completions string alist predicate))
511 ((eq flag 'lambda)
512 (and (assoc string alist) t)))))
514 (defun rng-generate-qname-list (&optional string)
515 (let ((forced-prefix (and string
516 (string-match ":" string)
517 (> (match-beginning 0) 0)
518 (substring string
520 (match-beginning 0))))
521 (namespaces (mapcar 'car rng-complete-target-names))
522 ns-prefixes-alist ns-prefixes iter ns prefer)
523 (while namespaces
524 (setq ns (car namespaces))
525 (when ns
526 (setq ns-prefixes-alist
527 (cons (cons ns (nxml-ns-prefixes-for
529 rng-complete-name-attribute-flag))
530 ns-prefixes-alist)))
531 (setq namespaces (delq ns (cdr namespaces))))
532 (setq iter ns-prefixes-alist)
533 (while iter
534 (setq ns-prefixes (car iter))
535 (setq ns (car ns-prefixes))
536 (when (null (cdr ns-prefixes))
537 ;; No declared prefix for the namespace
538 (if forced-prefix
539 ;; If namespace non-nil and prefix undeclared,
540 ;; use forced prefix.
541 (when (and ns
542 (not (nxml-ns-get-prefix forced-prefix)))
543 (setcdr ns-prefixes (list forced-prefix)))
544 (setq prefer (rng-get-preferred-unused-prefix ns))
545 (when prefer
546 (setcdr ns-prefixes (list prefer)))
547 ;; Unless it's an attribute with a non-nil namespace,
548 ;; allow no prefix for this namespace.
549 (unless rng-complete-name-attribute-flag
550 (setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
551 (setq iter (cdr iter)))
552 (rng-uniquify-equal
553 (sort (apply 'append
554 (cons rng-complete-extra-strings
555 (mapcar (lambda (name)
556 (if (car name)
557 (mapcar (lambda (prefix)
558 (if prefix
559 (concat prefix
561 (cdr name))
562 (cdr name)))
563 (cdr (assoc (car name)
564 ns-prefixes-alist)))
565 (list (cdr name))))
566 rng-complete-target-names)))
567 'string<))))
569 (defun rng-get-preferred-unused-prefix (ns)
570 (let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist))
571 iter prefix)
572 (when ns-prefix
573 (setq prefix (cdr ns-prefix))
574 (when (nxml-ns-get-prefix prefix)
575 ;; try to find an unused prefix
576 (setq iter (memq ns-prefix rng-preferred-prefix-alist))
577 (while (and iter
578 (setq ns-prefix (assoc ns iter)))
579 (if (nxml-ns-get-prefix (cdr ns-prefix))
580 (setq iter (memq ns-prefix iter))
581 (setq prefix (cdr ns-prefix))
582 nil))))
583 prefix))
585 (defun rng-strings-to-completion-alist (strings)
586 (mapcar (lambda (s) (cons s s))
587 (rng-uniquify-equal (sort (mapcar 'rng-escape-string strings)
588 'string<))))
590 (provide 'rng-nxml)
592 ;;; rng-nxml.el ends here