« back to all changes in this revision
Viewing changes to vm-page.el
- browse files at revision 2
- compare with another revision
- download diff
- download tarball
- view history from revision 2
- Committer: Robert Widhopf
- Date: 2004-05-02 21:30:26 UTC
- Revision ID: Arch-1:hack@robf.de--testing%vm--main--7--patch-1
Initial Import of VM 7.18
- files added:
- COPYING
- pixmaps
added
removed
vm-page.el
1
;;; Commands to move around within a VM message
2
;;; Copyright (C) 1989-1997 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-page)
19
20
(defun vm-scroll-forward (&optional arg)
21
"Scroll forward a screenful of text.
22
If the current message is being previewed, the message body is revealed.
23
If at the end of the current message, moves to the next message iff the
24
value of vm-auto-next-message is non-nil.
25
Prefix argument N means scroll forward N lines."
26
(interactive "P")
27
(let ((mp-changed (vm-follow-summary-cursor))
28
needs-decoding
29
(was-invisible nil))
30
(vm-select-folder-buffer)
31
(vm-check-for-killed-summary)
32
(vm-check-for-killed-presentation)
33
(vm-error-if-folder-empty)
34
(setq needs-decoding (and vm-display-using-mime
35
(not vm-mime-decoded)
36
(not (vm-mime-plain-message-p
37
(car vm-message-pointer)))
38
vm-auto-decode-mime-messages
39
(eq vm-system-state 'previewing)))
40
(and vm-presentation-buffer
41
(set-buffer vm-presentation-buffer))
42
(let ((point (point))
43
(w (vm-get-visible-buffer-window (current-buffer))))
44
(if (or (null w)
45
(not (vm-frame-totally-visible-p (vm-window-frame w))))
46
(progn
47
(vm-display (current-buffer) t
48
'(vm-scroll-forward vm-scroll-backward)
49
(list this-command 'reading-message))
50
;; window start sticks to end of clip region when clip
51
;; region moves back past it in the buffer. fix it.
52
(setq w (vm-get-visible-buffer-window (current-buffer)))
53
(if (= (window-start w) (point-max))
54
(set-window-start w (point-min)))
55
(setq was-invisible t))))
56
(if (or mp-changed was-invisible needs-decoding
57
(and (eq vm-system-state 'previewing)
58
(pos-visible-in-window-p
59
(point-max)
60
(vm-get-visible-buffer-window (current-buffer)))))
61
(progn
62
(if (not was-invisible)
63
(let ((w (vm-get-visible-buffer-window (current-buffer)))
64
old-w-start)
65
(setq old-w-start (window-start w))
66
;; save-excursion to avoid possible buffer change
67
(save-excursion (vm-select-frame (window-frame w)))
68
(vm-raise-frame (window-frame w))
69
(vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
70
(list this-command 'reading-message))
71
(setq w (vm-get-visible-buffer-window (current-buffer)))
72
(and w (set-window-start w old-w-start))))
73
(cond ((eq vm-system-state 'previewing)
74
(vm-show-current-message)
75
;; The window start marker sometimes drifts forward
76
;; because of something that vm-show-current-message
77
;; does. In Emacs 20, replacing ASCII chars with
78
;; multibyte chars seems to cause it, but I _think_
79
;; the drift can happen in Emacs 19 and even
80
;; XEmacs for different reasons. So we reset the
81
;; start marker here, since it is an easy fix.
82
(let ((w (vm-get-visible-buffer-window (current-buffer))))
83
(set-window-start w (point-min)))))
84
(vm-howl-if-eom))
85
(let ((vmp vm-message-pointer)
86
(msg-buf (current-buffer))
87
(h-diff 0)
88
w old-w old-w-height old-w-start result)
89
(if (eq vm-system-state 'previewing)
90
(vm-show-current-message))
91
(setq vm-system-state 'reading)
92
(setq old-w (vm-get-visible-buffer-window msg-buf)
93
old-w-height (window-height old-w)
94
old-w-start (window-start old-w))
95
(setq w (vm-get-visible-buffer-window msg-buf))
96
(vm-select-frame (window-frame w))
97
(vm-raise-frame (window-frame w))
98
(vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
99
(list this-command 'reading-message))
100
(setq w (vm-get-visible-buffer-window msg-buf))
101
(if (null w)
102
(error "current window configuration hides the message buffer.")
103
(setq h-diff (- (window-height w) old-w-height)))
104
;; must restore this since it gets clobbered by window
105
;; teardown and rebuild done by the window config stuff.
106
(set-window-start w old-w-start)
107
(setq old-w (selected-window))
108
(unwind-protect
109
(progn
110
(select-window w)
111
(let ((next-screen-context-lines
112
(+ next-screen-context-lines h-diff)))
113
(while (eq (setq result (vm-scroll-forward-internal arg))
114
'tryagain))
115
(cond ((and (not (eq result 'next-message))
116
vm-honor-page-delimiters)
117
(vm-narrow-to-page)
118
(goto-char (max (window-start w)
119
(vm-text-of (car vmp))))
120
;; This is needed because in some cases
121
;; the scroll-up call in vm-howl-if-emo
122
;; does not signal end-of-buffer when
123
;; it should unless we do this. This
124
;; sit-for most likely removes the need
125
;; for the (scroll-up 0) below, but
126
;; since the voodoo has worked this
127
;; long, it's probably best to let it
128
;; be.
129
(sit-for 0)
130
;; This voodoo is required! For some
131
;; reason the 18.52 emacs display
132
;; doesn't immediately reflect the
133
;; clip region change that occurs
134
;; above without this mantra.
135
(scroll-up 0)))))
136
(select-window old-w))
137
(set-buffer msg-buf)
138
(cond ((eq result 'next-message)
139
(vm-next-message))
140
((eq result 'end-of-message)
141
(let ((vm-message-pointer vmp))
142
(vm-emit-eom-blurb)))
143
(t
144
(and (> (prefix-numeric-value arg) 0)
145
(vm-howl-if-eom)))))))
146
(if (not vm-startup-message-displayed)
147
(vm-display-startup-message)))
148
149
(defun vm-scroll-forward-internal (arg)
150
(let ((direction (prefix-numeric-value arg))
151
(w (selected-window)))
152
(condition-case error-data
153
(progn (scroll-up arg) nil)
154
;; this looks like it should work, but doesn't because the
155
;; redisplay code is schizophrenic when it comes to updates. A
156
;; window position may no longer be visible but
157
;; pos-visible-in-window-p will still say it is because it was
158
;; visible before some window size change happened.
159
;; (progn
160
;; (if (and (> direction 0)
161
;; (pos-visible-in-window-p
162
;; (vm-text-end-of (car vm-message-pointer))))
163
;; (signal 'end-of-buffer nil)
164
;; (scroll-up arg))
165
;; nil )
166
(error
167
(if (or (and (< direction 0)
168
(> (point-min) (vm-text-of (car vm-message-pointer))))
169
(and (>= direction 0)
170
(/= (point-max)
171
(vm-text-end-of (car vm-message-pointer)))))
172
(progn
173
(vm-widen-page)
174
(if (>= direction 0)
175
(progn
176
(forward-page 1)
177
(set-window-start w (point))
178
nil )
179
(if (or (bolp)
180
(not (save-excursion
181
(beginning-of-line)
182
(looking-at page-delimiter))))
183
(forward-page -1))
184
(beginning-of-line)
185
(set-window-start w (point))
186
'tryagain))
187
(if (eq (car error-data) 'end-of-buffer)
188
(if vm-auto-next-message
189
'next-message
190
(set-window-point w (point))
191
'end-of-message)))))))
192
193
;; exploratory scrolling, what a concept.
194
;;
195
;; we do this because pos-visible-in-window-p checks the current
196
;; window configuration, while this exploratory scrolling forces
197
;; Emacs to recompute the display, giving us an up to the moment
198
;; answer about where the end of the message is going to be
199
;; visible when redisplay finally does occur.
200
(defun vm-howl-if-eom ()
201
(let ((w (get-buffer-window (current-buffer))))
202
(and w
203
(save-excursion
204
(save-window-excursion
205
(condition-case ()
206
(let ((next-screen-context-lines 0))
207
(select-window w)
208
(save-excursion
209
(save-window-excursion
210
;; scroll-fix.el replaces scroll-up and
211
;; doesn't behave properly when it hits
212
;; end of buffer. It does this!
213
;; (ding)
214
;; (message (get 'beginning-of-buffer 'error-message))
215
(let ((scroll-in-place-replace-original nil))
216
(scroll-up nil))))
217
nil)
218
(error t))))
219
(= (vm-text-end-of (car vm-message-pointer)) (point-max))
220
(vm-emit-eom-blurb))))
221
222
(defun vm-emit-eom-blurb ()
223
(let ((vm-summary-uninteresting-senders-arrow "")
224
(case-fold-search nil))
225
(message (if (and (stringp vm-summary-uninteresting-senders)
226
(string-match vm-summary-uninteresting-senders
227
(vm-su-from (car vm-message-pointer))))
228
"End of message %s to %s"
229
"End of message %s from %s")
230
(vm-number-of (car vm-message-pointer))
231
(vm-summary-sprintf "%F" (car vm-message-pointer)))))
232
233
(defun vm-scroll-backward (&optional arg)
234
"Scroll backward a screenful of text.
235
Prefix N scrolls backward N lines."
236
(interactive "P")
237
(vm-scroll-forward (cond ((null arg) '-)
238
((consp arg) (list (- (car arg))))
239
((numberp arg) (- arg))
240
((symbolp arg) nil)
241
(t arg))))
242
243
(defun vm-scroll-forward-one-line (&optional count)
244
"Scroll forward one line.
245
Prefix arg N means scroll forward N lines.
246
Negative arg means scroll backward."
247
(interactive "p")
248
(vm-scroll-forward count))
249
250
(defun vm-scroll-backward-one-line (&optional count)
251
"Scroll backward one line.
252
Prefix arg N means scroll backward N lines.
253
Negative arg means scroll forward."
254
(interactive "p")
255
(vm-scroll-forward (- count)))
256
257
(defun vm-highlight-headers ()
258
(cond
259
((and vm-xemacs-p vm-use-lucid-highlighting)
260
(require 'highlight-headers)
261
;; disable the url marking stuff, since VM has its own interface.
262
(let ((highlight-headers-mark-urls nil)
263
(highlight-headers-regexp (or vm-highlighted-header-regexp
264
highlight-headers-regexp)))
265
(highlight-headers (point-min) (point-max) t)))
266
(vm-xemacs-p
267
(let (e)
268
(map-extents (function
269
(lambda (e ignore)
270
(if (extent-property e 'vm-highlight)
271
(delete-extent e))
272
nil))
273
(current-buffer) (point-min) (point-max))
274
(goto-char (point-min))
275
(while (vm-match-header)
276
(cond ((vm-match-header vm-highlighted-header-regexp)
277
(setq e (make-extent (vm-matched-header-contents-start)
278
(vm-matched-header-contents-end)))
279
(set-extent-property e 'face vm-highlighted-header-face)
280
(set-extent-property e 'vm-highlight t)))
281
(goto-char (vm-matched-header-end)))))
282
((fboundp 'overlay-put)
283
(let (o-lists p)
284
(setq o-lists (overlay-lists)
285
p (car o-lists))
286
(while p
287
(and (overlay-get (car p) 'vm-highlight)
288
(delete-overlay (car p)))
289
(setq p (cdr p)))
290
(setq p (cdr o-lists))
291
(while p
292
(and (overlay-get (car p) 'vm-highlight)
293
(delete-overlay (car p)))
294
(setq p (cdr p)))
295
(goto-char (point-min))
296
(while (vm-match-header)
297
(cond ((vm-match-header vm-highlighted-header-regexp)
298
(setq p (make-overlay (vm-matched-header-contents-start)
299
(vm-matched-header-contents-end)))
300
(overlay-put p 'face vm-highlighted-header-face)
301
(overlay-put p 'vm-highlight t)))
302
(goto-char (vm-matched-header-end)))))))
303
304
(defun vm-energize-urls ()
305
;; Don't search too long in large regions. If the region is
306
;; large, search just the head and the tail of the region since
307
;; they tend to contain the interesting text.
308
(let ((search-limit vm-url-search-limit)
309
search-pairs n)
310
(if (and search-limit (> (- (point-max) (point-min)) search-limit))
311
(setq search-pairs (list (cons (point-min)
312
(+ (point-min) (/ search-limit 2)))
313
(cons (- (point-max) (/ search-limit 2))
314
(point-max))))
315
(setq search-pairs (list (cons (point-min) (point-max)))))
316
(cond
317
(vm-xemacs-p
318
(let (e)
319
(map-extents (function
320
(lambda (e ignore)
321
(if (extent-property e 'vm-url)
322
(delete-extent e))
323
nil))
324
(current-buffer) (point-min) (point-max))
325
(while search-pairs
326
(goto-char (car (car search-pairs)))
327
(while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
328
(setq n 1)
329
(while (null (match-beginning n))
330
(vm-increment n))
331
(setq e (make-extent (match-beginning n) (match-end n)))
332
(set-extent-property e 'vm-url t)
333
(if vm-highlight-url-face
334
(set-extent-property e 'face vm-highlight-url-face))
335
(if vm-url-browser
336
(let ((keymap (make-sparse-keymap))
337
(popup-function
338
(if (save-excursion
339
(goto-char (match-beginning n))
340
(looking-at "mailto:"))
341
'vm-menu-popup-mailto-url-browser-menu
342
'vm-menu-popup-url-browser-menu)))
343
(define-key keymap 'button2 'vm-mouse-send-url-at-event)
344
(if vm-popup-menu-on-mouse-3
345
(define-key keymap 'button3 popup-function))
346
(define-key keymap "\r"
347
(function (lambda () (interactive)
348
(vm-mouse-send-url-at-position (point)))))
349
(set-extent-property e 'vm-button t)
350
(set-extent-property e 'keymap keymap)
351
(set-extent-property e 'balloon-help 'vm-url-help)
352
(set-extent-property e 'highlight t))))
353
(setq search-pairs (cdr search-pairs)))))
354
((and vm-fsfemacs-p
355
(fboundp 'overlay-put))
356
(let (o-lists o p)
357
(setq o-lists (overlay-lists)
358
p (car o-lists))
359
(while p
360
(and (overlay-get (car p) 'vm-url)
361
(delete-overlay (car p)))
362
(setq p (cdr p)))
363
(setq p (cdr o-lists))
364
(while p
365
(and (overlay-get (car p) 'vm-url)
366
(delete-overlay (car p)))
367
(setq p (cdr p)))
368
(while search-pairs
369
(goto-char (car (car search-pairs)))
370
(while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
371
(setq n 1)
372
(while (null (match-beginning n))
373
(vm-increment n))
374
(setq o (make-overlay (match-beginning n) (match-end n)))
375
(overlay-put o 'vm-url t)
376
(if vm-highlight-url-face
377
(overlay-put o 'face vm-highlight-url-face))
378
(if vm-url-browser
379
(let ((keymap (make-sparse-keymap))
380
(popup-function
381
(if (save-excursion
382
(goto-char (match-beginning n))
383
(looking-at "mailto:"))
384
'vm-menu-popup-mailto-url-browser-menu
385
'vm-menu-popup-url-browser-menu)))
386
(overlay-put o 'vm-button t)
387
(overlay-put o 'mouse-face 'highlight)
388
(setq keymap (nconc keymap (current-local-map)))
389
(if vm-popup-menu-on-mouse-3
390
(define-key keymap [mouse-3] popup-function))
391
(define-key keymap "\r"
392
(function (lambda () (interactive)
393
(vm-mouse-send-url-at-position (point)))))
394
(overlay-put o 'local-map keymap))))
395
(setq search-pairs (cdr search-pairs))))))))
396
397
(defun vm-energize-headers ()
398
(cond
399
(vm-xemacs-p
400
(let ((search-tuples '(("^From:" vm-menu-author-menu)
401
("^Subject:" vm-menu-subject-menu)))
402
regexp menu keymap e)
403
(map-extents (function
404
(lambda (e ignore)
405
(if (extent-property e 'vm-header)
406
(delete-extent e))
407
nil))
408
(current-buffer) (point-min) (point-max))
409
(while search-tuples
410
(goto-char (point-min))
411
(setq regexp (nth 0 (car search-tuples))
412
menu (symbol-value (nth 1 (car search-tuples))))
413
(while (re-search-forward regexp nil t)
414
(save-excursion (goto-char (match-beginning 0)) (vm-match-header))
415
(setq e (make-extent (vm-matched-header-contents-start)
416
(vm-matched-header-contents-end)))
417
(set-extent-property e 'vm-header t)
418
(setq keymap (make-sparse-keymap))
419
;; Might as well make button2 do what button3 does in
420
;; this case, since there is no default 'select'
421
;; action.
422
(define-key keymap 'button2
423
(list 'lambda () '(interactive)
424
(list 'popup-menu (list 'quote menu))))
425
(if vm-popup-menu-on-mouse-3
426
(define-key keymap 'button3
427
(list 'lambda () '(interactive)
428
(list 'popup-menu (list 'quote menu)))))
429
(set-extent-property e 'keymap keymap)
430
(set-extent-property e 'balloon-help 'vm-mouse-3-help)
431
(set-extent-property e 'highlight t))
432
(setq search-tuples (cdr search-tuples)))))
433
((and vm-fsfemacs-p
434
(fboundp 'overlay-put))
435
(let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu)
436
("^Subject:" vm-menu-fsfemacs-subject-menu)))
437
regexp menu
438
o-lists o p)
439
(setq o-lists (overlay-lists)
440
p (car o-lists))
441
(while p
442
(and (overlay-get (car p) 'vm-header)
443
(delete-overlay (car p)))
444
(setq p (cdr p)))
445
(setq p (cdr o-lists))
446
(while p
447
(and (overlay-get (car p) 'vm-header)
448
(delete-overlay (car p)))
449
(setq p (cdr p)))
450
(while search-tuples
451
(goto-char (point-min))
452
(setq regexp (nth 0 (car search-tuples))
453
menu (symbol-value (nth 1 (car search-tuples))))
454
(while (re-search-forward regexp nil t)
455
(goto-char (match-end 0))
456
(save-excursion (goto-char (match-beginning 0)) (vm-match-header))
457
(setq o (make-overlay (vm-matched-header-contents-start)
458
(vm-matched-header-contents-end)))
459
(overlay-put o 'vm-header menu)
460
(overlay-put o 'mouse-face 'highlight))
461
(setq search-tuples (cdr search-tuples)))))))
462
463
(defun vm-display-xface ()
464
(cond (vm-xemacs-p (vm-display-xface-xemacs))
465
((and vm-fsfemacs-p
466
(and (stringp vm-uncompface-program)
467
(fboundp 'create-image)))
468
(vm-display-xface-fsfemacs))))
469
470
(defun vm-display-xface-xemacs ()
471
(let ((case-fold-search t) e g h)
472
(if (map-extents (function
473
(lambda (e ignore)
474
(if (extent-property e 'vm-xface)
475
t
476
nil)))
477
(current-buffer) (point-min) (point-max))
478
nil
479
(goto-char (point-min))
480
(if (find-face 'vm-xface)
481
nil
482
(make-face 'vm-xface)
483
(set-face-background 'vm-xface "white")
484
(set-face-foreground 'vm-xface "black"))
485
(if (re-search-forward "^X-Face:" nil t)
486
(progn
487
(goto-char (match-beginning 0))
488
(vm-match-header)
489
(setq h (concat "X-Face: " (vm-matched-header-contents)))
490
(setq g (intern h vm-xface-cache))
491
(if (boundp g)
492
(setq g (symbol-value g))
493
(set g (make-glyph
494
(list
495
(list 'global (cons '(tty) [nothing]))
496
(list 'global (cons '(win) (vector 'xface ':data h))))))
497
(setq g (symbol-value g))
498
;; XXX broken. Gives extra pixel lines at the
499
;; bottom of the glyph in 19.12
500
;;(set-glyph-baseline g 100)
501
(set-glyph-face g 'vm-xface))
502
(setq e (make-extent (vm-vheaders-of (car vm-message-pointer))
503
(vm-vheaders-of (car vm-message-pointer))))
504
(set-extent-property e 'vm-xface t)
505
(set-extent-begin-glyph e g))))))
506
507
(defun vm-display-xface-fsfemacs ()
508
(catch 'done
509
(let ((case-fold-search t) i g h ooo)
510
(setq ooo (overlays-in (point-min) (point-max)))
511
(while ooo
512
(if (overlay-get (car ooo) 'vm-xface)
513
(delete-overlay (car ooo)))
514
(setq ooo (cdr ooo)))
515
(goto-char (point-min))
516
(if (re-search-forward "^X-Face:" nil t)
517
(progn
518
(goto-char (match-beginning 0))
519
(vm-match-header)
520
(setq h (vm-matched-header-contents))
521
(setq g (intern h vm-xface-cache))
522
(if (boundp g)
523
(setq g (symbol-value g))
524
(setq i (vm-convert-xface-to-fsfemacs-image-instantiator h))
525
(cond (i
526
(set g i)
527
(setq g (symbol-value g)))
528
(t (throw 'done nil))))
529
(let ((pos (vm-vheaders-of (car vm-message-pointer)))
530
o )
531
;; An image must replace the normal display of at
532
;; least one character. Since we want to put the
533
;; image at the beginning of the visible headers
534
;; section, it will obscure the first character of
535
;; that section. To display that character we add
536
;; an after-string that contains the character.
537
;; Kludge city, but it works.
538
(setq o (make-overlay (+ 0 pos) (+ 1 pos)))
539
(overlay-put o 'vm-xface t)
540
(overlay-put o 'evaporate t)
541
(overlay-put o 'after-string
542
(char-to-string (char-after pos)))
543
(overlay-put o 'display g)))))))
544
545
(defun vm-convert-xface-to-fsfemacs-image-instantiator (data)
546
(let ((work-buffer nil)
547
retval)
548
(catch 'done
549
(unwind-protect
550
(save-excursion
551
(if (not (stringp vm-uncompface-program))
552
(throw 'done nil))
553
(setq work-buffer (vm-make-work-buffer))
554
(set-buffer work-buffer)
555
(insert data)
556
(setq retval
557
(apply 'call-process-region
558
(point-min) (point-max)
559
vm-uncompface-program t t nil
560
(if vm-uncompface-accepts-dash-x '("-X") nil)))
561
(if (not (eq retval 0))
562
(throw 'done nil))
563
(if vm-uncompface-accepts-dash-x
564
(throw 'done
565
(list 'image ':type 'xbm
566
':ascent 80
567
':foreground "black"
568
':background "white"
569
':data (buffer-string))))
570
(if (not (stringp vm-icontopbm-program))
571
(throw 'done nil))
572
(goto-char (point-min))
573
(insert "/* Width=48, Height=48 */\n");
574
(setq retval
575
(call-process-region
576
(point-min) (point-max)
577
vm-icontopbm-program t t nil))
578
(if (not (eq retval 0))
579
nil
580
(list 'image ':type 'pbm
581
':ascent 80
582
':foreground "black"
583
':background "white"
584
':data (buffer-string))))
585
(and work-buffer (kill-buffer work-buffer))))))
586
587
(defun vm-url-help (object)
588
(format
589
"Use mouse button 2 to send the URL to %s.
590
Use mouse button 3 to choose a Web browser for the URL."
591
(cond ((stringp vm-url-browser) vm-url-browser)
592
((eq vm-url-browser 'w3-fetch)
593
"Emacs W3")
594
((eq vm-url-browser 'w3-fetch-other-frame)
595
"Emacs W3")
596
((eq vm-url-browser 'vm-mouse-send-url-to-mosaic)
597
"Mosaic")
598
((eq vm-url-browser 'vm-mouse-send-url-to-netscape)
599
"Netscape")
600
(t (symbol-name vm-url-browser)))))
601
602
(defun vm-energize-urls-in-message-region (&optional start end)
603
(save-excursion
604
(or start (setq start (vm-headers-of (car vm-message-pointer))))
605
(or end (setq end (vm-text-end-of (car vm-message-pointer))))
606
;; energize the URLs
607
(if (or vm-highlight-url-face vm-url-browser)
608
(save-restriction
609
(widen)
610
(narrow-to-region start end)
611
(vm-energize-urls)))))
612
613
(defun vm-highlight-headers-maybe ()
614
;; highlight the headers
615
(if (or vm-highlighted-header-regexp
616
(and vm-xemacs-p vm-use-lucid-highlighting))
617
(save-restriction
618
(widen)
619
(narrow-to-region (vm-headers-of (car vm-message-pointer))
620
(vm-text-end-of (car vm-message-pointer)))
621
(vm-highlight-headers))))
622
623
(defun vm-energize-headers-and-xfaces ()
624
;; energize certain headers
625
(if (and vm-use-menus (vm-menu-support-possible-p))
626
(save-restriction
627
(widen)
628
(narrow-to-region (vm-headers-of (car vm-message-pointer))
629
(vm-text-of (car vm-message-pointer)))
630
(vm-energize-headers)))
631
;; display xfaces, if we can
632
(if (and vm-display-xfaces
633
(or (and vm-xemacs-p (featurep 'xface))
634
(and vm-fsfemacs-p (fboundp 'create-image)
635
(stringp vm-uncompface-program))))
636
(save-restriction
637
(widen)
638
(narrow-to-region (vm-headers-of (car vm-message-pointer))
639
(vm-text-of (car vm-message-pointer)))
640
(vm-display-xface))))
641
642
(defun vm-narrow-for-preview (&optional just-passing-through)
643
(widen)
644
;; hide as much of the message body as vm-preview-lines specifies
645
(narrow-to-region
646
(vm-vheaders-of (car vm-message-pointer))
647
(cond ((not (eq vm-preview-lines t))
648
(min
649
(vm-text-end-of (car vm-message-pointer))
650
(save-excursion
651
(goto-char (vm-text-of (car vm-message-pointer)))
652
(forward-line (if (natnump vm-preview-lines) vm-preview-lines 0))
653
;; KLUDGE CITY: Under XEmacs, an extent's begin-glyph
654
;; will be displayed even if the extent is at the end
655
;; of a narrowed region. Thus a message containing
656
;; only an image will have the image displayed at
657
;; preview time even if vm-preview-lines is 0 provided
658
;; vm-mime-decode-for-preview is non-nil. We kludge
659
;; a fix for this by moving everything on the preview
660
;; cutoff line one character forward, but only if
661
;; we're doing MIME decode for preview.
662
(if (and (not just-passing-through)
663
vm-xemacs-p
664
vm-mail-buffer ; in presentation buffer
665
vm-auto-decode-mime-messages
666
vm-mime-decode-for-preview
667
;; can't do the kludge unless we know that
668
;; when the message is exposed it will be
669
;; decoded and thereby remove the kludge.
670
(not (vm-mime-plain-message-p (car vm-message-pointer))))
671
(let ((buffer-read-only nil))
672
(insert " ")
673
(forward-char -1)))
674
(point))))
675
(t (vm-text-end-of (car vm-message-pointer))))))
676
677
(defun vm-preview-current-message ()
678
;; Set just-passing-through if the user will never see the
679
;; message in the previewed state. Save some time later by not
680
;; doing preview action that the user will never see anyway.
681
(let ((just-passing-through
682
(or (null vm-preview-lines)
683
(and (not vm-preview-read-messages)
684
(not (vm-new-flag (car vm-message-pointer)))
685
(not (vm-unread-flag (car vm-message-pointer)))))))
686
(vm-save-buffer-excursion
687
(setq vm-system-state 'previewing
688
vm-mime-decoded nil)
689
(if vm-real-buffers
690
(vm-make-virtual-copy (car vm-message-pointer)))
691
692
;; run the message select hooks.
693
(save-excursion
694
(vm-select-folder-buffer)
695
(vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook)
696
(and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer))
697
(vm-run-message-hook (car vm-message-pointer)
698
'vm-select-new-message-hook))
699
(and vm-select-unread-message-hook
700
(vm-unread-flag (car vm-message-pointer))
701
(vm-run-message-hook (car vm-message-pointer)
702
'vm-select-unread-message-hook)))
703
704
(vm-narrow-for-preview just-passing-through)
705
(if (or vm-mime-display-function
706
(natnump vm-fill-paragraphs-containing-long-lines)
707
(and vm-display-using-mime vm-auto-decode-mime-messages
708
(not (vm-mime-plain-message-p (car vm-message-pointer)))))
709
(let ((layout (vm-mm-layout (car vm-message-pointer))))
710
(vm-make-presentation-copy (car vm-message-pointer))
711
(vm-save-buffer-excursion
712
(vm-replace-buffer-in-windows (current-buffer)
713
vm-presentation-buffer))
714
(set-buffer vm-presentation-buffer)
715
(setq vm-system-state 'previewing)
716
(vm-narrow-for-preview))
717
(setq vm-presentation-buffer nil)
718
(and vm-presentation-buffer-handle
719
(vm-replace-buffer-in-windows vm-presentation-buffer-handle
720
(current-buffer))))
721
722
;; at this point the current buffer is the presentation buffer
723
;; if we're using one for this message.
724
(vm-unbury-buffer (current-buffer))
725
726
(if (and vm-display-using-mime
727
vm-auto-decode-mime-messages
728
vm-mime-decode-for-preview
729
(not just-passing-through)
730
(if vm-mail-buffer
731
(not (vm-buffer-variable-value vm-mail-buffer
732
'vm-mime-decoded))
733
(not vm-mime-decoded))
734
(not (vm-mime-plain-message-p (car vm-message-pointer))))
735
(if (eq vm-preview-lines 0)
736
(progn
737
(vm-decode-mime-message-headers (car vm-message-pointer))
738
(vm-energize-urls)
739
(vm-highlight-headers-maybe)
740
(vm-energize-headers-and-xfaces))
741
;; restrict the things that are auto-displayed, since
742
;; decode-for-preview is meant to allow a numeric
743
;; vm-preview-lines to be useful in the face of multipart
744
;; messages.
745
(let ((vm-auto-displayed-mime-content-type-exceptions
746
(cons "message/external-body"
747
vm-auto-displayed-mime-content-type-exceptions))
748
(vm-mime-external-content-types-alist nil))
749
(condition-case data
750
(progn
751
(vm-decode-mime-message)
752
;; reset vm-mime-decoded so that when the user
753
;; opens the message completely, the full MIME
754
;; display will happen.
755
(and vm-mail-buffer
756
(vm-set-buffer-variable vm-mail-buffer
757
'vm-mime-decoded nil)))
758
(vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer)
759
(car (cdr data)))
760
(message "%s" (car (cdr data)))))
761
(vm-narrow-for-preview)))
762
(vm-energize-urls-in-message-region)
763
(vm-highlight-headers-maybe)
764
(vm-energize-headers-and-xfaces))
765
766
(if (and vm-honor-page-delimiters (not just-passing-through))
767
(vm-narrow-to-page))
768
(goto-char (vm-text-of (car vm-message-pointer)))
769
;; If we have a window, set window start appropriately.
770
(let ((w (vm-get-visible-buffer-window (current-buffer))))
771
(if w
772
(progn (set-window-start w (point-min))
773
(set-window-point w (vm-text-of (car vm-message-pointer))))))
774
(if just-passing-through
775
(vm-show-current-message)
776
(vm-update-summary-and-mode-line)))))
777
778
(defun vm-show-current-message ()
779
(and vm-display-using-mime
780
vm-auto-decode-mime-messages
781
(if vm-mail-buffer
782
(not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded))
783
(not vm-mime-decoded))
784
(not (vm-mime-plain-message-p (car vm-message-pointer)))
785
(condition-case data
786
(vm-decode-mime-message)
787
(vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer)
788
(car (cdr data)))
789
(message "%s" (car (cdr data))))))
790
(if (and (natnump vm-fill-paragraphs-containing-long-lines)
791
(vm-mime-plain-message-p (car vm-message-pointer)))
792
(let ((needmsg (> (- (vm-text-end-of (car vm-message-pointer))
793
(vm-text-of (car vm-message-pointer)))
794
12000)))
795
(if needmsg
796
(message "Searching for paragraphs to fill..."))
797
(vm-fill-paragraphs-containing-long-lines
798
vm-fill-paragraphs-containing-long-lines
799
(vm-text-of (car vm-message-pointer))
800
(vm-text-end-of (car vm-message-pointer)))
801
(if needmsg
802
(message "Searching for paragraphs to fill... done"))))
803
(vm-save-buffer-excursion
804
(save-excursion
805
(save-excursion
806
(goto-char (point-min))
807
(widen)
808
(narrow-to-region (point) (vm-text-end-of (car vm-message-pointer))))
809
(if vm-honor-page-delimiters
810
(progn
811
(if (looking-at page-delimiter)
812
(forward-page 1))
813
(vm-narrow-to-page))))
814
;; don't mark the message as read if the user can't see it!
815
(if (vm-get-visible-buffer-window (current-buffer))
816
(progn
817
(save-excursion
818
(setq vm-system-state 'showing)
819
(if vm-mail-buffer
820
(vm-set-buffer-variable vm-mail-buffer 'vm-system-state
821
'showing))
822
;; We could be in the presentation buffer here. Since
823
;; the presentation buffer's message pointer and sole
824
;; message are a mockup, they will cause trouble if
825
;; passed into the undo/update system. So we switch
826
;; into the real message buffer to do attribute
827
;; updates.
828
(vm-select-folder-buffer)
829
(cond ((vm-new-flag (car vm-message-pointer))
830
(vm-set-new-flag (car vm-message-pointer) nil)))
831
(cond ((vm-unread-flag (car vm-message-pointer))
832
(vm-set-unread-flag (car vm-message-pointer) nil))))
833
(vm-update-summary-and-mode-line)
834
(vm-howl-if-eom))
835
(vm-update-summary-and-mode-line))))
836
837
(defun vm-expose-hidden-headers ()
838
"Toggle exposing and hiding message headers that are normally not visible."
839
(interactive)
840
(vm-follow-summary-cursor)
841
(vm-select-folder-buffer)
842
(vm-check-for-killed-summary)
843
(vm-check-for-killed-presentation)
844
(vm-error-if-folder-empty)
845
(and vm-presentation-buffer
846
(set-buffer vm-presentation-buffer))
847
(vm-display (current-buffer) t '(vm-expose-hidden-headers)
848
'(vm-expose-hidden-headers reading-message))
849
(let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer)))))
850
(vm-widen-page)
851
(goto-char (point-max))
852
(widen)
853
(if exposed
854
(narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer)))
855
(narrow-to-region (point) (vm-start-of (car vm-message-pointer))))
856
(goto-char (point-min))
857
(let (w)
858
(setq w (vm-get-visible-buffer-window (current-buffer)))
859
(and w (set-window-point w (point-min)))
860
(and w
861
(= (window-start w) (vm-vheaders-of (car vm-message-pointer)))
862
(not exposed)
863
(set-window-start w (vm-start-of (car vm-message-pointer)))))
864
(if vm-honor-page-delimiters
865
(vm-narrow-to-page))))
866
867
(defun vm-widen-page ()
868
(if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
869
(/= (point-max) (vm-text-end-of (car vm-message-pointer))))
870
(narrow-to-region (vm-vheaders-of (car vm-message-pointer))
871
(if (or (vm-new-flag (car vm-message-pointer))
872
(vm-unread-flag (car vm-message-pointer)))
873
(vm-text-of (car vm-message-pointer))
874
(vm-text-end-of (car vm-message-pointer))))))
875
876
(defun vm-narrow-to-page ()
877
(cond (vm-fsfemacs-p
878
(if (not (and vm-page-end-overlay
879
(overlay-buffer vm-page-end-overlay)))
880
(let ((g vm-page-continuation-glyph))
881
(setq vm-page-end-overlay (make-overlay (point) (point)))
882
(vm-set-extent-property vm-page-end-overlay 'vm-glyph g)
883
(vm-set-extent-property vm-page-end-overlay 'before-string g)
884
(overlay-put vm-page-end-overlay 'evaporate nil))))
885
(vm-xemacs-p
886
(if (not (and vm-page-end-overlay
887
(extent-end-position vm-page-end-overlay)))
888
(let ((g vm-page-continuation-glyph))
889
(cond ((not (glyphp g))
890
(setq g (make-glyph g))
891
(set-glyph-face g 'italic)))
892
(setq vm-page-end-overlay (make-extent (point) (point)))
893
(vm-set-extent-property vm-page-end-overlay 'vm-glyph g)
894
(vm-set-extent-property vm-page-end-overlay 'begin-glyph g)
895
(set-extent-property vm-page-end-overlay 'detachable nil)))))
896
(save-excursion
897
(let (min max (e vm-page-end-overlay))
898
(if (or (bolp) (not (save-excursion
899
(beginning-of-line)
900
(looking-at page-delimiter))))
901
(forward-page -1))
902
(setq min (point))
903
(forward-page 1)
904
(if (not (eobp))
905
(beginning-of-line))
906
(cond ((/= (point) (vm-text-end-of (car vm-message-pointer)))
907
(vm-set-extent-property e vm-begin-glyph-property
908
(vm-extent-property e 'vm-glyph))
909
(vm-set-extent-endpoints e (point) (point)))
910
(t
911
(vm-set-extent-property e vm-begin-glyph-property nil)))
912
(setq max (point))
913
(narrow-to-region min max))))
914
915
(defun vm-beginning-of-message ()
916
"Moves to the beginning of the current message."
917
(interactive)
918
(vm-follow-summary-cursor)
919
(vm-select-folder-buffer)
920
(vm-check-for-killed-summary)
921
(vm-check-for-killed-presentation)
922
(vm-error-if-folder-empty)
923
(and vm-presentation-buffer
924
(set-buffer vm-presentation-buffer))
925
(vm-widen-page)
926
(push-mark)
927
(vm-display (current-buffer) t '(vm-beginning-of-message)
928
'(vm-beginning-of-message reading-message))
929
(vm-save-buffer-excursion
930
(let ((osw (selected-window)))
931
(unwind-protect
932
(progn
933
(select-window (vm-get-visible-buffer-window (current-buffer)))
934
(goto-char (point-min)))
935
(if (not (eq osw (selected-window)))
936
(select-window osw)))))
937
(if vm-honor-page-delimiters
938
(vm-narrow-to-page)))
939
940
(defun vm-end-of-message ()
941
"Moves to the end of the current message, exposing and flagging it read
942
as necessary."
943
(interactive)
944
(vm-follow-summary-cursor)
945
(vm-select-folder-buffer)
946
(vm-check-for-killed-summary)
947
(vm-check-for-killed-presentation)
948
(vm-error-if-folder-empty)
949
(and vm-presentation-buffer
950
(set-buffer vm-presentation-buffer))
951
(if (eq vm-system-state 'previewing)
952
(vm-show-current-message))
953
(setq vm-system-state 'reading)
954
(vm-widen-page)
955
(push-mark)
956
(vm-display (current-buffer) t '(vm-end-of-message)
957
'(vm-end-of-message reading-message))
958
(vm-save-buffer-excursion
959
(let ((osw (selected-window)))
960
(unwind-protect
961
(progn
962
(select-window (vm-get-visible-buffer-window (current-buffer)))
963
(goto-char (point-max)))
964
(if (not (eq osw (selected-window)))
965
(select-window osw)))))
966
(if vm-honor-page-delimiters
967
(vm-narrow-to-page)))
968
969
(defun vm-move-to-next-button (count)
970
"Moves to the next button in the current message.
971
Prefix argument N means move to the Nth next button.
972
Negative N means move to the Nth previous button.
973
If there is no next button, an error is signaled and point is not moved.
974
975
A button is a highlighted region of text where pressing RETURN
976
will produce an action. If the message is being previewed, it is
977
exposed and marked as read."
978
(interactive "p")
979
(vm-follow-summary-cursor)
980
(vm-select-folder-buffer)
981
(vm-check-for-killed-summary)
982
(vm-check-for-killed-presentation)
983
(vm-error-if-folder-empty)
984
(and vm-presentation-buffer
985
(set-buffer vm-presentation-buffer))
986
(if (eq vm-system-state 'previewing)
987
(vm-show-current-message))
988
(setq vm-system-state 'reading)
989
(vm-widen-page)
990
(vm-display (current-buffer) t '(vm-move-to-next-button)
991
'(vm-move-to-next-button reading-message))
992
(select-window (vm-get-visible-buffer-window (current-buffer)))
993
(unwind-protect
994
(vm-move-to-xxxx-button (vm-abs count) (>= count 0))
995
(if vm-honor-page-delimiters
996
(vm-narrow-to-page))))
997
998
(defun vm-move-to-previous-button (count)
999
"Moves to the previous button in the current message.
1000
Prefix argument N means move to the Nth previous button.
1001
Negative N means move to the Nth next button.
1002
If there is no previous button, an error is signaled and point is not moved.
1003
1004
A button is a highlighted region of text where pressing RETURN
1005
will produce an action. If the message is being previewed, it is
1006
exposed and marked as read."
1007
(interactive "p")
1008
(vm-follow-summary-cursor)
1009
(vm-select-folder-buffer)
1010
(vm-check-for-killed-summary)
1011
(vm-check-for-killed-presentation)
1012
(vm-error-if-folder-empty)
1013
(and vm-presentation-buffer
1014
(set-buffer vm-presentation-buffer))
1015
(if (eq vm-system-state 'previewing)
1016
(vm-show-current-message))
1017
(setq vm-system-state 'reading)
1018
(vm-widen-page)
1019
(vm-display (current-buffer) t '(vm-move-to-previous-button)
1020
'(vm-move-to-previous-button reading-message))
1021
(select-window (vm-get-visible-buffer-window (current-buffer)))
1022
(unwind-protect
1023
(vm-move-to-xxxx-button (vm-abs count) (< count 0))
1024
(if vm-honor-page-delimiters
1025
(vm-narrow-to-page))))
1026
1027
(defun vm-move-to-xxxx-button (count next)
1028
(let ((old-point (point))
1029
(endp (if next 'eobp 'bobp))
1030
(extent-end-position (if vm-xemacs-p
1031
(if next
1032
'extent-end-position
1033
'extent-start-position)
1034
(if next
1035
'overlay-end
1036
'overlay-start)))
1037
(next-extent-change (if vm-xemacs-p
1038
(if next
1039
'next-extent-change
1040
'previous-extent-change)
1041
(if next
1042
'next-overlay-change
1043
'previous-overlay-change)))
1044
e)
1045
(while (and (> count 0) (not (funcall endp)))
1046
(goto-char (funcall next-extent-change (+ (point) (if next 0 -1))))
1047
(setq e (vm-extent-at (point)))
1048
(if e
1049
(progn
1050
(if (vm-extent-property e 'vm-button)
1051
(vm-decrement count))
1052
(goto-char (funcall extent-end-position e)))))
1053
(if e
1054
(goto-char (vm-extent-start-position e))
1055
(goto-char old-point)
1056
(error "No more buttons"))))
1057
1058
(provide 'vm-page)
Loggerhead is a web-based interface for Breezy
Version: 2.0.1