emacs/nxhtml/nxhtml/nxml-where.el

   1 ;;; nxml-where.el --- Show XML path
   2 ;;
   3 ;; Author: Lennart Borgman
   4 ;; Maintainer:
   5 ;; Created: Tue Dec 19 14:59:01 2006
   6 (defconst nxml-where:version "0.52");; Version:
   7 ;; Lxast-Updated: Thu Mar 01 23:16:35 2007 (3600 +0100)
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   `cl'.
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;;
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or modify
  29 ;; it under the terms of the GNU General Public License as published by
  30 ;; the Free Software Foundation; either version 2, or (at your option)
  31 ;; any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36 ;; GNU General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to the
  40 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  41 ;; Boston, MA 02111-1307, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 ;; This buffer is for notes you don't want to save, and for Lisp evaluation.
  48 ;; If you want to create a file, visit that file with C-x C-f,
  49 ;; then enter the text in that file's own buffer.
  50
  51 (eval-when-compile (require 'cl))
  52 (eval-when-compile (require 'mumamo nil t))
  53 (eval-when-compile (require 'nxml-mode nil t))
  54 (eval-when-compile (require 'ourcomments-util nil t))
  55 ;; (eval-when-compile
  56 ;;   (unless (featurep 'nxhtml-autostart)
  57 ;;     (let ((efn (expand-file-name "../autostart.el")))
  58 ;;       (load efn))
  59 ;;     (require 'nxml-mode)))
  60
  61 (defun nxml-where-error-message (format-string &rest args)
  62   (with-current-buffer (get-buffer-create "*Messages*")
  63     (let ((start (1+ (point-max))))
  64       (apply 'message format-string args)
  65       (goto-char (point-max))
  66       (backward-char)
  67       ;; fix-me: got some error here:
  68       ;;(put-text-property start (point) 'face 'highlight)
  69       )))
  70
  71 (defvar nxml-where-last-point nil
  72   "Where point was last time marking finished.
  73 Ie we should not restart marking if point is still there and no
  74 changes have occured.")
  75 (make-variable-buffer-local 'nxml-where-last-point)
  76 (put 'nxml-where-last-point 'permanent-local t)
  77
  78 (defvar nxml-where-last-finished nil
  79   "Non-nil then marking is finished.")
  80 (make-variable-buffer-local 'nxml-where-last-finished)
  81 (put 'nxml-where-last-finished 'permanent-local t)
  82
  83 (defvar nxml-where-last-added nil)
  84 (make-variable-buffer-local 'nxml-where-last-added)
  85 (put 'nxml-where-last-added 'permanent-local t)
  86
  87 (defvar nxml-where-path nil
  88   "The current where path.
  89 This is a list where the records have the form
  90
  91    \(START END TAG-STR OVERLAY)")
  92 (make-variable-buffer-local 'nxml-where-path)
  93 (put 'nxml-where-path 'permanent-local t)
  94
  95 (defvar nxml-where-new-path nil
  96   "The new where path.
  97 This is a list where the records have the form
  98
  99    \(START END TAG-STR OVERLAY)")
 100 (make-variable-buffer-local 'nxml-where-new-path)
 101 (put 'nxml-where-new-path 'permanent-local t)
 102
 103 (defvar nxml-where-once-update-timer nil)
 104 (make-variable-buffer-local 'nxml-where-once-update-timer)
 105 (put 'nxml-where-once-update-timer 'permanent-local t)
 106
 107
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109 ;;; Custom options
 110
 111 ;;;###autoload
 112 (defgroup nxml-where nil
 113   "Customization group for nxml-where."
 114   :group 'nxhtml
 115   :group 'nxml)
 116
 117 ;;(define-toggle nxml-where-only-inner nil
 118 (define-minor-mode nxml-where-only-inner
 119   "Mark only inner-most tag."
 120   :global t
 121   :group 'nxml-where
 122   (when (fboundp 'nxml-where-update-buffers)
 123     (nxml-where-update-buffers)))
 124
 125 (defun nxml-where-only-inner-toggle ()
 126   "Toggle `nxml-where-only-inner'."
 127   (interactive)
 128   (nxml-where-only-inner (if nxml-where-only-inner -1 1)))
 129
 130 ;;(define-toggle nxml-where-header t
 131 (define-minor-mode nxml-where-header
 132   "Show header with XML-path if non-nil."
 133   :global t
 134   :init-value t
 135   :group 'nxml-where
 136   (when (fboundp 'nxml-where-update-buffers)
 137     (nxml-where-update-buffers)))
 138
 139 (defun nxml-where-header-toggle ()
 140   "Toggle `nxml-where-header'."
 141   (interactive)
 142   (nxml-where-header (if nxml-where-header -1 1)))
 143
 144 ;;(define-toggle nxml-where-tag+id t
 145 (define-minor-mode nxml-where-tag+id
 146   "Show tags + id in path if non-nil.
 147 If nil show only tag names."
 148   :global t
 149   :init-value t
 150   :group 'nxml-where
 151   (when (fboundp 'nxml-where-update-buffers)
 152     (nxml-where-update-buffers)))
 153
 154 (defun nxml-where-tag+id-toggle ()
 155   "Toggle `nxml-where-tag+id'."
 156   (interactive)
 157   (nxml-where-tag+id (if nxml-where-tag+id -1 1)))
 158
 159 ;;(define-toggle nxml-where-marks t
 160 (define-minor-mode nxml-where-marks
 161   "Show marks in buffer for XML-path if non-nil."
 162   :global t
 163   :init-value t
 164   :group 'nxml-where
 165   (when (fboundp 'nxml-where-update-buffers)
 166     (nxml-where-update-buffers)))
 167
 168 (defun nxml-where-marks-toggle ()
 169   "Toggle `nxml-where-marks'."
 170   (interactive)
 171   (nxml-where-marks (if nxml-where-marks -1 1)))
 172
 173 ;; Fix-me: implement this?
 174 ;; (define-toggle nxml-where-only-tags-with-id t
 175 ;;   "Show only tags with id in the header line."
 176 ;;   :set (lambda (sym val)
 177 ;;          (set-default sym val)
 178 ;;          (when (fboundp 'nxml-where-update-buffers)
 179 ;;            (nxml-where-update-buffers)))
 180 ;;   :group 'nxml-where)
 181
 182 (defface nxml-where-marking
 183   '((t (:inherit secondary-selection)))
 184   "The default face used for marking tags in path."
 185   :group 'nxml-where)
 186
 187 (defcustom nxml-where-marking 'nxml-where-marking
 188   "Variable pointing to the face used for marking tags in path."
 189   :type 'face
 190   :set (lambda (sym val)
 191          (set-default sym val)
 192          (when (fboundp 'nxml-where-update-buffers)
 193            (nxml-where-update-buffers)))
 194   :group 'nxml-where)
 195
 196 (defcustom nxml-where-header-attributes '("id" "name")
 197   "List of attributes `nxml-where-header' should display."
 198   :type '(repeat string)
 199   :set (lambda (sym val)
 200          (set-default sym val)
 201          (when (fboundp 'nxml-where-update-buffers)
 202            (nxml-where-update-buffers)))
 203   :group 'nxml-where)
 204
 205 (defcustom nxml-where-widen t
 206   "If non-nil and narrowed widen before getting XML path."
 207   :type 'boolean
 208   :group 'nxml-where)
 209
 210
 211
 212
 213
 214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 215 ;;; Modes
 216
 217 (defvar nxml-where-modes '(nxml-mode nxhtml-mode))
 218
 219 (defun nxml-where-is-nxml ()
 220   (or (derived-mode-p 'nxml-mode)
 221       (and (featurep 'mumamo)
 222            mumamo-multi-major-mode
 223            (let ((major-mode (mumamo-main-major-mode)))
 224              (derived-mode-p 'nxml-mode)))))
 225
 226 (defun nxml-where-setup-updating ()
 227   (nxml-where-clear-old-path 0 "setup")
 228   (setq nxml-where-last-added nil)
 229   (setq nxml-where-last-point nil)
 230   (when (and nxml-where-header
 231              (not nxml-where-only-inner))
 232     (setq header-line-format "Started nxml-where-mode ..."))
 233   ;;(nxml-where-restart-update)
 234   (add-hook 'post-command-hook 'nxml-where-restart-update nil t))
 235
 236 (defun nxml-where-mode-start ()
 237   ;;(message "START")
 238   (unless (nxml-where-is-nxml)
 239     (error "Can't display XML path since major mode is not nxml-mode child."))
 240   (add-hook 'after-change-major-mode-hook 'nxml-where-turn-off-unless-nxml nil t)
 241   (add-hook 'after-change-functions 'nxml-where-after-change nil t)
 242   (nxml-where-save-header-line-format)
 243   (nxml-where-setup-updating))
 244
 245 (defun nxml-where-mode-stop ()
 246   ;;(message "STOP")
 247   (remove-hook 'after-change-major-mode-hook 'nxml-where-turn-off-unless-nxml t)
 248   (remove-hook 'after-change-functions 'nxml-where-after-change t)
 249   (nxml-where-stop-updating)
 250   (nxml-where-unmark-forward-element)
 251   (nxml-where-restore-header-line-format)
 252   (nxml-where-clear-old-path 0 "stop"))
 253
 254 (defun nxml-where-turn-off-unless-nxml ()
 255   (unless (nxml-where-is-nxml)
 256     (nxml-where-mode-stop)))
 257 (put 'nxml-where-turn-off-unless-nxml 'permanent-local-hook t)
 258
 259 ;;;###autoload
 260 (define-minor-mode nxml-where-mode
 261   "Shows path in mode line."
 262   :global nil
 263   :group 'nxml-where
 264   (if nxml-where-mode
 265       ;;Turn it on
 266       (nxml-where-mode-start)
 267     ;; Turn it off
 268     (nxml-where-mode-stop)
 269     ))
 270 (put 'nxml-where-mode 'permanent-local t)
 271
 272 (defun nxml-where-turn-on-in-nxml-child ()
 273   "Turn on `nxml-where-mode' if possible.
 274 This is possible if `major-mode' in the buffer is derived from
 275 `nxml-mode'."
 276   (when (or (derived-mode-p 'nxml-mode)
 277             (and mumamo-multi-major-mode
 278                  (let ((major-mode (mumamo-main-major-mode)))
 279                    (derived-mode-p 'nxml-mode))))
 280     (unless nxml-where-mode
 281       (nxml-where-mode 1))))
 282
 283 ;;;###autoload
 284 (define-globalized-minor-mode nxml-where-global-mode nxml-where-mode
 285   nxml-where-turn-on-in-nxml-child
 286   :group 'nxml-where)
 287 ;; The problem with global minor modes:
 288 (when (and nxml-where-global-mode
 289            (not (boundp 'define-global-minor-mode-bug)))
 290   (nxml-where-global-mode 1))
 291
 292
 293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 294 ;;; Auto updating
 295
 296 (defvar nxhtml-where-hook nil
 297   "Normal hook run when marking has changed.")
 298
 299 (defun nxml-where-start-update-in-timer (buffer)
 300   "First checks post command."
 301   ;;(message "nxml-where-start-update buffer=%s (bufferp buffer)=%s" buffer (bufferp buffer))
 302   (when (and (bufferp buffer)
 303              (buffer-live-p buffer))
 304     (with-current-buffer buffer
 305       (let ((here (point)))
 306         (save-match-data
 307           (condition-case err
 308               (progn
 309                 ;;(unless nxml-where-marks (nxml-where-clear-old-path))
 310                 (unless (and nxml-where-header
 311                              (not nxml-where-only-inner))
 312                   (setq header-line-format nil))
 313                 (when (and nxml-where-mode
 314                            (or nxml-where-header nxml-where-marks))
 315                   (nxml-where-do-marking nil buffer)))
 316             (error
 317              (nxml-where-error-message
 318               "nxml-where-start-update-in-timer error: %s" err)))
 319           (goto-char here))))))
 320
 321 (defun nxml-where-continue-marking-in-timer (this-point buffer)
 322   "Continue unfinished marking after last restart.
 323 Ie we have run at least once post command."
 324   ;;(message "continue-marking-in-timer %s %s" this-point buffer)
 325   (with-current-buffer buffer
 326     (let ((here (point)))
 327       (condition-case err
 328           (save-match-data ;; runs in timer
 329             (nxml-where-do-marking this-point buffer))
 330         (error
 331          (nxml-where-error-message
 332           "nxml-where-do-marking error: %s"
 333           err)))
 334       (goto-char here))))
 335
 336 (defun nxml-where-start-continue-in-timer (next-point buffer)
 337   ;;(message "start second")
 338   (condition-case err
 339       (setq nxml-where-once-update-timer
 340             (run-with-idle-timer idle-update-delay
 341                                  nil
 342                                  'nxml-where-continue-marking-in-timer
 343                                  next-point
 344                                  buffer))
 345     (error
 346      (nxml-where-error-message
 347       "nxml-where-start-second error %s" err))))
 348
 349 (defun nxml-where-restart-update ()
 350   "Restart update, runs in `post-command-hook'."
 351   ;;(message "restart-update")
 352   (condition-case err
 353       (save-match-data ;; runs in timer
 354         (unless (and nxml-where-last-point
 355                      (= nxml-where-last-point (point)))
 356           (setq nxml-where-last-point nil)
 357           (setq nxml-where-last-finished nil)
 358           (nxml-where-cancel-once)
 359           (setq nxml-where-once-update-timer
 360                 (run-with-idle-timer
 361                  (* 0.2 idle-update-delay)
 362                  nil
 363                  'nxml-where-start-update-in-timer
 364                  (current-buffer)))))
 365     (error
 366      (nxml-where-error-message
 367       "%s" (error-message-string err)))))
 368 (put 'nxml-where-restart-update 'permanent-local-hook t)
 369
 370 (defvar nxml-where-first-change-pos nil)
 371 (make-variable-buffer-local 'nxml-where-first-change-pos)
 372 (put 'nxml-where-first-change-pos 'permanent-local t)
 373
 374 (defun nxml-where-after-change (beg end len)
 375   (setq nxml-where-last-point nil)
 376   (setq nxml-where-first-change-pos
 377         (min beg
 378              (or nxml-where-first-change-pos
 379                  beg))))
 380
 381 (defun nxml-where-cancel-once ()
 382   (when (timerp nxml-where-once-update-timer)
 383     (cancel-timer nxml-where-once-update-timer)
 384     (setq nxml-where-once-update-timer nil)))
 385
 386 (defun nxml-where-update-buffers ()
 387   (when (boundp 'nxml-where-mode)
 388     (dolist (buf (buffer-list))
 389       (with-current-buffer buf
 390         (when nxml-where-mode
 391           (nxml-where-mode -1)
 392           (nxml-where-mode 1))))))
 393
 394 (defun nxml-where-stop-updating ()
 395   (remove-hook 'post-command-hook 'nxml-where-restart-update t))
 396
 397
 398
 399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 400 ;;; Marking
 401
 402 (defconst nxml-where-get-id-pattern
 403   (rx-to-string
 404    `(and
 405      space
 406      ,(cons 'or nxml-where-header-attributes)
 407      (0+ space)
 408      ?=
 409      (0+ space)
 410      ?\"
 411      (0+ (not (any ?\")))
 412      ?\")
 413    t))
 414
 415 (defvar nxml-where-tag+id-pattern
 416   (rx ?<
 417       (submatch
 418        (1+ (char "-a-z0-9:"))
 419        )
 420       (0+ (1+ space)
 421           (1+ (any "a-z"))
 422           (0+ space)
 423           ?=
 424           (0+ space)
 425           ?\"
 426           (0+ (not (any ?\")))
 427           ?\"
 428           )
 429       (0+ space)
 430       (opt ?/)
 431       ?>))
 432
 433
 434 (defvar nxml-where-forward-element nil)
 435 (make-variable-buffer-local 'nxml-where-forward-element)
 436 (put 'nxml-where-forward-element 'permanent-local t)
 437
 438 (defun nxml-where-unmark-forward-element ()
 439   "Unmark currently marked end tag."
 440   (when nxml-where-forward-element
 441     (let* ((ovl (nth 1 nxml-where-forward-element))
 442            (str (when ovl (buffer-substring-no-properties (overlay-start ovl) (overlay-end ovl)))))
 443       (when (overlayp ovl)
 444         ;;(message "unmark-forward-element:delete-overlay %s %s" str ovl)
 445         (delete-overlay ovl)))
 446     (setq nxml-where-forward-element nil)))
 447
 448 (defun nxml-where-mark-forward-element (start-tag)
 449   "Mark the end tag matching START-TAG."
 450   ;;(message "nxml-where-forward-element=%s" nxml-where-forward-element)
 451   (unless (and start-tag
 452                nxml-where-forward-element
 453                (nth 1 nxml-where-forward-element)
 454                (= (nth 0 nxml-where-forward-element)
 455                   start-tag))
 456     ;;(message "before unmark")
 457     (nxml-where-unmark-forward-element)
 458     ;;(message "after unmark")
 459     (when start-tag
 460       (let ((here (point))
 461             (end-of-narrow
 462              (progn
 463                (goto-char start-tag)
 464                (line-end-position 4)))
 465             start end ovl)
 466         ;; Fix-me: Narrow how much?
 467         (setq end-of-narrow (max (+ 4000 (window-end))
 468                                  end-of-narrow))
 469         (setq end-of-narrow (min (point-max)
 470                                  end-of-narrow))
 471         (save-restriction
 472           (narrow-to-region start-tag end-of-narrow)
 473           (condition-case err
 474               (progn
 475                 (goto-char start-tag)
 476                 (nxml-forward-element)
 477                 (when (looking-back "</[a-z0-9]+>")
 478                   (setq start (match-beginning 0))
 479                   (setq end (point))
 480                   (setq ovl (make-overlay start end))
 481                   (overlay-put ovl 'nxml-where t)
 482                   (overlay-put ovl 'face nxml-where-marking)))
 483             (error
 484              (let ((msg (error-message-string err)))
 485                (unless (string= msg "Start-tag has no end-tag")
 486                  (message "nxml-where-mark-forw: %s" msg))))))
 487         (goto-char here)
 488         ;;(message "point 2 = %s" (point))
 489         (setq nxml-where-forward-element (list start-tag ovl))))))
 490
 491
 492 (defun nxml-where-make-rec (tag-start tag-end tag-str buf)
 493   ;;(message "nxml-where-make-rec %s %s %s %s" tag-start tag-end tag-str buf)
 494   (let ((ovls (overlays-at tag-start))
 495         str)
 496     (dolist (ovl ovls)
 497       (when (overlay-get ovl 'nxml-where)
 498         (setq str (buffer-substring-no-properties (overlay-start ovl) (overlay-end ovl)))
 499         (message "==================================================")
 500         (nxml-where-error-message "old ovl=%s    %S" ovl str)
 501         (message "old: nxml-where-path=%s" nxml-where-path)
 502         (message "old: nxml-where-new-path=%s" nxml-where-new-path)
 503         )))
 504   (let ((ovl (when buf (make-overlay tag-start tag-end))))
 505     (when ovl
 506       (overlay-put ovl 'nxml-where t)
 507       (overlay-put ovl 'face nxml-where-marking))
 508     (list tag-start tag-end tag-str ovl)))
 509
 510 (defun nxml-where-delete-rec (rec from)
 511   (let* ((ovl (nth 3 rec))
 512          (str (when ovl
 513                 (buffer-substring-no-properties (overlay-start ovl) (overlay-end ovl)))))
 514     (when (and ovl (overlay-buffer ovl))
 515       (assert (overlayp ovl) t)
 516       ;;(message "delete-rec:delete-overlay %s %s (%s)" str ovl from)
 517       (delete-overlay ovl)
 518       ;;(message "after delete=%s" ovl)
 519       )))
 520
 521
 522 (defun nxml-where-clear-old-path (end-of-interest from)
 523   "Clear all marking below END-OF-INTEREST.
 524 Update `nxml-where-path accordingly."
 525   (setq nxml-where-last-added nil)
 526   ;;(message "++++++ clear A: %s (%s)" end-of-interest from)
 527   (setq nxml-where-path (cons 'dummy nxml-where-path))
 528   (let ((path nxml-where-path))
 529     ;;(message "path 1=%s" path)
 530     (while (cdr path)
 531       ;;(message "path 2=%s" path)
 532       (when (> (nth 1 (cadr path)) end-of-interest)
 533         (dolist (p (cdr path))
 534           (nxml-where-delete-rec p "clear"))
 535         (setcdr path nil))
 536       (setq path (cdr path))))
 537   (setq nxml-where-path (cdr nxml-where-path)))
 538
 539 (defun nxml-where-clear-new-path ()
 540   (dolist (new nxml-where-new-path)
 541     (nxml-where-delete-rec new "clear new"))
 542   (setq nxml-where-new-path nil)
 543   ;;(message "clear B:nxml-where-path=%s" nxml-where-path)
 544   )
 545
 546
 547 (defun nxml-where-update-where-path (tag-start tag-end tag-str buffer)
 548   "Update where path with given tag.
 549 The tag is between TAG-START and TAG-END and the string to
 550 display for it in the header-line is TAG-STR.  This is in buffer
 551 BUFFER."
 552   ;; Delete old marks below tag-start:
 553   (nxml-where-clear-old-path (+ tag-end 0) (format "update-where-path, tag-start=%s" tag-start))
 554   ;; Is this now the same as the old value?
 555   (let ((last-old (last nxml-where-path))
 556         new-rec
 557         result)
 558     ;;(message "update: %s %s %s %s, last-old=%s" tag-start tag-end tag-str buffer last-old)
 559     (if (and last-old
 560              (= tag-start (nth 0 (car last-old)))
 561              (= tag-end   (nth 1 (car last-old))))
 562         (progn
 563           (setq result 'ready))
 564       (when nxml-where-only-inner
 565         ;;(message "last-old=%S, nwp=%S, nwnp=%S" last-old nxml-where-path nxml-where-new-path)
 566         (setq last-old (car (last nxml-where-path)))
 567         (when last-old
 568           (setq nxml-where-path nil)
 569           (nxml-where-delete-rec last-old "only-inner")))
 570       (setq new-rec (nxml-where-make-rec tag-start tag-end tag-str buffer))
 571       (setq nxml-where-last-added new-rec)
 572       (setq nxml-where-new-path (cons new-rec nxml-where-new-path))
 573       (setq result 'continue))
 574     result))
 575
 576 (defun nxml-where-do-marking (this-point buffer)
 577   "Do marking.
 578 If THIS-POINT is nil then it is the first marking post command in
 579 buffer BUFFER.  In that case start from current point, otherwise
 580 from THIS-POINT.
 581
 582 Go up to previous tag.  Then check if this is the same tag where
 583 we started last time and ran to completion.  If so just finish.
 584
 585 Otherwise check this tag.  If not ready after that then restart
 586 this command with arg THIS-POINT set to right before this tag."
 587   ;;(message "****************nxml-where-do-marking %s %s, point=%s" this-point buffer (point))
 588   (when (buffer-live-p buffer)
 589     (with-current-buffer buffer
 590       (save-restriction
 591         (when nxml-where-widen (widen))
 592         (let ((here (point))
 593               next-point
 594               (is-first (not this-point))
 595               (end-of-interest (if nxml-where-first-change-pos
 596                                    (min (point) nxml-where-first-change-pos)
 597                                  ;; Check for tag at point
 598                                  (catch 'eoi
 599                                    (let (ovl)
 600                                      (dolist (ovl (overlays-at (point)))
 601                                        (when (overlay-get ovl 'nxml-where)
 602                                          (throw 'eoi (overlay-end ovl)))))
 603                                    (point)))))
 604           ;; If on beginning of tag step forward one char.
 605           (unless (or (eobp)
 606                       this-point
 607                       (not (eq  ?< (char-after))))
 608             (forward-char))
 609           (when this-point (goto-char this-point))
 610           (setq next-point
 611                 (catch 'cnext-point
 612                   (progn
 613                     (condition-case err
 614                         (nxml-backward-up-element)
 615                       (error
 616                        (if (equal err '(error "No parent element"))
 617                            (let (rec)
 618                              ;;(message "------------ No parent element")
 619                              (dolist (rec nxml-where-path)
 620                                (nxml-where-delete-rec rec "no parent"))
 621                              (setq nxml-where-path nil)
 622                              (throw 'cnext-point nil)) ;; <---- remember...
 623                          (nxml-where-error-message "nxml-where error: %S" err)
 624                          (throw 'cnext-point "uh?"))))
 625                     ;; Is this the first call
 626                     ;;(message ";; Is this the first call, %s" is-first)
 627                     (when is-first
 628                       (when (and nxml-where-path
 629                                  nxml-where-last-finished
 630                                  (= (point) (caar (last nxml-where-path))))
 631                         (throw 'cnext-point 'same-as-last))
 632                       ;;(setq nxml-where-new-path nil)
 633                       (setq nxml-where-last-added nil)
 634                       ;; Delete those parts we can't trust or don't
 635                       ;; need any more. Fix-me, Note: this is different
 636                       ;; dependent on if some buffer changes occured.
 637                       (nxml-where-clear-old-path end-of-interest (format "is-first,p=%s" (point)))
 638                       (nxml-where-clear-new-path))
 639                     ;;(message "looking-at")
 640                     (when (looking-at nxml-where-tag+id-pattern)
 641                       (let ((start (point))
 642                             (end (match-end 0))
 643                             (tag (match-string-no-properties 1))
 644                             (all (match-string-no-properties 0)))
 645                         (when nxml-where-tag+id
 646                           (when (string-match nxml-where-get-id-pattern all)
 647                             (setq tag (concat tag (match-string 0 all)))))
 648                         (setq tag (concat "<" tag ">"))
 649                         (when (or (eq 'ready
 650                                       (nxml-where-update-where-path start end tag t))
 651                                   nxml-where-only-inner)
 652                           ;;(message "throw 'cp nil")
 653                           (throw 'cnext-point nil))))
 654                     (throw 'cnext-point (max (1- (point)) (point-min))))))
 655           (goto-char here)
 656           (if next-point
 657               (cond
 658                ((stringp next-point) (message "%s" next-point) ;; Some error
 659                 (when nxml-where-header (setq header-line-format next-point)))
 660                ((eq 'same-as-last next-point)
 661                 nil)
 662                (t
 663                 (unless nxml-where-only-inner
 664                   (setq nxml-where-once-update-timer
 665                         (run-with-timer (* 0.2 idle-update-delay)
 666                                         nil
 667                                         'nxml-where-start-continue-in-timer
 668                                         next-point (current-buffer))))))
 669             (if nxml-where-path
 670                 (setcdr (last nxml-where-path) nxml-where-new-path)
 671               (setq nxml-where-path nxml-where-new-path))
 672             (setq nxml-where-new-path nil)
 673             ;;(message "nxml-where-path=%s" nxml-where-path)
 674             (nxml-where-mark-forward-element (caar (last nxml-where-path)))
 675             (setq nxml-where-last-finished t)
 676             (setq nxml-where-first-change-pos nil)
 677             (run-hooks 'nxhtml-where-hook)
 678             (setq nxml-where-last-point (point))
 679             (when (and nxml-where-header
 680                        (not nxml-where-only-inner))
 681               (nxml-where-insert-header))))))))
 682
 683
 684
 685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 686 ;;; Header path
 687
 688 (defun nxml-where-insert-header ()
 689   (let ((path (mapcar (lambda (elt)
 690                         (nth 2 elt))
 691                       nxml-where-path)))
 692     (unless path
 693       (setq path (list (if (looking-at "[[:space:]]*\\'")
 694                            "(After last tag)"
 695                          "(Before first tag)"))))
 696     (if (null path)
 697         (setq path " *Error* ")
 698       ;; Throw away <html>
 699       (let* ((first (car path))
 700              (html "<html")
 701              (hlen (length html)))
 702         (when (and (> (length first) hlen)
 703                    (string= html (substring first 0 hlen)))
 704           (setq path (cdr path))))
 705       (unless path
 706         (setq path (list "(At html start)"))))
 707     (let* ((sp (substring (format "%s" path) 1 -1))
 708            (label " Path: ")
 709            (totlen (+ (length sp) (length label)))
 710            header)
 711       (when (> totlen (window-width))
 712         (setq sp (concat "... "
 713                          (substring sp (+ (- totlen (window-width))
 714                                           4)))))
 715       (setq header (concat label sp))
 716       (when nxml-where-header
 717         (setq header-line-format header)))))
 718
 719 (defvar nxml-where-saved-header-line-format nil)
 720 (make-variable-buffer-local 'nxml-where-saved-header-line-format)
 721 (put 'nxml-where-saved-header-line-format 'permanent-local t)
 722
 723 (defun nxml-where-save-header-line-format ()
 724   (unless nxml-where-saved-header-line-format
 725     (setq nxml-where-saved-header-line-format header-line-format)))
 726
 727 (defun nxml-where-restore-header-line-format ()
 728   (setq header-line-format nxml-where-saved-header-line-format))
 729
 730
 731
 732 (provide 'nxml-where)
 733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 734 ;;; nxml-where.el ends here