diff options
Diffstat (limited to 'emacs.d/nxhtml/nxhtml/rngalt.el')
| -rw-r--r-- | emacs.d/nxhtml/nxhtml/rngalt.el | 828 |
1 files changed, 828 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/nxhtml/rngalt.el b/emacs.d/nxhtml/nxhtml/rngalt.el new file mode 100644 index 0000000..788128a --- /dev/null +++ b/emacs.d/nxhtml/nxhtml/rngalt.el @@ -0,0 +1,828 @@ +;;; rngalt.el --- Tools for making completion addition to nxml mode +;; +;; Author: Lennart Borgman +;; Created: Wed Jan 10 17:17:18 2007 +(defconst rngalt:version "0.51") ;;Version: +;; Last-Updated: 2008-03-08T03:33:56+0100 Sat +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; `nxml-enc', `nxml-ns', `nxml-parse', `nxml-util', +;; `ourcomments-util', `rng-dt', `rng-loc', `rng-match', +;; `rng-parse', `rng-pttrn', `rng-uri', `rng-util', `rng-valid', +;; `xmltok'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program 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 2, or (at your option) +;; any later version. +;; +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(eval-and-compile (require 'rng-valid)) +(eval-when-compile (require 'rng-nxml)) +(eval-when-compile (unless load-file-name (require 'nxhtml-mode nil t))) + +(eval-when-compile + (let* ((this-file (or load-file-name + (when (boundp 'bytecomp-filename) bytecomp-filename) + buffer-file-name)) + (this-dir (file-name-directory this-file)) + (util-dir (expand-file-name "../util/" this-dir)) + (load-path (cons util-dir load-path))) + (require 'ourcomments-util))) +;;(require 'ourcomments-util) + +;; (setq x (macroexpand '(defcustom my-temp-opt t "doc" :type 'boolean))) +;; (setq x (macroexpand '(define-minor-mode my-temp-mode "doc"))) +;; (setq x (macroexpand '(define-toggle my-temp-toggle t "doc"))) +;;(define-toggle rngalt-display-validation-header t +(define-minor-mode rngalt-display-validation-header + "Display XML validation headers at the top of buffer when t. +The validation header is only displayed in buffers where the main +major mode is derived from `nxml-mode'." + :global t + :init-value t + :group 'relax-ng + :group 'nxhtml + (when (fboundp 'rngalt-update-validation-header-overlay-everywhere) + (rngalt-update-validation-header-overlay-everywhere))) + +(defun rngalt-display-validation-header-toggle () + "Toggle `rngalt-display-validation-header'." + (interactive) + (rngalt-display-validation-header (if rngalt-display-validation-header -1 1))) + +;;(define-toggle rngalt-minimal-validation-header t +(define-minor-mode rngalt-minimal-validation-header + "If non-nil display only a short informaion about the XML validation header. +See also `rngalt-display-validation-header'." + :global t + :init-value t + :group 'relax-ng + :group 'nxhtml + (when (fboundp 'rngalt-update-validation-header-overlay-everywhere) + (rngalt-update-validation-header-overlay-everywhere))) + +(defun rngalt-minimal-validation-header-toggle () + "Toggle `rngalt-minimal-validation-header'." + (interactive) + (rngalt-minimal-validation-header (if rngalt-minimal-validation-header -1 1))) + +(defface rngalt-validation-header-top + '((t (:foreground "RGB:87/CE/FA" :background "white"))) + "Face first line of validation header." + :group 'nxhtml) + +(defface rngalt-validation-header-bottom + '((t (:foreground "white" :background "RGB:87/CE/FA"))) + "Face first line of validation header." + :group 'nxhtml) + +;; FIX-ME: remember to clear these variable, but where? +(defvar rngalt-validation-header nil) +(make-variable-buffer-local 'rngalt-validation-header) +(put 'rngalt-validation-header 'permanent-local t) + +(defvar rngalt-current-schema-file-name nil) +(make-variable-buffer-local 'rngalt-current-schema-file-name) +(put 'rngalt-current-schema-file-name 'permanent-local t) + +(defvar rngalt-validation-header-overlay nil) +(make-variable-buffer-local 'rngalt-validation-header-overlay) +(put 'rngalt-validation-header-overlay 'permanent-local t) + +(defvar rngalt-major-mode nil) +(make-variable-buffer-local 'rngalt-major-mode) +(put 'rngalt-major-mode 'permanent-local t) + +(defvar rngalt-complete-first-try nil + "First function to try for completion. +If non-nil should be a function with no parameters. Used by +`rngalt-complete'.") + +(defvar rngalt-complete-last-try nil + "Last function to try for completion. +If non-nil should be a function with no parameters. Used by +`rngalt-complete'.") + +(defvar rngalt-completing-read-tag nil + "Alternate function for completing tag name. +If non-nil should be a function with the same parameters as +`completing-read'. Used by `rngalt-complete'.") + +(defvar rngalt-completing-read-attribute-name nil + "Alternate function for completing attribute name. +If non-nil should be a function with the same parameters as +`completing-read'. Used by `rngalt-complete'.") + +(defvar rngalt-completing-read-attribute-value nil + "Alternate function for completing attribute value. +If non-nil should be a function with the same parameters as +`completing-read'. Used by `rngalt-complete'.") + + +(defun rngalt-finish-element () + "Finish the current element by inserting an end-tag. +Like `nxml-finish-element' but takes `rngalt-validation-header' +into account." + (interactive "*") + (rngalt-finish-element-1 nil)) + +;; Fix-me: Check the other uses of `nxml-finish-element-1'. But this +;; is maybe not necessary since the only other use is in +;; `nxml-split-element' and that will anyway work - I believe ... +(defun rngalt-finish-element-1 (startp) + "Insert an end-tag for the current element and optionally a start-tag. +The start-tag is inserted if STARTP is non-nil. Return the position +of the inserted start-tag or nil if none was inserted. + +This is like `nxml-finish-element-1' but takes +`rngalt-validation-header' into account." + (interactive "*") + (let (token-end + start-tag-end + starts-line + ends-line + start-tag-indent + qname + inserted-start-tag-pos) + ;; Temporary insert the fictive validation header if any. + (let ((buffer-undo-list nil) + (here (point-marker))) + (when rngalt-validation-header + (let ((vh (nth 2 rngalt-validation-header))) + (set-marker-insertion-type here t) + (save-restriction + (widen) + (goto-char (point-min)) + (insert vh))) + (goto-char here)) + (setq token-end (nxml-token-before)) + (setq start-tag-end + (save-excursion + (when (and (< (point) token-end) + (memq xmltok-type + '(cdata-section + processing-instruction + comment + start-tag + end-tag + empty-element))) + (error "Point is inside a %s" + (nxml-token-type-friendly-name xmltok-type))) + (nxml-scan-element-backward token-end t))) + (when start-tag-end + (setq starts-line + (save-excursion + (unless (eq xmltok-type 'start-tag) + (error "No matching start-tag")) + (goto-char xmltok-start) + (back-to-indentation) + (eq (point) xmltok-start))) + (setq ends-line + (save-excursion + (goto-char start-tag-end) + (looking-at "[ \t\r\n]*$"))) + (setq start-tag-indent (save-excursion + (goto-char xmltok-start) + (current-column))) + (setq qname (xmltok-start-tag-qname))) + + ;; Undo the insertion of the fictive header: + (undo-start) + (while (and (not (eq t pending-undo-list)) + pending-undo-list) + (undo-more 1)) + (goto-char here)) + + (unless start-tag-end (error "No more start tags")) + + (when (and starts-line ends-line) + ;; start-tag is on a line by itself + ;; => put the end-tag on a line by itself + (unless (<= (point) + (save-excursion + (back-to-indentation) + (point))) + (insert "\n")) + (indent-line-to start-tag-indent)) + (insert "</" qname ">") + (when startp + (when starts-line + (insert "\n") + (indent-line-to start-tag-indent)) + (setq inserted-start-tag-pos (point)) + (insert "<" qname ">") + (when (and starts-line ends-line) + (insert "\n") + (indent-line-to (save-excursion + (goto-char xmltok-start) + (forward-line 1) + (back-to-indentation) + (if (= (current-column) + (+ start-tag-indent nxml-child-indent)) + (+ start-tag-indent nxml-child-indent) + start-tag-indent))))) + inserted-start-tag-pos)) + +(defun rngalt-complete () + "Complete the string before point using the current schema. +Return non-nil if in a context it understands. + +This function should be added to `nxml-completion-hook' before +`rng-complete'. By default it works just like this function, but +you can add your own completion by setting the variables +`rngalt-complete-first-try', `rngalt-completing-read-tag', +`rngalt-completing-read-attribute-name', +`rngalt-completing-read-attribute-value' and +`rngalt-complete-last-try'." + (interactive) + (unless rng-validate-mode + (when (y-or-n-p + "XML Validation is not on. Do you want to turn it on? ") + (rng-validate-mode 1))) + (when rng-validate-mode + ;; schema file may mismatch if user sets it explicitly: + (rngalt-reapply-validation-header) + (when rng-current-schema-file-name + (rngalt-validate)) + (or (when rngalt-complete-first-try + (funcall rngalt-complete-first-try)) + (progn + (unless rng-current-schema-file-name + (when (eq major-mode 'nxhtml-mode) + (when (y-or-n-p + "There is currently no DTD specified for the buffer. +This makes XHTML completion impossible. You can add a fictive +XHTML validation header that sets the DTD to XHTML. This will +not be inserted in the buffer but completion and XHTML validation +will assume it is there so both error checking and completion +will work. + +Do you want to add a fictive XHTML validation header? ") + (message "") ;; Get rid of the large minibuffer message window + (nxhtml-validation-header-mode) + ))) + (let ((lt-pos (save-excursion (search-backward "<" nil t))) + xmltok-dtd) + (or (and lt-pos + (= (rng-set-state-after lt-pos) lt-pos) + (or (rngalt-complete-tag lt-pos) + (rng-complete-end-tag lt-pos) + (rngalt-complete-attribute-name lt-pos) + (rngalt-complete-attribute-value lt-pos))) + (when rngalt-complete-last-try + (funcall rngalt-complete-last-try)))))))) + +(defun rngalt-validate () + (unless (= (buffer-size) 0) + (let ((while-n1 0) + (maxn1 20)) + (condition-case err + (while (and (> maxn1 (setq while-n1 (1+ while-n1))) + (rng-do-some-validation)) + nil) + (error + ;; FIX-ME: for debugging: + ;;(lwarn 'rngalt-validate :error "%s" (error-message-string err)) + (message "rngalt-validate: %s" (error-message-string err)) + nil)) + (when (>= while-n1 maxn1) + (error "rngalt-validate: Could not validate"))) + (rng-validate-done))) + +(defvar rngalt-region-ovl nil) +(defvar rngalt-region-prepared nil) +(defun rngalt-complete-tag-region-prepare () + (unless rngalt-region-prepared + (when rngalt-region-ovl + (when (overlayp rngalt-region-ovl) + (delete-overlay rngalt-region-ovl)) + (setq rngalt-region-ovl nil)) + (when (and mark-active + transient-mark-mode) + (let ((beginning (region-beginning)) + (end (region-end))) + (unless (= (point) (region-beginning)) + (goto-char beginning)) + (when (save-excursion + (when (re-search-forward "\\=[^<]*\\(?:<[^<]*>\\)*[^>]*" end t) + (= end (point)))) + (setq rngalt-region-ovl (make-overlay beginning end)) + (overlay-put rngalt-region-ovl 'face 'region) + ))) + (setq rngalt-region-prepared t))) + +(defun rngalt-complete-tag-region-cleanup () + (when rngalt-region-prepared + (when (overlayp rngalt-region-ovl) + (delete-overlay rngalt-region-ovl)) + (deactivate-mark) + (setq rngalt-region-prepared nil))) + +(defun rngalt-complete-tag-region-finish () + (when (and rngalt-region-prepared + (overlayp rngalt-region-ovl)) + (let ((here (point))) + (insert ">") + (goto-char (overlay-end rngalt-region-ovl)) + (nxml-finish-element) + (rngalt-validate) + (goto-char here))) + (rngalt-complete-tag-region-cleanup)) + +(defun rngalt-complete-tag (lt-pos) + "Like `rng-complete-tag' but with some additions. +The additions are: +- Alternate completion. +- Complete around highlighted region. + +See also the variable `rngalt-completing-read-tag'." + (let (rng-complete-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)))) + (setq rng-complete-extra-strings + (cons (concat "/" + (if (caar rng-open-elements) + (concat (caar rng-open-elements) + ":" + (cdar rng-open-elements)) + (cdar rng-open-elements))) + rng-complete-extra-strings))) + (when (save-excursion + (re-search-backward rng-in-start-tag-name-regex + lt-pos + t)) + (and rng-collecting-text (rng-flush-text)) + (rngalt-complete-tag-region-prepare) + (let ((completion + (let ((rng-complete-target-names + (rng-match-possible-start-tag-names)) + (rng-complete-name-attribute-flag nil)) + (rngalt-complete-before-point (1+ lt-pos) + 'rng-complete-qname-function + "Insert tag: " + nil + 'rng-tag-history + rngalt-completing-read-tag))) + name) + (when completion + (cond ((rng-qname-p completion) + (setq 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 " ")) + (rngalt-complete-tag-region-finish) + (run-hook-with-args 'rngalt-complete-tag-hooks completion) + ) + ((member completion rng-complete-extra-strings) + (insert ">"))))) + (rngalt-complete-tag-region-finish) + t))) + +(defvar rngalt-complete-tag-hooks nil + "Hook run after completing a tag. +Each function is called with the last name of the last tag +completed.") + +(defun rngalt-complete-attribute-name (lt-pos) + "Like `rng-complete-attribute-name' but with alternate completion. +See the variable `rngalt-completing-read-attribute-name'." + (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 ((rng-complete-target-names + (rng-match-possible-attribute-names)) + (rng-complete-extra-strings + (mapcar (lambda (prefix) + (if prefix + (concat "xmlns:" prefix) + "xmlns")) + rng-undeclared-prefixes)) + (rng-complete-name-attribute-flag t) + completion) + (setq completion + (rngalt-complete-before-point attribute-start + 'rng-complete-qname-function + "Attribute: " + nil + 'rng-attribute-name-history + rngalt-completing-read-attribute-name)) + (when (and completion + (< 0 (length completion))) + (insert "=\""))))) + t)) + +(defun rngalt-complete-attribute-value (lt-pos) + "Like `rng-complete-attribute-value' but with alternate completion. +See the variable `rngalt-completing-read-attribute-value'." + (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)))) + (and (rng-adjust-state-for-attribute lt-pos + name-start) + (if (string= (buffer-substring-no-properties name-start + (or colon name-end)) + "xmlns") + (rngalt-complete-before-point + value-start + (rng-strings-to-completion-alist + (rng-possible-namespace-uris + (and colon + (buffer-substring-no-properties (1+ colon) name-end)))) + "Namespace URI: " + nil + 'rng-namespace-uri-history + rngalt-completing-read-attribute-value) ;; fix-me + (rng-adjust-state-for-attribute-value name-start + colon + name-end) + (rngalt-complete-before-point + value-start + (rng-strings-to-completion-alist + (rng-match-possible-value-strings)) + "Value: " + nil + 'rng-attribute-value-history + rngalt-completing-read-attribute-value)) + (unless (eq (char-after) (char-before value-start)) + (insert (char-before value-start))))) + t)) + +(defun rngalt-complete-before-point (start table prompt &optional predicate hist altcompl) + "Complete text between START and point. +Works like `rng-complete-before-point' if ALTCOMPL is nil. When +ALTCOMPL is a function symbol and no completion alternative is +available from table then this is called instead of +`compleating-read' with the same parameters." + (let* ((orig (buffer-substring-no-properties start (point))) + (completion (try-completion orig table predicate)) + (completing-fun (if altcompl altcompl 'completing-read)) + (completion-ignore-case t)) + (cond ((not (or completion completing-fun)) + (if (string= orig "") + (message "No completions available") + (message "No completion for %s" (rng-quote-string orig))) + (ding) + nil) + ((eq completion t) orig) + ((and completion + (not (string= completion orig))) + (delete-region start (point)) + (insert completion) + (cond ((not (rng-completion-exact-p completion table predicate)) + (message "Incomplete") + nil) + ((eq (try-completion completion table predicate) t) + completion) + (t + (message "Complete but not unique") + nil))) + (t + (setq completion + (let ((saved-minibuffer-setup-hook + (default-value 'minibuffer-setup-hook))) + (add-hook 'minibuffer-setup-hook + 'minibuffer-completion-help + t) + (unwind-protect + (funcall completing-fun + prompt + table + predicate + nil + orig + hist) + (setq-default minibuffer-setup-hook + saved-minibuffer-setup-hook)))) + (when completion + (delete-region start (point)) + (insert completion)) + completion)))) + +(defun rngalt-get-missing-required-attr (single-tag) + "Get a list of missing required attributes. +This is to be used when completing attribute names. +SINGLE-TAG should be non-nil if the tag has no end tag. + +For a typical use see `nxhtml-completing-read-attribute-name' in +nxhtml.el. +" + ;; FIX-ME: This is a terrible cludge. One day I hope I will + ;; understand how to write this ;-) + ;; + ;; I currently fetch the missing tags from the error message in the + ;; error overlay set by rng validate. + (let ((here (point))) + (unless (save-match-data (looking-at "[^<]\\{,200\\}>")) + ;; We can probably add a >, so let us do it: + (when single-tag + (insert "/")) + (insert ">") + (rngalt-validate)) + (goto-char here)) + (let ((ovl (rng-error-overlay-message (or (rng-error-overlay-after (point)) + (rng-error-overlay-after (1- (point))))))) + ;;(message "ovl=%s" ovl)(sit-for 1) + ;;(message "prop ovl=%s" (overlay-properties ovl))(sit-for 1) + (when (and ovl + (eq (overlay-get ovl 'category) 'rng-error)) + ;;(message "rng-error")(sit-for 1) + (let ((msg (overlay-get ovl 'help-echo))) + ;;(message "msg=%s" msg);(sit-for 1) + (when (string-match "Missing attributes? \\(.*\\)" msg) + ;;(message "0=%s" (match-string 0 msg));(sit-for 1) + ;;(message "1=%s" (match-string 1 msg));(sit-for 1) + (let* ((matches (match-string 1 msg)) + (lst (split-string (substring matches 1 (- (length matches) 1)) "\", \""))) + ;;(message "matches=%s" matches);(sit-for 2) + ;;(message "lst=%s" lst);(sit-for 1) + lst)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Validation start state + +(defun rngalt-after-change-major () + (unless (and (boundp 'mumamo-set-major-running) + mumamo-set-major-running) + (setq rngalt-major-mode major-mode) + (when (and (derived-mode-p 'nxml-mode) + rngalt-validation-header) + (rngalt-reapply-validation-header)) + (rngalt-update-validation-header-overlay))) + +(defvar rngalt-validation-header-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'rngalt-minimal-validation-header-toggle) + map)) + +(defun rngalt-update-validation-header-overlay () + (if (and (boundp 'rngalt-display-validation-header) + rngalt-display-validation-header + rngalt-validation-header + (or (derived-mode-p 'nxml-mode) + (let ((major-mode rngalt-major-mode)) + (and major-mode + (derived-mode-p 'nxml-mode)))) + ) + (progn + (if rngalt-validation-header-overlay + (move-overlay rngalt-validation-header-overlay 1 1) + (setq rngalt-validation-header-overlay (make-overlay 1 1))) + (overlay-put rngalt-validation-header-overlay + 'priority 1000) + ;; Other properties should go to the 'before-string + (let* ((validation-header (nth 2 rngalt-validation-header)) + (header + (if rngalt-minimal-validation-header + (propertize + (concat + "*** Fictive XHTML/XML Validation Header: ... " + (save-match-data + (if (string-match "\\(<[^[:space:]>]+\\)[^>]*>[^<>]*\\'" + validation-header) + (concat (match-string 1 validation-header) ">") + "Error")) + "\n") + 'face 'rngalt-validation-header-bottom) + (concat + (propertize "*** Fictive XHTML/XML Validation Header:\n" + 'face 'rngalt-validation-header-top) + (propertize (concat validation-header "\n") + 'face 'rngalt-validation-header-bottom))))) + (setq header + (propertize + header + 'help-echo + "Click to toggle full/minimal display of header" + 'keymap rngalt-validation-header-keymap)) + (overlay-put rngalt-validation-header-overlay + 'before-string header))) + (when rngalt-validation-header-overlay + (delete-overlay rngalt-validation-header-overlay)))) + +(defun rngalt-update-validation-header-overlay-everywhere () + (dolist (b (buffer-list)) + (when (buffer-live-p b) + (with-current-buffer b + (when rngalt-validation-header + (rngalt-update-validation-header-overlay)))))) + +;; This is exactly the same as the original `rng-set-initial-state' +;; except when `rngalt-validation-header' is non-nil." +(defadvice rng-set-initial-state (around + rngalt-set-initial-state + activate + compile + ) + (nxml-ns-init) + (rng-match-start-document) + (setq rng-open-elements nil) + (setq rng-pending-contents nil) + (when rngalt-validation-header + (let ((state (car rngalt-validation-header))) + (rng-restore-state state))) + (setq ad-return-value (goto-char (point-min)))) + +;; (defun rng-new-validate-prepare () +;; "Prepare to do some validation, initializing point and the state. +;; Return t if there is work to do, nil otherwise. + +;; This is exactly the same as the original-insert-directory +;; `rng-validate-prepare' with the difference that the state at +;; point 1 is set differently if `rngalt-validation-header' is +;; non-nil. + +;; See also `rng-set-initial-state'." +;; (cond ((= rng-validate-up-to-date-end 1) +;; (rng-set-initial-state) +;; t) +;; ((= rng-validate-up-to-date-end (point-max)) +;; nil) +;; (t (let ((state +;; (if (and rngalt-validation-header +;; (= rng-validate-up-to-date-end 1)) +;; (car rngalt-validation-header) +;; (get-text-property (1- rng-validate-up-to-date-end) +;; 'rng-state)))) +;; (cond (state +;; (rng-restore-state state) +;; (goto-char rng-validate-up-to-date-end)) +;; (t +;; (let ((pos (previous-single-property-change +;; rng-validate-up-to-date-end +;; 'rng-state))) +;; (cond (pos +;; (rng-restore-state +;; (or (get-text-property (1- pos) 'rng-state) +;; (error "Internal error: state null"))) +;; (goto-char pos)) +;; (t (rng-set-initial-state)))))))))) + + +;; For as-external.el +;;;###autoload +(defun rngalt-set-validation-header (start-of-doc) + (let ((old-rvm rng-validate-mode)) + (when old-rvm (rng-validate-mode -1)) + (if start-of-doc + (progn + (add-hook 'after-change-major-mode-hook 'rngalt-after-change-major nil t) + (setq rngalt-validation-header (rngalt-get-state-after start-of-doc)) + (rng-set-schema-file-1 (cadr rngalt-validation-header)) + (setq rngalt-current-schema-file-name rng-current-schema-file-name) + (setq rng-compile-table nil) + (setq rng-ipattern-table nil) + (setq rng-last-ipattern-index nil)) + (remove-hook 'after-change-major-mode-hook 'rngalt-after-change-major t) + (setq rngalt-validation-header nil) + (when old-rvm + (rng-set-vacuous-schema) + (rng-auto-set-schema))) + (when old-rvm + (rng-validate-mode 1) + (rngalt-update-validation-header-overlay) + (rngalt-update-validation-header-buffer)))) + +(defun rngalt-reapply-validation-header () + (when rngalt-validation-header + (when (or (not rng-current-schema-file-name) + (unless (string= rngalt-current-schema-file-name rng-current-schema-file-name) + (lwarn 'schema-mismatch :warning + "XHTML validation header schema %s reapplied (replaces %s)" + (file-name-nondirectory rngalt-current-schema-file-name) + (file-name-nondirectory rng-current-schema-file-name)) + t)) + (rngalt-set-validation-header (nth 2 rngalt-validation-header))))) + +;; (defun rngalt-clear-validation-header () +;; "Remove XML validation header from current buffer. +;; For more information see `rngalt-show-validation-header'." +;; (interactive) +;; (rngalt-set-validation-header nil) +;; (rng-auto-set-schema t)) + +;; FIX-ME: Add edit header? + +(defun rngalt-get-validation-header-buffer () + (let ((b (get-buffer " *XML Validation Header*"))) + (unless b + (setq b (get-buffer-create " *XML Validation Header*")) + (with-current-buffer b + ;;(fundamental-mode) + (nxml-mode))) + b)) + +(defun rngalt-get-state-after (start-of-doc) + ;; FIX-ME: better buffer name? + (let ((statebuf (rngalt-get-validation-header-buffer))) + (with-current-buffer statebuf + (when rng-validate-mode (rng-validate-mode -1)) + (erase-buffer) + (insert start-of-doc) + ;; From rng-get-state + (setq rng-match-state nil) + (setq nxml-ns-state nil) + (setq rng-open-elements nil) + ;; From rng-match-init-buffer + (setq rng-compile-table nil) + (setq rng-ipattern-table nil) + (setq rng-last-ipattern-index nil) + + (nxml-mode) + (rng-validate-mode 1) + (rngalt-validate) + (let* ((state (rng-get-state)) + (cp-state (copy-tree state))) + ;;(if (equal state cp-state) (message "(equal state cp-state)=t") (message "(equal state cp-state)=nil")) + ;; Fix-me: is the copy-tree necessary here? + (list + cp-state + (rng-locate-schema-file) + start-of-doc))))) + +(defun rngalt-show-validation-header () + "Show XML validation header used in current buffer. +The XML validation header is used in `nxhtml-mode' to set a state +for XML validation at the start of the buffer. + +The purpose is to make it possible to use `nxml-mode' completion +in buffers where you do not actually have a full XML file. This +could for example be a buffer with PHP code or a buffer with a +blog entry. + +More techhnical info: This can be used by any mode derived from +`nxml-mode'. To use it in other modes than `nxhtml-mode' replace +`rng-complete' by `rngalt-complete' in `nxml-completion-hook'." + (interactive) + (unless (derived-mode-p 'nxml-mode) + (error "Buffer mode is not an nXml type major mode: %s" major-mode)) + (rngalt-update-validation-header-buffer) + (display-buffer (rngalt-get-validation-header-buffer) t)) + +(defun rngalt-update-validation-header-buffer () + (let ((vh (nth 2 rngalt-validation-header)) + (cb (current-buffer))) + (with-current-buffer (rngalt-get-validation-header-buffer) + (erase-buffer) + (if (not vh) + (setq header-line-format (concat " No XML validation header in buffer " + (buffer-name cb))) + (insert vh) + (setq header-line-format (concat " XML validation header in buffer " + (buffer-name cb))))))) + +;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + +(provide 'rngalt) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rngalt.el ends here |