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