nxhtml/nxhtml/rngalt.el

   1 ;;; rngalt.el --- Tools for making completion addition to nxml mode
   2 ;;
   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
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  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',
  15 ;;   `xmltok'.
  16 ;;
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;;
  19 ;;; Commentary:
  20 ;;
  21 ;;
  22 ;;
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;;
  25 ;;; Change log:
  26 ;;
  27 ;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;
  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)
  33 ;; any later version.
  34 ;;
  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.
  39 ;;
  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.
  44 ;;
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46 ;;
  47 ;;; Code:
  48
  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)))
  52
  53 (eval-when-compile
  54   (let* ((this-file (or load-file-name
  55                         (when (boundp 'bytecomp-filename) bytecomp-filename)
  56                         buffer-file-name))
  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)
  62
  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'."
  71   :global t
  72   :init-value t
  73   :group 'relax-ng
  74   :group 'nxhtml
  75   (when (fboundp 'rngalt-update-validation-header-overlay-everywhere)
  76     (rngalt-update-validation-header-overlay-everywhere)))
  77
  78 (defun rngalt-display-validation-header-toggle ()
  79   "Toggle `rngalt-display-validation-header'."
  80   (interactive)
  81   (rngalt-display-validation-header (if rngalt-display-validation-header -1 1)))
  82
  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'."
  87   :global t
  88   :init-value t
  89   :group 'relax-ng
  90   :group 'nxhtml
  91   (when (fboundp 'rngalt-update-validation-header-overlay-everywhere)
  92     (rngalt-update-validation-header-overlay-everywhere)))
  93
  94 (defun rngalt-minimal-validation-header-toggle ()
  95   "Toggle `rngalt-minimal-validation-header'."
  96   (interactive)
  97   (rngalt-minimal-validation-header (if rngalt-minimal-validation-header -1 1)))
  98
  99 (defface rngalt-validation-header-top
 100   '((t (:foreground "RGB:87/CE/FA" :background "white")))
 101   "Face first line of validation header."
 102   :group 'nxhtml)
 103
 104 (defface rngalt-validation-header-bottom
 105   '((t (:foreground "white" :background "RGB:87/CE/FA")))
 106   "Face first line of validation header."
 107   :group 'nxhtml)
 108
 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)
 113
 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)
 117
 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)
 121
 122 (defvar rngalt-major-mode nil)
 123 (make-variable-buffer-local 'rngalt-major-mode)
 124 (put 'rngalt-major-mode 'permanent-local t)
 125
 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
 129 `rngalt-complete'.")
 130
 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
 134 `rngalt-complete'.")
 135
 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'.")
 140
 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'.")
 145
 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'.")
 150
 151
 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'
 155 into account."
 156   (interactive "*")
 157   (rngalt-finish-element-1 nil))
 158
 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.
 166
 167 This is like `nxml-finish-element-1' but takes
 168 `rngalt-validation-header' into account."
 169   (interactive "*")
 170   (let (token-end
 171         start-tag-end
 172         starts-line
 173         ends-line
 174         start-tag-indent
 175         qname
 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)
 183           (save-restriction
 184             (widen)
 185             (goto-char (point-min))
 186             (insert vh)))
 187         (goto-char here))
 188       (setq token-end (nxml-token-before))
 189       (setq start-tag-end
 190             (save-excursion
 191               (when (and (< (point) token-end)
 192                          (memq xmltok-type
 193                                '(cdata-section
 194                                  processing-instruction
 195                                  comment
 196                                  start-tag
 197                                  end-tag
 198                                  empty-element)))
 199                 (error "Point is inside a %s"
 200                        (nxml-token-type-friendly-name xmltok-type)))
 201               (nxml-scan-element-backward token-end t)))
 202       (when start-tag-end
 203         (setq starts-line
 204               (save-excursion
 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)))
 210         (setq ends-line
 211               (save-excursion
 212                 (goto-char start-tag-end)
 213                 (looking-at "[ \t\r\n]*$")))
 214         (setq start-tag-indent (save-excursion
 215                                  (goto-char xmltok-start)
 216                                  (current-column)))
 217         (setq qname (xmltok-start-tag-qname)))
 218
 219       ;; Undo the insertion of the fictive header:
 220       (undo-start)
 221       (while (and (not (eq t pending-undo-list))
 222                   pending-undo-list)
 223         (undo-more 1))
 224       (goto-char here))
 225
 226     (unless start-tag-end (error "No more start tags"))
 227
 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
 231       (unless (<= (point)
 232                   (save-excursion
 233                     (back-to-indentation)
 234                     (point)))
 235         (insert "\n"))
 236       (indent-line-to start-tag-indent))
 237     (insert "</" qname ">")
 238     (when startp
 239       (when starts-line
 240         (insert "\n")
 241         (indent-line-to start-tag-indent))
 242       (setq inserted-start-tag-pos (point))
 243       (insert "<" qname ">")
 244       (when (and starts-line ends-line)
 245         (insert "\n")
 246         (indent-line-to (save-excursion
 247                           (goto-char xmltok-start)
 248                           (forward-line 1)
 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))
 255
 256 (defun rngalt-complete ()
 257   "Complete the string before point using the current schema.
 258 Return non-nil if in a context it understands.
 259
 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'."
 267   (interactive)
 268   (unless rng-validate-mode
 269     (when (y-or-n-p
 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
 276       (rngalt-validate))
 277     (or (when rngalt-complete-first-try
 278           (funcall rngalt-complete-first-try))
 279         (progn
 280           (unless rng-current-schema-file-name
 281             (when (eq major-mode 'nxhtml-mode)
 282               (when (y-or-n-p
 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
 288 will work.
 289
 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)
 293                 )))
 294           (let ((lt-pos (save-excursion (search-backward "<" nil t)))
 295                 xmltok-dtd)
 296             (or (and lt-pos
 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))))))))
 304
 305 (defun rngalt-validate ()
 306   (unless (= (buffer-size) 0)
 307     (let ((while-n1 0)
 308           (maxn1 20))
 309       (condition-case err
 310           (while (and (> maxn1 (setq while-n1 (1+ while-n1)))
 311                       (rng-do-some-validation))
 312             nil)
 313         (error
 314          ;; FIX-ME: for debugging:
 315          ;;(lwarn 'rngalt-validate :error "%s" (error-message-string err))
 316          (message "rngalt-validate: %s" (error-message-string err))
 317          nil))
 318       (when (>= while-n1 maxn1)
 319         (error "rngalt-validate: Could not validate")))
 320     (rng-validate-done)))
 321
 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
 331                transient-mark-mode)
 332       (let ((beginning (region-beginning))
 333             (end       (region-end)))
 334         (unless (= (point) (region-beginning))
 335           (goto-char beginning))
 336         (when (save-excursion
 337                 (when (re-search-forward "\\=[^<]*\\(?:<[^<]*>\\)*[^>]*" end t)
 338                   (= end (point))))
 339           (setq rngalt-region-ovl (make-overlay beginning end))
 340           (overlay-put rngalt-region-ovl 'face 'region)
 341           )))
 342     (setq rngalt-region-prepared t)))
 343
 344 (defun rngalt-complete-tag-region-cleanup ()
 345   (when rngalt-region-prepared
 346     (when (overlayp rngalt-region-ovl)
 347       (delete-overlay rngalt-region-ovl))
 348     (deactivate-mark)
 349     (setq rngalt-region-prepared nil)))
 350
 351 (defun rngalt-complete-tag-region-finish ()
 352   (when (and rngalt-region-prepared
 353              (overlayp rngalt-region-ovl))
 354     (let ((here (point)))
 355       (insert ">")
 356       (goto-char (overlay-end rngalt-region-ovl))
 357       (nxml-finish-element)
 358       (rngalt-validate)
 359       (goto-char here)))
 360   (rngalt-complete-tag-region-cleanup))
 361
 362 (defun rngalt-complete-tag (lt-pos)
 363   "Like `rng-complete-tag' but with some additions.
 364 The additions are:
 365 - Alternate completion.
 366 - Complete around highlighted region.
 367
 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-<
 372                rng-open-elements
 373                (not (eq (car rng-open-elements) t))
 374                (or rng-collecting-text
 375                    (rng-match-save
 376                      (rng-match-end-tag))))
 377       (setq rng-complete-extra-strings
 378             (cons (concat "/"
 379                           (if (caar rng-open-elements)
 380                               (concat (caar rng-open-elements)
 381                                       ":"
 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
 387                                 lt-pos
 388                                 t))
 389       (and rng-collecting-text (rng-flush-text))
 390       (rngalt-complete-tag-region-prepare)
 391       (let ((completion
 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
 397                                              "Insert tag: "
 398                                              nil
 399                                              'rng-tag-history
 400                                              rngalt-completing-read-tag)))
 401             name)
 402         (when completion
 403           (cond ((rng-qname-p completion)
 404                  (setq name (rng-expand-qname completion
 405                                               t
 406                                               'rng-start-tag-expand-recover))
 407                  (when (and name
 408                             (rng-match-start-tag-open name)
 409                             (or (not (rng-match-start-tag-close))
 410                                 ;; need a namespace decl on the root element
 411                                 (and (car name)
 412                                      (not rng-open-elements))))
 413                    ;; attributes are required
 414                    (insert " "))
 415                  (rngalt-complete-tag-region-finish)
 416                  (run-hook-with-args 'rngalt-complete-tag-hooks completion)
 417                  )
 418                 ((member completion rng-complete-extra-strings)
 419                  (insert ">")))))
 420       (rngalt-complete-tag-region-finish)
 421       t)))
 422
 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
 426 completed.")
 427
 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
 436                                            attribute-start)
 437            (let ((rng-complete-target-names
 438                   (rng-match-possible-attribute-names))
 439                  (rng-complete-extra-strings
 440                   (mapcar (lambda (prefix)
 441                             (if prefix
 442                                 (concat "xmlns:" prefix)
 443                               "xmlns"))
 444                           rng-undeclared-prefixes))
 445                  (rng-complete-name-attribute-flag t)
 446                  completion)
 447              (setq completion
 448                    (rngalt-complete-before-point attribute-start
 449                                                  'rng-complete-qname-function
 450                                                  "Attribute: "
 451                                                  nil
 452                                                  'rng-attribute-name-history
 453                                                  rngalt-completing-read-attribute-name))
 454              (when (and completion
 455                         (< 0 (length completion)))
 456                (insert "=\"")))))
 457     t))
 458
 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
 469                                            name-start)
 470            (if (string= (buffer-substring-no-properties name-start
 471                                                         (or colon name-end))
 472                         "xmlns")
 473                (rngalt-complete-before-point
 474                 value-start
 475                 (rng-strings-to-completion-alist
 476                  (rng-possible-namespace-uris
 477                   (and colon
 478                        (buffer-substring-no-properties (1+ colon) name-end))))
 479                 "Namespace URI: "
 480                 nil
 481                 'rng-namespace-uri-history
 482                 rngalt-completing-read-attribute-value) ;; fix-me
 483              (rng-adjust-state-for-attribute-value name-start
 484                                                    colon
 485                                                    name-end)
 486              (rngalt-complete-before-point
 487               value-start
 488               (rng-strings-to-completion-alist
 489                (rng-match-possible-value-strings))
 490               "Value: "
 491               nil
 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)))))
 496     t))
 497
 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)))
 512            (ding)
 513            nil)
 514           ((eq completion t) orig)
 515           ((and completion
 516                 (not (string= completion orig)))
 517            (delete-region start (point))
 518            (insert completion)
 519            (cond ((not (rng-completion-exact-p completion table predicate))
 520                   (message "Incomplete")
 521                   nil)
 522                  ((eq (try-completion completion table predicate) t)
 523                   completion)
 524                  (t
 525                   (message "Complete but not unique")
 526                   nil)))
 527           (t
 528            (setq completion
 529                  (let ((saved-minibuffer-setup-hook
 530                         (default-value 'minibuffer-setup-hook)))
 531                    (add-hook 'minibuffer-setup-hook
 532                              'minibuffer-completion-help
 533                              t)
 534                    (unwind-protect
 535                        (funcall completing-fun
 536                                 prompt
 537                                 table
 538                                 predicate
 539                                 nil
 540                                 orig
 541                                 hist)
 542                      (setq-default minibuffer-setup-hook
 543                                    saved-minibuffer-setup-hook))))
 544            (when completion
 545              (delete-region start (point))
 546              (insert completion))
 547            completion))))
 548
 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.
 553
 554 For a typical use see `nxhtml-completing-read-attribute-name' in
 555 nxhtml.el.
 556 "
 557   ;; FIX-ME: This is a terrible cludge. One day I hope I will
 558   ;; understand how to write this ;-)
 559   ;;
 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:
 565       (when single-tag
 566         (insert "/"))
 567       (insert ">")
 568       (rngalt-validate))
 569     (goto-char here))
 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)
 574     (when (and ovl
 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)
 586             lst))))))
 587
 588
 589 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 590 ;;; Validation start state
 591
 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)))
 600
 601 (defvar rngalt-validation-header-keymap
 602   (let ((map (make-sparse-keymap)))
 603     (define-key map [mouse-1] 'rngalt-minimal-validation-header-toggle)
 604     map))
 605
 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))
 612                  (and major-mode
 613                       (derived-mode-p 'nxml-mode))))
 614            )
 615       (progn
 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
 620                      'priority 1000)
 621         ;; Other properties should go to the 'before-string
 622         (let* ((validation-header (nth 2 rngalt-validation-header))
 623                (header
 624                (if rngalt-minimal-validation-header
 625                    (propertize
 626                     (concat
 627                      "*** Fictive XHTML/XML Validation Header: ... "
 628                      (save-match-data
 629                        (if (string-match "\\(<[^[:space:]>]+\\)[^>]*>[^<>]*\\'"
 630                                          validation-header)
 631                            (concat (match-string 1 validation-header) ">")
 632                          "Error"))
 633                      "\n")
 634                     'face 'rngalt-validation-header-bottom)
 635                  (concat
 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)))))
 640           (setq header
 641                 (propertize
 642                  header
 643                  'help-echo
 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))))
 650
 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))))))
 657
 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
 662                                   activate
 663                                   compile
 664                                   )
 665   (nxml-ns-init)
 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))))
 673
 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.
 677
 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
 681 ;; non-nil.
 682
 683 ;; See also `rng-set-initial-state'."
 684 ;;   (cond ((= rng-validate-up-to-date-end 1)
 685 ;;          (rng-set-initial-state)
 686 ;;       t)
 687 ;;      ((= rng-validate-up-to-date-end (point-max))
 688 ;;       nil)
 689 ;;      (t (let ((state
 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)
 694 ;;                                        'rng-state))))
 695 ;;              (cond (state
 696 ;;                  (rng-restore-state state)
 697 ;;                  (goto-char rng-validate-up-to-date-end))
 698 ;;                 (t
 699 ;;                  (let ((pos (previous-single-property-change
 700 ;;                              rng-validate-up-to-date-end
 701 ;;                              'rng-state)))
 702 ;;                    (cond (pos
 703 ;;                           (rng-restore-state
 704 ;;                            (or (get-text-property (1- pos) 'rng-state)
 705 ;;                                (error "Internal error: state null")))
 706 ;;                           (goto-char pos))
 707 ;;                          (t (rng-set-initial-state))))))))))
 708
 709
 710 ;; For as-external.el
 711 ;;;###autoload
 712 (defun rngalt-set-validation-header (start-of-doc)
 713   (let ((old-rvm rng-validate-mode))
 714     (when old-rvm (rng-validate-mode -1))
 715     (if start-of-doc
 716         (progn
 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)
 726       (when old-rvm
 727         (rng-set-vacuous-schema)
 728         (rng-auto-set-schema)))
 729     (when old-rvm
 730       (rng-validate-mode 1)
 731       (rngalt-update-validation-header-overlay)
 732       (rngalt-update-validation-header-buffer))))
 733
 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))
 742                 t))
 743       (rngalt-set-validation-header (nth 2 rngalt-validation-header)))))
 744
 745 ;; (defun rngalt-clear-validation-header ()
 746 ;;   "Remove XML validation header from current buffer.
 747 ;; For more information see `rngalt-show-validation-header'."
 748 ;;   (interactive)
 749 ;;   (rngalt-set-validation-header nil)
 750 ;;   (rng-auto-set-schema t))
 751
 752 ;; FIX-ME: Add edit header?
 753
 754 (defun rngalt-get-validation-header-buffer ()
 755   (let ((b (get-buffer " *XML Validation Header*")))
 756     (unless b
 757       (setq b (get-buffer-create " *XML Validation Header*"))
 758       (with-current-buffer b
 759         ;;(fundamental-mode)
 760         (nxml-mode)))
 761     b))
 762
 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))
 768       (erase-buffer)
 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)
 778
 779       (nxml-mode)
 780       (rng-validate-mode 1)
 781       (rngalt-validate)
 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?
 786         (list
 787          cp-state
 788          (rng-locate-schema-file)
 789          start-of-doc)))))
 790
 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.
 795
 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
 799 blog entry.
 800
 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'."
 804   (interactive)
 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))
 809
 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)
 814       (erase-buffer)
 815       (if (not vh)
 816           (setq header-line-format (concat " No XML validation header in buffer "
 817                                            (buffer-name cb)))
 818         (insert vh)
 819         (setq header-line-format (concat " XML validation header in buffer "
 820                                          (buffer-name cb)))))))
 821
 822 ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 823
 824
 825
 826 (provide 'rngalt)
 827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 828 ;;; rngalt.el ends here