1 ;;; rngalt.el --- Tools for making completion addition to nxml mode
3 ;; Author: Lennart Borgman
4 ;; Created: Wed Jan 10 17:17:18 2007
5 (defconst rngalt:version "0.51") ;;Version:
6 ;; Last-Updated: 2008-03-08T03:33:56+0100 Sat
10 ;; Features that might be required by this library:
12 ;; `nxml-enc', `nxml-ns', `nxml-parse', `nxml-util',
13 ;; `ourcomments-util', `rng-dt', `rng-loc', `rng-match',
14 ;; `rng-parse', `rng-pttrn', `rng-uri', `rng-util', `rng-valid',
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;; This program is free software; you can redistribute it and/or modify
31 ;; it under the terms of the GNU General Public License as published by
32 ;; the Free Software Foundation; either version 2, or (at your option)
35 ;; This program is distributed in the hope that it will be useful,
36 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
37 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
38 ;; GNU General Public License for more details.
40 ;; You should have received a copy of the GNU General Public License
41 ;; along with this program; see the file COPYING. If not, write to the
42 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
43 ;; Boston, MA 02111-1307, USA.
45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 (eval-and-compile (require 'rng-valid))
50 (eval-when-compile (require 'rng-nxml))
51 (eval-when-compile (unless load-file-name (require 'nxhtml-mode nil t)))
54 (let* ((this-file (or load-file-name
55 (when (boundp 'bytecomp-filename) bytecomp-filename)
57 (this-dir (file-name-directory this-file))
58 (util-dir (expand-file-name "../util/" this-dir))
59 (load-path (cons util-dir load-path)))
60 (require 'ourcomments-util)))
61 ;;(require 'ourcomments-util)
63 ;; (setq x (macroexpand '(defcustom my-temp-opt t "doc" :type 'boolean)))
64 ;; (setq x (macroexpand '(define-minor-mode my-temp-mode "doc")))
65 ;; (setq x (macroexpand '(define-toggle my-temp-toggle t "doc")))
66 ;;(define-toggle rngalt-display-validation-header t
67 (define-minor-mode rngalt-display-validation-header
68 "Display XML validation headers at the top of buffer when t.
69 The validation header is only displayed in buffers where the main
70 major mode is derived from `nxml-mode'."
75 (when (fboundp 'rngalt-update-validation-header-overlay-everywhere)
76 (rngalt-update-validation-header-overlay-everywhere)))
78 (defun rngalt-display-validation-header-toggle ()
79 "Toggle `rngalt-display-validation-header'."
81 (rngalt-display-validation-header (if rngalt-display-validation-header -1 1)))
83 ;;(define-toggle rngalt-minimal-validation-header t
84 (define-minor-mode rngalt-minimal-validation-header
85 "If non-nil display only a short informaion about the XML validation header.
86 See also `rngalt-display-validation-header'."
91 (when (fboundp 'rngalt-update-validation-header-overlay-everywhere)
92 (rngalt-update-validation-header-overlay-everywhere)))
94 (defun rngalt-minimal-validation-header-toggle ()
95 "Toggle `rngalt-minimal-validation-header'."
97 (rngalt-minimal-validation-header (if rngalt-minimal-validation-header -1 1)))
99 (defface rngalt-validation-header-top
100 '((t (:foreground "RGB:87/CE/FA" :background "white")))
101 "Face first line of validation header."
104 (defface rngalt-validation-header-bottom
105 '((t (:foreground "white" :background "RGB:87/CE/FA")))
106 "Face first line of validation header."
109 ;; FIX-ME: remember to clear these variable, but where?
110 (defvar rngalt-validation-header nil)
111 (make-variable-buffer-local 'rngalt-validation-header)
112 (put 'rngalt-validation-header 'permanent-local t)
114 (defvar rngalt-current-schema-file-name nil)
115 (make-variable-buffer-local 'rngalt-current-schema-file-name)
116 (put 'rngalt-current-schema-file-name 'permanent-local t)
118 (defvar rngalt-validation-header-overlay nil)
119 (make-variable-buffer-local 'rngalt-validation-header-overlay)
120 (put 'rngalt-validation-header-overlay 'permanent-local t)
122 (defvar rngalt-major-mode nil)
123 (make-variable-buffer-local 'rngalt-major-mode)
124 (put 'rngalt-major-mode 'permanent-local t)
126 (defvar rngalt-complete-first-try nil
127 "First function to try for completion.
128 If non-nil should be a function with no parameters. Used by
131 (defvar rngalt-complete-last-try nil
132 "Last function to try for completion.
133 If non-nil should be a function with no parameters. Used by
136 (defvar rngalt-completing-read-tag nil
137 "Alternate function for completing tag name.
138 If non-nil should be a function with the same parameters as
139 `completing-read'. Used by `rngalt-complete'.")
141 (defvar rngalt-completing-read-attribute-name nil
142 "Alternate function for completing attribute name.
143 If non-nil should be a function with the same parameters as
144 `completing-read'. Used by `rngalt-complete'.")
146 (defvar rngalt-completing-read-attribute-value nil
147 "Alternate function for completing attribute value.
148 If non-nil should be a function with the same parameters as
149 `completing-read'. Used by `rngalt-complete'.")
152 (defun rngalt-finish-element ()
153 "Finish the current element by inserting an end-tag.
154 Like `nxml-finish-element' but takes `rngalt-validation-header'
157 (rngalt-finish-element-1 nil))
159 ;; Fix-me: Check the other uses of `nxml-finish-element-1'. But this
160 ;; is maybe not necessary since the only other use is in
161 ;; `nxml-split-element' and that will anyway work - I believe ...
162 (defun rngalt-finish-element-1 (startp)
163 "Insert an end-tag for the current element and optionally a start-tag.
164 The start-tag is inserted if STARTP is non-nil. Return the position
165 of the inserted start-tag or nil if none was inserted.
167 This is like `nxml-finish-element-1' but takes
168 `rngalt-validation-header' into account."
176 inserted-start-tag-pos)
177 ;; Temporary insert the fictive validation header if any.
178 (let ((buffer-undo-list nil)
179 (here (point-marker)))
180 (when rngalt-validation-header
181 (let ((vh (nth 2 rngalt-validation-header)))
182 (set-marker-insertion-type here t)
185 (goto-char (point-min))
188 (setq token-end (nxml-token-before))
191 (when (and (< (point) token-end)
194 processing-instruction
199 (error "Point is inside a %s"
200 (nxml-token-type-friendly-name xmltok-type)))
201 (nxml-scan-element-backward token-end t)))
205 (unless (eq xmltok-type 'start-tag)
206 (error "No matching start-tag"))
207 (goto-char xmltok-start)
208 (back-to-indentation)
209 (eq (point) xmltok-start)))
212 (goto-char start-tag-end)
213 (looking-at "[ \t\r\n]*$")))
214 (setq start-tag-indent (save-excursion
215 (goto-char xmltok-start)
217 (setq qname (xmltok-start-tag-qname)))
219 ;; Undo the insertion of the fictive header:
221 (while (and (not (eq t pending-undo-list))
226 (unless start-tag-end (error "No more start tags"))
228 (when (and starts-line ends-line)
229 ;; start-tag is on a line by itself
230 ;; => put the end-tag on a line by itself
233 (back-to-indentation)
236 (indent-line-to start-tag-indent))
237 (insert "</" qname ">")
241 (indent-line-to start-tag-indent))
242 (setq inserted-start-tag-pos (point))
243 (insert "<" qname ">")
244 (when (and starts-line ends-line)
246 (indent-line-to (save-excursion
247 (goto-char xmltok-start)
249 (back-to-indentation)
250 (if (= (current-column)
251 (+ start-tag-indent nxml-child-indent))
252 (+ start-tag-indent nxml-child-indent)
253 start-tag-indent)))))
254 inserted-start-tag-pos))
256 (defun rngalt-complete ()
257 "Complete the string before point using the current schema.
258 Return non-nil if in a context it understands.
260 This function should be added to `nxml-completion-hook' before
261 `rng-complete'. By default it works just like this function, but
262 you can add your own completion by setting the variables
263 `rngalt-complete-first-try', `rngalt-completing-read-tag',
264 `rngalt-completing-read-attribute-name',
265 `rngalt-completing-read-attribute-value' and
266 `rngalt-complete-last-try'."
268 (unless rng-validate-mode
270 "XML Validation is not on. Do you want to turn it on? ")
271 (rng-validate-mode 1)))
272 (when rng-validate-mode
273 ;; schema file may mismatch if user sets it explicitly:
274 (rngalt-reapply-validation-header)
275 (when rng-current-schema-file-name
277 (or (when rngalt-complete-first-try
278 (funcall rngalt-complete-first-try))
280 (unless rng-current-schema-file-name
281 (when (eq major-mode 'nxhtml-mode)
283 "There is currently no DTD specified for the buffer.
284 This makes XHTML completion impossible. You can add a fictive
285 XHTML validation header that sets the DTD to XHTML. This will
286 not be inserted in the buffer but completion and XHTML validation
287 will assume it is there so both error checking and completion
290 Do you want to add a fictive XHTML validation header? ")
291 (message "") ;; Get rid of the large minibuffer message window
292 (nxhtml-validation-header-mode)
294 (let ((lt-pos (save-excursion (search-backward "<" nil t)))
297 (= (rng-set-state-after lt-pos) lt-pos)
298 (or (rngalt-complete-tag lt-pos)
299 (rng-complete-end-tag lt-pos)
300 (rngalt-complete-attribute-name lt-pos)
301 (rngalt-complete-attribute-value lt-pos)))
302 (when rngalt-complete-last-try
303 (funcall rngalt-complete-last-try))))))))
305 (defun rngalt-validate ()
306 (unless (= (buffer-size) 0)
310 (while (and (> maxn1 (setq while-n1 (1+ while-n1)))
311 (rng-do-some-validation))
314 ;; FIX-ME: for debugging:
315 ;;(lwarn 'rngalt-validate :error "%s" (error-message-string err))
316 (message "rngalt-validate: %s" (error-message-string err))
318 (when (>= while-n1 maxn1)
319 (error "rngalt-validate: Could not validate")))
320 (rng-validate-done)))
322 (defvar rngalt-region-ovl nil)
323 (defvar rngalt-region-prepared nil)
324 (defun rngalt-complete-tag-region-prepare ()
325 (unless rngalt-region-prepared
326 (when rngalt-region-ovl
327 (when (overlayp rngalt-region-ovl)
328 (delete-overlay rngalt-region-ovl))
329 (setq rngalt-region-ovl nil))
330 (when (and mark-active
332 (let ((beginning (region-beginning))
334 (unless (= (point) (region-beginning))
335 (goto-char beginning))
336 (when (save-excursion
337 (when (re-search-forward "\\=[^<]*\\(?:<[^<]*>\\)*[^>]*" end t)
339 (setq rngalt-region-ovl (make-overlay beginning end))
340 (overlay-put rngalt-region-ovl 'face 'region)
342 (setq rngalt-region-prepared t)))
344 (defun rngalt-complete-tag-region-cleanup ()
345 (when rngalt-region-prepared
346 (when (overlayp rngalt-region-ovl)
347 (delete-overlay rngalt-region-ovl))
349 (setq rngalt-region-prepared nil)))
351 (defun rngalt-complete-tag-region-finish ()
352 (when (and rngalt-region-prepared
353 (overlayp rngalt-region-ovl))
354 (let ((here (point)))
356 (goto-char (overlay-end rngalt-region-ovl))
357 (nxml-finish-element)
360 (rngalt-complete-tag-region-cleanup))
362 (defun rngalt-complete-tag (lt-pos)
363 "Like `rng-complete-tag' but with some additions.
365 - Alternate completion.
366 - Complete around highlighted region.
368 See also the variable `rngalt-completing-read-tag'."
369 (let (rng-complete-extra-strings)
370 (when (and (= lt-pos (1- (point)))
371 rng-complete-end-tags-after-<
373 (not (eq (car rng-open-elements) t))
374 (or rng-collecting-text
376 (rng-match-end-tag))))
377 (setq rng-complete-extra-strings
379 (if (caar rng-open-elements)
380 (concat (caar rng-open-elements)
382 (cdar rng-open-elements))
383 (cdar rng-open-elements)))
384 rng-complete-extra-strings)))
385 (when (save-excursion
386 (re-search-backward rng-in-start-tag-name-regex
389 (and rng-collecting-text (rng-flush-text))
390 (rngalt-complete-tag-region-prepare)
392 (let ((rng-complete-target-names
393 (rng-match-possible-start-tag-names))
394 (rng-complete-name-attribute-flag nil))
395 (rngalt-complete-before-point (1+ lt-pos)
396 'rng-complete-qname-function
400 rngalt-completing-read-tag)))
403 (cond ((rng-qname-p completion)
404 (setq name (rng-expand-qname completion
406 'rng-start-tag-expand-recover))
408 (rng-match-start-tag-open name)
409 (or (not (rng-match-start-tag-close))
410 ;; need a namespace decl on the root element
412 (not rng-open-elements))))
413 ;; attributes are required
415 (rngalt-complete-tag-region-finish)
416 (run-hook-with-args 'rngalt-complete-tag-hooks completion)
418 ((member completion rng-complete-extra-strings)
420 (rngalt-complete-tag-region-finish)
423 (defvar rngalt-complete-tag-hooks nil
424 "Hook run after completing a tag.
425 Each function is called with the last name of the last tag
428 (defun rngalt-complete-attribute-name (lt-pos)
429 "Like `rng-complete-attribute-name' but with alternate completion.
430 See the variable `rngalt-completing-read-attribute-name'."
431 (when (save-excursion
432 (re-search-backward rng-in-attribute-regex lt-pos t))
433 (let ((attribute-start (match-beginning 1))
434 rng-undeclared-prefixes)
435 (and (rng-adjust-state-for-attribute lt-pos
437 (let ((rng-complete-target-names
438 (rng-match-possible-attribute-names))
439 (rng-complete-extra-strings
440 (mapcar (lambda (prefix)
442 (concat "xmlns:" prefix)
444 rng-undeclared-prefixes))
445 (rng-complete-name-attribute-flag t)
448 (rngalt-complete-before-point attribute-start
449 'rng-complete-qname-function
452 'rng-attribute-name-history
453 rngalt-completing-read-attribute-name))
454 (when (and completion
455 (< 0 (length completion)))
459 (defun rngalt-complete-attribute-value (lt-pos)
460 "Like `rng-complete-attribute-value' but with alternate completion.
461 See the variable `rngalt-completing-read-attribute-value'."
462 (when (save-excursion
463 (re-search-backward rng-in-attribute-value-regex lt-pos t))
464 (let ((name-start (match-beginning 1))
465 (name-end (match-end 1))
466 (colon (match-beginning 2))
467 (value-start (1+ (match-beginning 3))))
468 (and (rng-adjust-state-for-attribute lt-pos
470 (if (string= (buffer-substring-no-properties name-start
473 (rngalt-complete-before-point
475 (rng-strings-to-completion-alist
476 (rng-possible-namespace-uris
478 (buffer-substring-no-properties (1+ colon) name-end))))
481 'rng-namespace-uri-history
482 rngalt-completing-read-attribute-value) ;; fix-me
483 (rng-adjust-state-for-attribute-value name-start
486 (rngalt-complete-before-point
488 (rng-strings-to-completion-alist
489 (rng-match-possible-value-strings))
492 'rng-attribute-value-history
493 rngalt-completing-read-attribute-value))
494 (unless (eq (char-after) (char-before value-start))
495 (insert (char-before value-start)))))
498 (defun rngalt-complete-before-point (start table prompt &optional predicate hist altcompl)
499 "Complete text between START and point.
500 Works like `rng-complete-before-point' if ALTCOMPL is nil. When
501 ALTCOMPL is a function symbol and no completion alternative is
502 available from table then this is called instead of
503 `compleating-read' with the same parameters."
504 (let* ((orig (buffer-substring-no-properties start (point)))
505 (completion (try-completion orig table predicate))
506 (completing-fun (if altcompl altcompl 'completing-read))
507 (completion-ignore-case t))
508 (cond ((not (or completion completing-fun))
509 (if (string= orig "")
510 (message "No completions available")
511 (message "No completion for %s" (rng-quote-string orig)))
514 ((eq completion t) orig)
516 (not (string= completion orig)))
517 (delete-region start (point))
519 (cond ((not (rng-completion-exact-p completion table predicate))
520 (message "Incomplete")
522 ((eq (try-completion completion table predicate) t)
525 (message "Complete but not unique")
529 (let ((saved-minibuffer-setup-hook
530 (default-value 'minibuffer-setup-hook)))
531 (add-hook 'minibuffer-setup-hook
532 'minibuffer-completion-help
535 (funcall completing-fun
542 (setq-default minibuffer-setup-hook
543 saved-minibuffer-setup-hook))))
545 (delete-region start (point))
549 (defun rngalt-get-missing-required-attr (single-tag)
550 "Get a list of missing required attributes.
551 This is to be used when completing attribute names.
552 SINGLE-TAG should be non-nil if the tag has no end tag.
554 For a typical use see `nxhtml-completing-read-attribute-name' in
557 ;; FIX-ME: This is a terrible cludge. One day I hope I will
558 ;; understand how to write this ;-)
560 ;; I currently fetch the missing tags from the error message in the
561 ;; error overlay set by rng validate.
562 (let ((here (point)))
563 (unless (save-match-data (looking-at "[^<]\\{,200\\}>"))
564 ;; We can probably add a >, so let us do it:
570 (let ((ovl (rng-error-overlay-message (or (rng-error-overlay-after (point))
571 (rng-error-overlay-after (1- (point)))))))
572 ;;(message "ovl=%s" ovl)(sit-for 1)
573 ;;(message "prop ovl=%s" (overlay-properties ovl))(sit-for 1)
575 (eq (overlay-get ovl 'category) 'rng-error))
576 ;;(message "rng-error")(sit-for 1)
577 (let ((msg (overlay-get ovl 'help-echo)))
578 ;;(message "msg=%s" msg);(sit-for 1)
579 (when (string-match "Missing attributes? \\(.*\\)" msg)
580 ;;(message "0=%s" (match-string 0 msg));(sit-for 1)
581 ;;(message "1=%s" (match-string 1 msg));(sit-for 1)
582 (let* ((matches (match-string 1 msg))
583 (lst (split-string (substring matches 1 (- (length matches) 1)) "\", \"")))
584 ;;(message "matches=%s" matches);(sit-for 2)
585 ;;(message "lst=%s" lst);(sit-for 1)
589 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
590 ;;; Validation start state
592 (defun rngalt-after-change-major ()
593 (unless (and (boundp 'mumamo-set-major-running)
594 mumamo-set-major-running)
595 (setq rngalt-major-mode major-mode)
596 (when (and (derived-mode-p 'nxml-mode)
597 rngalt-validation-header)
598 (rngalt-reapply-validation-header))
599 (rngalt-update-validation-header-overlay)))
601 (defvar rngalt-validation-header-keymap
602 (let ((map (make-sparse-keymap)))
603 (define-key map [mouse-1] 'rngalt-minimal-validation-header-toggle)
606 (defun rngalt-update-validation-header-overlay ()
607 (if (and (boundp 'rngalt-display-validation-header)
608 rngalt-display-validation-header
609 rngalt-validation-header
610 (or (derived-mode-p 'nxml-mode)
611 (let ((major-mode rngalt-major-mode))
613 (derived-mode-p 'nxml-mode))))
616 (if rngalt-validation-header-overlay
617 (move-overlay rngalt-validation-header-overlay 1 1)
618 (setq rngalt-validation-header-overlay (make-overlay 1 1)))
619 (overlay-put rngalt-validation-header-overlay
621 ;; Other properties should go to the 'before-string
622 (let* ((validation-header (nth 2 rngalt-validation-header))
624 (if rngalt-minimal-validation-header
627 "*** Fictive XHTML/XML Validation Header: ... "
629 (if (string-match "\\(<[^[:space:]>]+\\)[^>]*>[^<>]*\\'"
631 (concat (match-string 1 validation-header) ">")
634 'face 'rngalt-validation-header-bottom)
636 (propertize "*** Fictive XHTML/XML Validation Header:\n"
637 'face 'rngalt-validation-header-top)
638 (propertize (concat validation-header "\n")
639 'face 'rngalt-validation-header-bottom)))))
644 "Click to toggle full/minimal display of header"
645 'keymap rngalt-validation-header-keymap))
646 (overlay-put rngalt-validation-header-overlay
647 'before-string header)))
648 (when rngalt-validation-header-overlay
649 (delete-overlay rngalt-validation-header-overlay))))
651 (defun rngalt-update-validation-header-overlay-everywhere ()
652 (dolist (b (buffer-list))
653 (when (buffer-live-p b)
654 (with-current-buffer b
655 (when rngalt-validation-header
656 (rngalt-update-validation-header-overlay))))))
658 ;; This is exactly the same as the original `rng-set-initial-state'
659 ;; except when `rngalt-validation-header' is non-nil."
660 (defadvice rng-set-initial-state (around
661 rngalt-set-initial-state
666 (rng-match-start-document)
667 (setq rng-open-elements nil)
668 (setq rng-pending-contents nil)
669 (when rngalt-validation-header
670 (let ((state (car rngalt-validation-header)))
671 (rng-restore-state state)))
672 (setq ad-return-value (goto-char (point-min))))
674 ;; (defun rng-new-validate-prepare ()
675 ;; "Prepare to do some validation, initializing point and the state.
676 ;; Return t if there is work to do, nil otherwise.
678 ;; This is exactly the same as the original-insert-directory
679 ;; `rng-validate-prepare' with the difference that the state at
680 ;; point 1 is set differently if `rngalt-validation-header' is
683 ;; See also `rng-set-initial-state'."
684 ;; (cond ((= rng-validate-up-to-date-end 1)
685 ;; (rng-set-initial-state)
687 ;; ((= rng-validate-up-to-date-end (point-max))
690 ;; (if (and rngalt-validation-header
691 ;; (= rng-validate-up-to-date-end 1))
692 ;; (car rngalt-validation-header)
693 ;; (get-text-property (1- rng-validate-up-to-date-end)
696 ;; (rng-restore-state state)
697 ;; (goto-char rng-validate-up-to-date-end))
699 ;; (let ((pos (previous-single-property-change
700 ;; rng-validate-up-to-date-end
703 ;; (rng-restore-state
704 ;; (or (get-text-property (1- pos) 'rng-state)
705 ;; (error "Internal error: state null")))
707 ;; (t (rng-set-initial-state))))))))))
710 ;; For as-external.el
712 (defun rngalt-set-validation-header (start-of-doc)
713 (let ((old-rvm rng-validate-mode))
714 (when old-rvm (rng-validate-mode -1))
717 (add-hook 'after-change-major-mode-hook 'rngalt-after-change-major nil t)
718 (setq rngalt-validation-header (rngalt-get-state-after start-of-doc))
719 (rng-set-schema-file-1 (cadr rngalt-validation-header))
720 (setq rngalt-current-schema-file-name rng-current-schema-file-name)
721 (setq rng-compile-table nil)
722 (setq rng-ipattern-table nil)
723 (setq rng-last-ipattern-index nil))
724 (remove-hook 'after-change-major-mode-hook 'rngalt-after-change-major t)
725 (setq rngalt-validation-header nil)
727 (rng-set-vacuous-schema)
728 (rng-auto-set-schema)))
730 (rng-validate-mode 1)
731 (rngalt-update-validation-header-overlay)
732 (rngalt-update-validation-header-buffer))))
734 (defun rngalt-reapply-validation-header ()
735 (when rngalt-validation-header
736 (when (or (not rng-current-schema-file-name)
737 (unless (string= rngalt-current-schema-file-name rng-current-schema-file-name)
738 (lwarn 'schema-mismatch :warning
739 "XHTML validation header schema %s reapplied (replaces %s)"
740 (file-name-nondirectory rngalt-current-schema-file-name)
741 (file-name-nondirectory rng-current-schema-file-name))
743 (rngalt-set-validation-header (nth 2 rngalt-validation-header)))))
745 ;; (defun rngalt-clear-validation-header ()
746 ;; "Remove XML validation header from current buffer.
747 ;; For more information see `rngalt-show-validation-header'."
749 ;; (rngalt-set-validation-header nil)
750 ;; (rng-auto-set-schema t))
752 ;; FIX-ME: Add edit header?
754 (defun rngalt-get-validation-header-buffer ()
755 (let ((b (get-buffer " *XML Validation Header*")))
757 (setq b (get-buffer-create " *XML Validation Header*"))
758 (with-current-buffer b
763 (defun rngalt-get-state-after (start-of-doc)
764 ;; FIX-ME: better buffer name?
765 (let ((statebuf (rngalt-get-validation-header-buffer)))
766 (with-current-buffer statebuf
767 (when rng-validate-mode (rng-validate-mode -1))
769 (insert start-of-doc)
770 ;; From rng-get-state
771 (setq rng-match-state nil)
772 (setq nxml-ns-state nil)
773 (setq rng-open-elements nil)
774 ;; From rng-match-init-buffer
775 (setq rng-compile-table nil)
776 (setq rng-ipattern-table nil)
777 (setq rng-last-ipattern-index nil)
780 (rng-validate-mode 1)
782 (let* ((state (rng-get-state))
783 (cp-state (copy-tree state)))
784 ;;(if (equal state cp-state) (message "(equal state cp-state)=t") (message "(equal state cp-state)=nil"))
785 ;; Fix-me: is the copy-tree necessary here?
788 (rng-locate-schema-file)
791 (defun rngalt-show-validation-header ()
792 "Show XML validation header used in current buffer.
793 The XML validation header is used in `nxhtml-mode' to set a state
794 for XML validation at the start of the buffer.
796 The purpose is to make it possible to use `nxml-mode' completion
797 in buffers where you do not actually have a full XML file. This
798 could for example be a buffer with PHP code or a buffer with a
801 More techhnical info: This can be used by any mode derived from
802 `nxml-mode'. To use it in other modes than `nxhtml-mode' replace
803 `rng-complete' by `rngalt-complete' in `nxml-completion-hook'."
805 (unless (derived-mode-p 'nxml-mode)
806 (error "Buffer mode is not an nXml type major mode: %s" major-mode))
807 (rngalt-update-validation-header-buffer)
808 (display-buffer (rngalt-get-validation-header-buffer) t))
810 (defun rngalt-update-validation-header-buffer ()
811 (let ((vh (nth 2 rngalt-validation-header))
812 (cb (current-buffer)))
813 (with-current-buffer (rngalt-get-validation-header-buffer)
816 (setq header-line-format (concat " No XML validation header in buffer "
819 (setq header-line-format (concat " XML validation header in buffer "
820 (buffer-name cb)))))))
822 ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
828 ;;; rngalt.el ends here