Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-motion.el @ 0:376386a54a3c r19-14

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