cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-motion.el

   1 ;;; vm-motion.el --- Commands to move around in a VM folder
   2 ;;
   3 ;; Copyright (C) 1989-1997 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defun vm-record-and-change-message-pointer (old new)
  22   (intern (buffer-name) vm-buffers-needing-display-update)
  23   (vm-garbage-collect-message)
  24   (setq vm-last-message-pointer old
  25         vm-message-pointer new
  26         vm-need-summary-pointer-update t))
  27
  28 ;;;###autoload
  29 (defun vm-goto-message (n)
  30   "Go to the message numbered N.
  31 Interactively N is the prefix argument.  If no prefix arg is provided
  32 N is prompted for in the minibuffer.
  33
  34 If vm-follow-summary-cursor is non-nil this command will go to
  35 the message under the cursor in the summary buffer if the summary
  36 window is selected.  This only happens if no prefix argument is
  37 given."
  38   (interactive
  39    (list
  40     (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg))
  41           ((vm-follow-summary-cursor) nil)
  42           ((vm-follow-folders-summary-cursor) nil)
  43           (t
  44            (let ((last-command last-command)
  45                  (this-command this-command))
  46              (vm-read-number "Go to message: "))))))
  47   (if (null n)
  48       ()                                ; nil means work has been done already
  49     (vm-select-folder-buffer)
  50     (vm-check-for-killed-summary)
  51     (vm-error-if-folder-empty)
  52     (vm-display nil nil '(vm-goto-message) '(vm-goto-message))
  53     (let ((cons (nthcdr (1- n) vm-message-list)))
  54       (if (null cons)
  55           (error "No such message."))
  56       (if (eq vm-message-pointer cons)
  57           (vm-preview-current-message)
  58         (vm-record-and-change-message-pointer vm-message-pointer cons)
  59         (vm-preview-current-message)))))
  60
  61 ;;;###autoload
  62 (defun vm-goto-message-last-seen ()
  63   "Go to the message last previewed."
  64   (interactive)
  65   (vm-select-folder-buffer)
  66   (vm-check-for-killed-summary)
  67   (vm-error-if-folder-empty)
  68   (vm-display nil nil '(vm-goto-message-last-seen)
  69               '(vm-goto-message-last-seen))
  70   (if vm-last-message-pointer
  71       (progn
  72         (vm-record-and-change-message-pointer vm-message-pointer
  73                                               vm-last-message-pointer)
  74         (vm-preview-current-message))))
  75
  76 ;;;###autoload
  77 (defun vm-goto-parent-message ()
  78   "Go to the parent of the current message."
  79   (interactive)
  80   (vm-follow-summary-cursor)
  81   (vm-select-folder-buffer)
  82   (vm-check-for-killed-summary)
  83   (vm-error-if-folder-empty)
  84   (vm-build-threads-if-unbuilt)
  85   (vm-display nil nil '(vm-goto-parent-message)
  86               '(vm-goto-parent-message))
  87   (let ((list (vm-th-thread-list (car vm-message-pointer)))
  88         message)
  89     (if (null (cdr list))
  90         (message "Message has no parent.")
  91       (while (cdr (cdr list))
  92         (setq list (cdr list)))
  93       (setq message (car (get (car list) 'messages)))
  94       (if (null message)
  95           (message "Parent message is not in this folder.")
  96         (vm-record-and-change-message-pointer vm-message-pointer
  97                                               (memq message vm-message-list))
  98         (vm-preview-current-message)))))
  99
 100 (defun vm-check-count (count)
 101   (if (>= count 0)
 102       (if (< (length vm-message-pointer) count)
 103           (signal 'end-of-folder nil))
 104     (if (< (1+ (- (length vm-message-list) (length vm-message-pointer)))
 105            (vm-abs count))
 106         (signal 'beginning-of-folder nil))))
 107
 108 (defun vm-move-message-pointer (direction)
 109   (let ((mp vm-message-pointer))
 110     (if (eq direction 'forward)
 111         (progn
 112           (setq mp (cdr mp))
 113           (if (null mp)
 114               (if vm-circular-folders
 115                   (setq mp vm-message-list)
 116                 (signal 'end-of-folder nil))))
 117       (setq mp (vm-reverse-link-of (car mp)))
 118       (if (null mp)
 119           (if vm-circular-folders
 120               (setq mp (vm-last vm-message-list))
 121             (signal 'beginning-of-folder nil))))
 122     (setq vm-message-pointer mp)))
 123
 124 (defun vm-should-skip-message (mp &optional skip-dogmatically)
 125   (if skip-dogmatically
 126       (or (and vm-skip-deleted-messages
 127                (vm-deleted-flag (car mp)))
 128           (and vm-skip-read-messages
 129                (or (vm-deleted-flag (car mp))
 130                    (not (or (vm-new-flag (car mp))
 131                             (vm-unread-flag (car mp))))))
 132           (and (eq last-command 'vm-next-command-uses-marks)
 133                (null (vm-mark-of (car mp)))))
 134     (or (and (eq vm-skip-deleted-messages t)
 135              (vm-deleted-flag (car mp)))
 136         (and (eq vm-skip-read-messages t)
 137              (or (vm-deleted-flag (car mp))
 138                  (not (or (vm-new-flag (car mp))
 139                           (vm-unread-flag (car mp))))))
 140         (and (eq last-command 'vm-next-command-uses-marks)
 141              (null (vm-mark-of (car mp)))))))
 142
 143 ;;;###autoload
 144 (defun vm-next-message (&optional count retry signal-errors)
 145   "Go forward one message and preview it.
 146 With prefix arg (optional first argument) COUNT, go forward COUNT
 147 messages.  A negative COUNT means go backward.  If the absolute
 148 value of COUNT is greater than 1, then the values of the variables
 149 vm-skip-deleted-messages and vm-skip-read-messages are ignored.
 150
 151 When invoked on marked messages (via vm-next-command-uses-marks)
 152 this command 'sees' marked messages as it moves."
 153   ;; second arg RETRY non-nil means retry a failed move, giving
 154   ;; not nil-or-t values of the vm-skip variables a chance to
 155   ;; work.
 156   ;;
 157   ;; third arg SIGNAL-ERRORS non-nil means that if after
 158   ;; everything we still have bashed into the end or beginning of
 159   ;; folder before completing the move, signal
 160   ;; beginning-of-folder or end-of-folder.  Otherwise no error
 161   ;; will be signaled.
 162   ;;
 163   ;; Note that interactively all args are 1, so error signaling
 164   ;; and retries apply to all interactive moves.
 165   (interactive "p\np\np")
 166   (if (interactive-p)
 167       (vm-follow-summary-cursor))
 168   (vm-select-folder-buffer)
 169   (vm-check-for-killed-summary)
 170   ;; include other commands that call vm-next-message so that the
 171   ;; correct window configuration is applied for these particular
 172   ;; non-interactive calls.
 173   (vm-display nil nil '(vm-next-message
 174                         vm-delete-message
 175                         vm-undelete-message
 176                         vm-scroll-forward)
 177               (list this-command))
 178   (and signal-errors (vm-error-if-folder-empty))
 179   (or count (setq count 1))
 180   (let ((oldmp vm-message-pointer)
 181         (use-marks (eq last-command 'vm-next-command-uses-marks))
 182         (error)
 183         (direction (if (> count 0) 'forward 'backward))
 184         (count (vm-abs count)))
 185     (cond
 186      ((null vm-message-pointer)
 187       (setq vm-message-pointer vm-message-list))
 188      ((/= count 1)
 189       (condition-case ()
 190           (let ((oldmp oldmp))
 191             (while (not (zerop count))
 192               (vm-move-message-pointer direction)
 193               (if (and use-marks (null (vm-mark-of (car vm-message-pointer))))
 194                   (progn
 195                     (while (and (not (eq vm-message-pointer oldmp))
 196                                 (null (vm-mark-of (car vm-message-pointer))))
 197                       (vm-move-message-pointer direction))
 198                     (if (eq vm-message-pointer oldmp)
 199                         ;; terminate the loop
 200                         (setq count 1)
 201                       ;; reset for next pass
 202                       (setq oldmp vm-message-pointer))))
 203               (vm-decrement count)))
 204         (beginning-of-folder (setq error 'beginning-of-folder))
 205         (end-of-folder (setq error 'end-of-folder))))
 206      (t
 207       (condition-case ()
 208           (progn
 209             (vm-move-message-pointer direction)
 210             (while (and (not (eq oldmp vm-message-pointer))
 211                         (vm-should-skip-message vm-message-pointer t))
 212               (vm-move-message-pointer direction))
 213             ;; Retry the move if we've gone a complete circle and
 214             ;; retries are allowed and there are other messages
 215             ;; besides this one.
 216             (and (eq vm-message-pointer oldmp) retry (cdr vm-message-list)
 217                  (progn
 218                    (vm-move-message-pointer direction)
 219                    (while (and (not (eq oldmp vm-message-pointer))
 220                                (vm-should-skip-message vm-message-pointer))
 221                      (vm-move-message-pointer direction)))))
 222         (beginning-of-folder
 223          ;; we bumped into the beginning of the folder without finding
 224          ;; a suitable stopping point; retry the move if we're allowed.
 225          (setq vm-message-pointer oldmp)
 226          ;; if the retry fails, we make sure the message pointer
 227          ;; is restored to its old value.
 228          (if retry
 229              (setq vm-message-pointer
 230                    (condition-case ()
 231                        (let ((vm-message-pointer vm-message-pointer))
 232                          (vm-move-message-pointer direction)
 233                          (while (vm-should-skip-message vm-message-pointer)
 234                            (vm-move-message-pointer direction))
 235                          vm-message-pointer )
 236                      (beginning-of-folder
 237                       (setq error 'beginning-of-folder)
 238                       oldmp )))
 239            (setq error 'beginning-of-folder)))
 240         (end-of-folder
 241          ;; we bumped into the end of the folder without finding
 242          ;; a suitable stopping point; retry the move if we're allowed.
 243          (setq vm-message-pointer oldmp)
 244          ;; if the retry fails, we make sure the message pointer
 245          ;; is restored to its old value.
 246          (if retry
 247              (setq vm-message-pointer
 248                    (condition-case ()
 249                        (let ((vm-message-pointer vm-message-pointer))
 250                          (vm-move-message-pointer direction)
 251                          (while (vm-should-skip-message vm-message-pointer)
 252                            (vm-move-message-pointer direction))
 253                          vm-message-pointer )
 254                      (end-of-folder
 255                       (setq error 'end-of-folder)
 256                       oldmp )))
 257            (setq error 'end-of-folder))))))
 258     (if (not (eq vm-message-pointer oldmp))
 259         (progn
 260           (vm-record-and-change-message-pointer oldmp vm-message-pointer)
 261           (vm-preview-current-message)))
 262     (and error signal-errors
 263          (signal error nil))))
 264
 265 ;;;###autoload
 266 (defun vm-previous-message (&optional count retry signal-errors)
 267   "Go back one message and preview it.
 268 With prefix arg COUNT, go backward COUNT messages.  A negative COUNT
 269 means go forward.  If the absolute value of COUNT > 1 the values of the
 270 variables vm-skip-deleted-messages and vm-skip-read-messages are
 271 ignored."
 272   (interactive "p\np\np")
 273   (or count (setq count 1))
 274   (if (interactive-p)
 275       (vm-follow-summary-cursor))
 276   (vm-select-folder-buffer)
 277   (vm-display nil nil '(vm-previous-message) '(vm-previous-message))
 278   (vm-next-message (- count) retry signal-errors))
 279
 280 ;;;###autoload
 281 (defun vm-next-message-no-skip (&optional count)
 282   "Like vm-next-message but will not skip deleted or read messages."
 283   (interactive "p")
 284   (if (interactive-p)
 285       (vm-follow-summary-cursor))
 286   (vm-select-folder-buffer)
 287   (vm-display nil nil '(vm-next-message-no-skip)
 288               '(vm-next-message-no-skip))
 289   (let ((vm-skip-deleted-messages nil)
 290         (vm-skip-read-messages nil))
 291     (vm-next-message count nil t)))
 292 ;; backward compatibility
 293 (fset 'vm-Next-message 'vm-next-message-no-skip)
 294
 295 ;;;###autoload
 296 (defun vm-previous-message-no-skip (&optional count)
 297   "Like vm-previous-message but will not skip deleted or read messages."
 298   (interactive "p")
 299   (if (interactive-p)
 300       (vm-follow-summary-cursor))
 301   (vm-select-folder-buffer)
 302   (vm-display nil nil '(vm-previous-message-no-skip)
 303               '(vm-previous-message-no-skip))
 304   (let ((vm-skip-deleted-messages nil)
 305         (vm-skip-read-messages nil))
 306     (vm-previous-message count)))
 307 ;; backward compatibility
 308 (fset 'vm-Previous-message 'vm-previous-message-no-skip)
 309
 310 ;;;###autoload
 311 (defun vm-next-unread-message ()
 312   "Move forward to the nearest new or unread message, if there is one."
 313   (interactive)
 314   (if (interactive-p)
 315       (vm-follow-summary-cursor))
 316   (vm-select-folder-buffer)
 317   (vm-check-for-killed-summary)
 318   (vm-display nil nil '(vm-next-unread-message) '(vm-next-unread-message))
 319   (condition-case ()
 320       (let ((vm-skip-read-messages t)
 321             (oldmp vm-message-pointer))
 322         (vm-next-message 1 nil t)
 323         ;; in case vm-circular-folders is non-nil
 324         (and (eq vm-message-pointer oldmp) (signal 'end-of-folder nil)))
 325     (end-of-folder (message "No next unread message"))))
 326
 327 ;;;###autoload
 328 (defun vm-previous-unread-message ()
 329   "Move backward to the nearest new or unread message, if there is one."
 330   (interactive)
 331   (if (interactive-p)
 332       (vm-follow-summary-cursor))
 333   (vm-select-folder-buffer)
 334   (vm-check-for-killed-summary)
 335   (vm-display nil nil '(vm-previous-unread-message)
 336               '(vm-previous-unread-message))
 337   (condition-case ()
 338       (let ((vm-skip-read-messages t)
 339             (oldmp vm-message-pointer))
 340         (vm-previous-message)
 341         ;; in case vm-circular-folders is non-nil
 342         (and (eq vm-message-pointer oldmp) (signal 'beginning-of-folder nil)))
 343     (beginning-of-folder (message "No previous unread message"))))
 344
 345 ;;;###autoload
 346 (defun vm-next-message-same-subject ()
 347   "Move forward to the nearest message with the same subject.
 348 vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply
 349 to the subject comparisons."
 350   (interactive)
 351   (if (interactive-p)
 352       (vm-follow-summary-cursor))
 353   (vm-select-folder-buffer)
 354   (vm-check-for-killed-summary)
 355   (vm-display nil nil '(vm-next-message-same-subject)
 356               '(vm-next-message-same-subject))
 357   (let ((oldmp vm-message-pointer)
 358         (done nil)
 359         (subject (vm-so-sortable-subject (car vm-message-pointer))))
 360     (condition-case ()
 361         (progn
 362           (while (not done)
 363             (vm-move-message-pointer 'forward)
 364             (if (eq oldmp vm-message-pointer)
 365                 (signal 'end-of-folder nil))
 366             (if (equal subject
 367                        (vm-so-sortable-subject (car vm-message-pointer)))
 368                 (setq done t)))
 369           (vm-record-and-change-message-pointer oldmp vm-message-pointer)
 370           (vm-preview-current-message))
 371       (end-of-folder
 372        (setq vm-message-pointer oldmp)
 373        (message "No next message with the same subject")))))
 374
 375 ;;;###autoload
 376 (defun vm-previous-message-same-subject ()
 377   "Move backward to the nearest message with the same subject.
 378 vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply
 379 to the subject comparisons."
 380   (interactive)
 381   (if (interactive-p)
 382       (vm-follow-summary-cursor))
 383   (vm-select-folder-buffer)
 384   (vm-check-for-killed-summary)
 385   (vm-display nil nil '(vm-previous-message-same-subject)
 386               '(vm-previous-message-same-subject))
 387   (let ((oldmp vm-message-pointer)
 388         (done nil)
 389         (subject (vm-so-sortable-subject (car vm-message-pointer))))
 390     (condition-case ()
 391         (progn
 392           (while (not done)
 393             (vm-move-message-pointer 'backward)
 394             (if (eq oldmp vm-message-pointer)
 395                 (signal 'beginning-of-folder nil))
 396             (if (equal subject
 397                        (vm-so-sortable-subject (car vm-message-pointer)))
 398                 (setq done t)))
 399           (vm-record-and-change-message-pointer oldmp vm-message-pointer)
 400           (vm-preview-current-message))
 401       (beginning-of-folder
 402        (setq vm-message-pointer oldmp)
 403        (message "No previous message with the same subject")))))
 404
 405 (defun vm-find-first-unread-message (new)
 406   (let (mp unread-mp)
 407     (setq mp vm-message-list)
 408     (if new
 409         (while mp
 410           (if (and (vm-new-flag (car mp)) (not (vm-deleted-flag (car mp))))
 411               (setq unread-mp mp mp nil)
 412             (setq mp (cdr mp))))
 413       (while mp
 414         (if (and (or (vm-new-flag (car mp)) (vm-unread-flag (car mp)))
 415                  (not (vm-deleted-flag (car mp))))
 416             (setq unread-mp mp mp nil)
 417           (setq mp (cdr mp)))))
 418     unread-mp ))
 419
 420 (defun vm-thoughtfully-select-message ()
 421   (let ((new (and vm-jump-to-new-messages (vm-find-first-unread-message t)))
 422         (unread (and vm-jump-to-unread-messages
 423                      (vm-find-first-unread-message nil)))
 424         fix mp)
 425     (if (null vm-message-pointer)
 426         (setq fix (vm-last vm-message-list)))
 427     (setq mp (or new unread fix))
 428     (if (and mp (not (eq mp vm-message-pointer)))
 429         (progn
 430           (vm-record-and-change-message-pointer vm-message-pointer mp)
 431           mp )
 432       nil )))
 433
 434 (defun vm-follow-summary-cursor ()
 435   (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode)
 436        (let ((point (point))
 437              message-pointer message-list mp)
 438          (save-excursion
 439            (set-buffer vm-mail-buffer)
 440            (setq message-pointer vm-message-pointer
 441                  message-list vm-message-list))
 442          (cond ((or (null message-pointer)
 443                     (and (>= point (vm-su-start-of (car message-pointer)))
 444                          (< point (vm-su-end-of (car message-pointer)))))
 445                 nil )
 446                ;; the position at eob belongs to the last message
 447                ((and (eobp) (= (vm-su-end-of (car message-pointer)) point))
 448                 nil )
 449                ;; make the position at eob belong to the last message
 450                ((eobp)
 451                 (setq mp (vm-last message-pointer))
 452                 (save-excursion
 453                   (set-buffer vm-mail-buffer)
 454                   (vm-record-and-change-message-pointer vm-message-pointer mp)
 455                   (vm-preview-current-message)
 456                   ;; return non-nil so the caller will know that
 457                   ;; a new message was selected.
 458                   t ))
 459                (t
 460                 (if (< point (vm-su-start-of (car message-pointer)))
 461                     (setq mp message-list)
 462                   (setq mp (cdr message-pointer) message-pointer nil))
 463                 (while (and (not (eq mp message-pointer))
 464                             (>= point (vm-su-end-of (car mp))))
 465                   (setq mp (cdr mp)))
 466                 (if (not (eq mp message-pointer))
 467                     (save-excursion
 468                       (set-buffer vm-mail-buffer)
 469                       (vm-record-and-change-message-pointer
 470                        vm-message-pointer mp)
 471                       (vm-preview-current-message)
 472                       ;; return non-nil so the caller will know that
 473                       ;; a new message was selected.
 474                       t )))))))
 475
 476 (provide 'vm-motion)
 477
 478 ;;; vm-motion.el ends here