* lisp/mail/rmail.el (rmail-show-message-1): Use restore-buffer-modified-p.
[emacs.git] / lisp / nxml / rng-nxml.el
blob1686ebfc5143cc5063a1d22bd67995a89cca1dcf
1 ;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode
3 ;; Copyright (C) 2003, 2007-2011 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 ;; Force redisplay but don't allow idle timers to run.
384 (let ((timer-idle-list nil))
385 (sit-for 0)))
386 (message "Parsing...done"))
387 (save-excursion
388 (save-restriction
389 (widen)
390 (nxml-with-invisible-motion
391 (if (= pos 1)
392 (rng-set-initial-state)
393 (let ((state (get-text-property (1- pos) 'rng-state)))
394 (cond (state
395 (rng-restore-state state)
396 (goto-char pos))
398 (let ((start (previous-single-property-change pos
399 'rng-state)))
400 (cond (start
401 (rng-restore-state (get-text-property (1- start)
402 'rng-state))
403 (goto-char start))
404 (t (rng-set-initial-state))))))))
405 (xmltok-save
406 (if (= (point) 1)
407 (xmltok-forward-prolog)
408 (setq xmltok-dtd rng-dtd))
409 (cond ((and (< pos (point))
410 ;; This handles the case where the prolog ends
411 ;; with a < without any following name-start
412 ;; character. This will be treated by the parser
413 ;; as part of the prolog, but we want to treat
414 ;; it as the start of the instance.
415 (eq (char-after pos) ?<)
416 (<= (point)
417 (save-excursion
418 (goto-char (1+ pos))
419 (skip-chars-forward " \t\r\n")
420 (point))))
421 pos)
422 ((< (point) pos)
423 (let ((rng-dt-namespace-context-getter
424 '(nxml-ns-get-context))
425 (rng-parsing-for-state t))
426 (rng-forward pos))
427 (point))
428 (t pos)))))))
430 (defun rng-adjust-state-for-attribute (lt-pos start)
431 (xmltok-save
432 (save-excursion
433 (goto-char lt-pos)
434 (when (memq (xmltok-forward)
435 '(start-tag
436 partial-start-tag
437 empty-element
438 partial-empty-element))
439 (when (< start (point))
440 (setq xmltok-namespace-attributes
441 (rng-prune-attribute-at start
442 xmltok-namespace-attributes))
443 (setq xmltok-attributes
444 (rng-prune-attribute-at start
445 xmltok-attributes)))
446 (let ((rng-parsing-for-state t)
447 (rng-dt-namespace-context-getter '(nxml-ns-get-context)))
448 (rng-process-start-tag 'stop)
449 (rng-find-undeclared-prefixes)
450 t)))))
452 (defun rng-find-undeclared-prefixes ()
453 ;; Start with the newly effective namespace declarations.
454 ;; (Includes declarations added during recovery.)
455 (setq rng-undeclared-prefixes (nxml-ns-changed-prefixes))
456 (let ((iter xmltok-attributes)
457 (ns-state (nxml-ns-state))
458 att)
459 ;; Add namespace prefixes used in this tag,
460 ;; but not declared in the parent.
461 (nxml-ns-pop-state)
462 (while iter
463 (setq att (car iter))
464 (let ((prefix (xmltok-attribute-prefix att)))
465 (when (and prefix
466 (not (member prefix rng-undeclared-prefixes))
467 (not (nxml-ns-get-prefix prefix)))
468 (setq rng-undeclared-prefixes
469 (cons prefix rng-undeclared-prefixes))))
470 (setq iter (cdr iter)))
471 (nxml-ns-set-state ns-state)
472 ;; Remove namespace prefixes explicitly declared.
473 (setq iter xmltok-namespace-attributes)
474 (while iter
475 (setq att (car iter))
476 (setq rng-undeclared-prefixes
477 (delete (and (xmltok-attribute-prefix att)
478 (xmltok-attribute-local-name att))
479 rng-undeclared-prefixes))
480 (setq iter (cdr iter)))))
482 (defun rng-prune-attribute-at (start atts)
483 (when atts
484 (let ((cur atts))
485 (while (if (eq (xmltok-attribute-name-start (car cur)) start)
486 (progn
487 (setq atts (delq (car cur) atts))
488 nil)
489 (setq cur (cdr cur)))))
490 atts))
492 (defun rng-adjust-state-for-attribute-value (name-start
493 colon
494 name-end)
495 (let* ((prefix (if colon
496 (buffer-substring-no-properties name-start colon)
497 nil))
498 (local-name (buffer-substring-no-properties (if colon
499 (1+ colon)
500 name-start)
501 name-end))
502 (ns (and prefix (nxml-ns-get-prefix prefix))))
503 (and (or (not prefix) ns)
504 (rng-match-attribute-name (cons ns local-name)))))
506 (defun rng-complete-qname-function (string predicate flag)
507 (let ((alist (mapcar (lambda (name) (cons name nil))
508 (rng-generate-qname-list string))))
509 (cond ((not flag)
510 (try-completion string alist predicate))
511 ((eq flag t)
512 (all-completions string alist predicate))
513 ((eq flag 'lambda)
514 (and (assoc string alist) t)))))
516 (defun rng-generate-qname-list (&optional string)
517 (let ((forced-prefix (and string
518 (string-match ":" string)
519 (> (match-beginning 0) 0)
520 (substring string
522 (match-beginning 0))))
523 (namespaces (mapcar 'car rng-complete-target-names))
524 ns-prefixes-alist ns-prefixes iter ns prefer)
525 (while namespaces
526 (setq ns (car namespaces))
527 (when ns
528 (setq ns-prefixes-alist
529 (cons (cons ns (nxml-ns-prefixes-for
531 rng-complete-name-attribute-flag))
532 ns-prefixes-alist)))
533 (setq namespaces (delq ns (cdr namespaces))))
534 (setq iter ns-prefixes-alist)
535 (while iter
536 (setq ns-prefixes (car iter))
537 (setq ns (car ns-prefixes))
538 (when (null (cdr ns-prefixes))
539 ;; No declared prefix for the namespace
540 (if forced-prefix
541 ;; If namespace non-nil and prefix undeclared,
542 ;; use forced prefix.
543 (when (and ns
544 (not (nxml-ns-get-prefix forced-prefix)))
545 (setcdr ns-prefixes (list forced-prefix)))
546 (setq prefer (rng-get-preferred-unused-prefix ns))
547 (when prefer
548 (setcdr ns-prefixes (list prefer)))
549 ;; Unless it's an attribute with a non-nil namespace,
550 ;; allow no prefix for this namespace.
551 (unless rng-complete-name-attribute-flag
552 (setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
553 (setq iter (cdr iter)))
554 (rng-uniquify-equal
555 (sort (apply 'append
556 (cons rng-complete-extra-strings
557 (mapcar (lambda (name)
558 (if (car name)
559 (mapcar (lambda (prefix)
560 (if prefix
561 (concat prefix
563 (cdr name))
564 (cdr name)))
565 (cdr (assoc (car name)
566 ns-prefixes-alist)))
567 (list (cdr name))))
568 rng-complete-target-names)))
569 'string<))))
571 (defun rng-get-preferred-unused-prefix (ns)
572 (let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist))
573 iter prefix)
574 (when ns-prefix
575 (setq prefix (cdr ns-prefix))
576 (when (nxml-ns-get-prefix prefix)
577 ;; try to find an unused prefix
578 (setq iter (memq ns-prefix rng-preferred-prefix-alist))
579 (while (and iter
580 (setq ns-prefix (assoc ns iter)))
581 (if (nxml-ns-get-prefix (cdr ns-prefix))
582 (setq iter (memq ns-prefix iter))
583 (setq prefix (cdr ns-prefix))
584 nil))))
585 prefix))
587 (defun rng-strings-to-completion-alist (strings)
588 (mapcar (lambda (s) (cons s s))
589 (rng-uniquify-equal (sort (mapcar 'rng-escape-string strings)
590 'string<))))
592 (provide 'rng-nxml)
594 ;;; rng-nxml.el ends here