Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-page.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents c53a95d3c46d
children 131b0175ea99
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
23 If at the end of the current message, moves to the next message iff the 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. 24 value of vm-auto-next-message is non-nil.
25 Prefix argument N means scroll forward N lines." 25 Prefix argument N means scroll forward N lines."
26 (interactive "P") 26 (interactive "P")
27 (let ((mp-changed (vm-follow-summary-cursor)) 27 (let ((mp-changed (vm-follow-summary-cursor))
28 needs-decoding
28 (was-invisible nil)) 29 (was-invisible nil))
29 (vm-select-folder-buffer) 30 (vm-select-folder-buffer)
30 (vm-check-for-killed-summary) 31 (vm-check-for-killed-summary)
31 (vm-check-for-killed-presentation) 32 (vm-check-for-killed-presentation)
32 (vm-error-if-folder-empty) 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)))
33 (and vm-presentation-buffer 40 (and vm-presentation-buffer
34 (set-buffer vm-presentation-buffer)) 41 (set-buffer vm-presentation-buffer))
35 (let ((point (point)) 42 (let ((point (point))
36 (w (vm-get-visible-buffer-window (current-buffer)))) 43 (w (vm-get-visible-buffer-window (current-buffer))))
37 (if (or (null w) 44 (if (or (null w)
44 ;; region moves back past it in the buffer. fix it. 51 ;; region moves back past it in the buffer. fix it.
45 (setq w (vm-get-visible-buffer-window (current-buffer))) 52 (setq w (vm-get-visible-buffer-window (current-buffer)))
46 (if (= (window-start w) (point-max)) 53 (if (= (window-start w) (point-max))
47 (set-window-start w (point-min))) 54 (set-window-start w (point-min)))
48 (setq was-invisible t)))) 55 (setq was-invisible t))))
49 (if (or mp-changed was-invisible 56 (if (or mp-changed was-invisible needs-decoding
50 (and (eq vm-system-state 'previewing) 57 (and (eq vm-system-state 'previewing)
51 (pos-visible-in-window-p 58 (pos-visible-in-window-p
52 (point-max) 59 (point-max)
53 (vm-get-visible-buffer-window (current-buffer))))) 60 (vm-get-visible-buffer-window (current-buffer)))))
54 (progn 61 (progn
191 (vm-number-of (car vm-message-pointer)) 198 (vm-number-of (car vm-message-pointer))
192 (vm-full-name-of (car vm-message-pointer))) 199 (vm-full-name-of (car vm-message-pointer)))
193 (message "End of message %s" 200 (message "End of message %s"
194 (vm-number-of (car vm-message-pointer))))) 201 (vm-number-of (car vm-message-pointer)))))
195 202
196 (defun vm-scroll-backward (arg) 203 (defun vm-scroll-backward (&optional arg)
197 "Scroll backward a screenful of text. 204 "Scroll backward a screenful of text.
198 Prefix N scrolls backward N lines." 205 Prefix N scrolls backward N lines."
199 (interactive "P") 206 (interactive "P")
200 (vm-scroll-forward (cond ((null arg) '-) 207 (vm-scroll-forward (cond ((null arg) '-)
201 ((consp arg) (list (- (car arg)))) 208 ((consp arg) (list (- (car arg))))
203 ((symbolp arg) nil) 210 ((symbolp arg) nil)
204 (t arg)))) 211 (t arg))))
205 212
206 (defun vm-highlight-headers () 213 (defun vm-highlight-headers ()
207 (cond 214 (cond
208 ((and (vm-xemacs-p) vm-use-lucid-highlighting) 215 ((and vm-xemacs-p vm-use-lucid-highlighting)
209 (require 'highlight-headers) 216 (require 'highlight-headers)
210 ;; disable the url marking stuff, since VM has its own interface. 217 ;; disable the url marking stuff, since VM has its own interface.
211 (let ((highlight-headers-mark-urls nil) 218 (let ((highlight-headers-mark-urls nil)
212 (highlight-headers-regexp (or vm-highlighted-header-regexp 219 (highlight-headers-regexp (or vm-highlighted-header-regexp
213 highlight-headers-regexp))) 220 highlight-headers-regexp)))
214 (highlight-headers (point-min) (point-max) t))) 221 (highlight-headers (point-min) (point-max) t)))
215 ((vm-xemacs-p) 222 (vm-xemacs-p
216 (let (e) 223 (let (e)
217 (map-extents (function 224 (map-extents (function
218 (lambda (e ignore) 225 (lambda (e ignore)
219 (if (extent-property e 'vm-highlight) 226 (if (extent-property e 'vm-highlight)
220 (delete-extent e)) 227 (delete-extent e))
261 (+ (point-min) (/ search-limit 2))) 268 (+ (point-min) (/ search-limit 2)))
262 (cons (- (point-max) (/ search-limit 2)) 269 (cons (- (point-max) (/ search-limit 2))
263 (point-max)))) 270 (point-max))))
264 (setq search-pairs (list (cons (point-min) (point-max))))) 271 (setq search-pairs (list (cons (point-min) (point-max)))))
265 (cond 272 (cond
266 ((vm-xemacs-p) 273 (vm-xemacs-p
267 (let (e) 274 (let (e)
268 (map-extents (function 275 (map-extents (function
269 (lambda (e ignore) 276 (lambda (e ignore)
270 (if (extent-property e 'vm-url) 277 (if (extent-property e 'vm-url)
271 (delete-extent e)) 278 (delete-extent e))
280 (setq e (make-extent (match-beginning n) (match-end n))) 287 (setq e (make-extent (match-beginning n) (match-end n)))
281 (set-extent-property e 'vm-url t) 288 (set-extent-property e 'vm-url t)
282 (if vm-highlight-url-face 289 (if vm-highlight-url-face
283 (set-extent-property e 'face vm-highlight-url-face)) 290 (set-extent-property e 'face vm-highlight-url-face))
284 (if vm-url-browser 291 (if vm-url-browser
285 (let ((keymap (make-sparse-keymap))) 292 (let ((keymap (make-sparse-keymap))
293 (popup-function
294 (if (save-excursion
295 (goto-char (match-beginning n))
296 (looking-at "mailto:"))
297 'vm-menu-popup-mailto-url-browser-menu
298 'vm-menu-popup-url-browser-menu)))
286 (define-key keymap 'button2 'vm-mouse-send-url-at-event) 299 (define-key keymap 'button2 'vm-mouse-send-url-at-event)
287 (if vm-popup-menu-on-mouse-3 300 (if vm-popup-menu-on-mouse-3
288 (define-key keymap 'button3 'vm-menu-popup-url-browser-menu)) 301 (define-key keymap 'button3 popup-function))
289 (define-key keymap "\r" 302 (define-key keymap "\r"
290 (function (lambda () (interactive) 303 (function (lambda () (interactive)
291 (vm-mouse-send-url-at-position (point))))) 304 (vm-mouse-send-url-at-position (point)))))
292 (set-extent-property e 'keymap keymap) 305 (set-extent-property e 'keymap keymap)
293 (set-extent-property e 'balloon-help 'vm-url-help) 306 (set-extent-property e 'balloon-help 'vm-url-help)
294 (set-extent-property e 'highlight t)))) 307 (set-extent-property e 'highlight t))))
295 (setq search-pairs (cdr search-pairs))))) 308 (setq search-pairs (cdr search-pairs)))))
296 ((and (vm-fsfemacs-19-p) 309 ((and vm-fsfemacs-19-p
297 (fboundp 'overlay-put)) 310 (fboundp 'overlay-put))
298 (let (o-lists o p) 311 (let (o-lists o p)
299 (setq o-lists (overlay-lists) 312 (setq o-lists (overlay-lists)
300 p (car o-lists)) 313 p (car o-lists))
301 (while p 314 (while p
316 (setq o (make-overlay (match-beginning n) (match-end n))) 329 (setq o (make-overlay (match-beginning n) (match-end n)))
317 (overlay-put o 'vm-url t) 330 (overlay-put o 'vm-url t)
318 (if vm-highlight-url-face 331 (if vm-highlight-url-face
319 (overlay-put o 'face vm-highlight-url-face)) 332 (overlay-put o 'face vm-highlight-url-face))
320 (if vm-url-browser 333 (if vm-url-browser
321 (let ((keymap (make-sparse-keymap))) 334 (let ((keymap (make-sparse-keymap))
335 (popup-function
336 (if (save-excursion
337 (goto-char (match-beginning n))
338 (looking-at "mailto:"))
339 'vm-menu-popup-mailto-url-browser-menu
340 'vm-menu-popup-url-browser-menu)))
322 (overlay-put o 'mouse-face 'highlight) 341 (overlay-put o 'mouse-face 'highlight)
323 (setq keymap (nconc keymap (current-local-map))) 342 (setq keymap (nconc keymap (current-local-map)))
343 (if vm-popup-menu-on-mouse-3
344 (define-key keymap [mouse-3] popup-function))
324 (define-key keymap "\r" 345 (define-key keymap "\r"
325 (function (lambda () (interactive) 346 (function (lambda () (interactive)
326 (vm-mouse-send-url-at-position (point))))) 347 (vm-mouse-send-url-at-position (point)))))
327 (overlay-put o 'local-map keymap)))) 348 (overlay-put o 'local-map keymap))))
328 (setq search-pairs (cdr search-pairs)))))))) 349 (setq search-pairs (cdr search-pairs))))))))
329 350
330 (defun vm-energize-headers () 351 (defun vm-energize-headers ()
331 (cond 352 (cond
332 ((vm-xemacs-p) 353 (vm-xemacs-p
333 (let ((search-tuples '(("^From:" vm-menu-author-menu) 354 (let ((search-tuples '(("^From:" vm-menu-author-menu)
334 ("^Subject:" vm-menu-subject-menu))) 355 ("^Subject:" vm-menu-subject-menu)))
335 regexp menu keymap e) 356 regexp menu keymap e)
336 (map-extents (function 357 (map-extents (function
337 (lambda (e ignore) 358 (lambda (e ignore)
361 (list 'popup-menu (list 'quote menu))))) 382 (list 'popup-menu (list 'quote menu)))))
362 (set-extent-property e 'keymap keymap) 383 (set-extent-property e 'keymap keymap)
363 (set-extent-property e 'balloon-help 'vm-mouse-3-help) 384 (set-extent-property e 'balloon-help 'vm-mouse-3-help)
364 (set-extent-property e 'highlight t)) 385 (set-extent-property e 'highlight t))
365 (setq search-tuples (cdr search-tuples))))) 386 (setq search-tuples (cdr search-tuples)))))
366 ((and (vm-fsfemacs-19-p) 387 ((and vm-fsfemacs-19-p
367 (fboundp 'overlay-put)) 388 (fboundp 'overlay-put))
368 (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu) 389 (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu)
369 ("^Subject:" vm-menu-fsfemacs-subject-menu))) 390 ("^Subject:" vm-menu-fsfemacs-subject-menu)))
370 regexp menu 391 regexp menu
371 o-lists o p) 392 o-lists o p)
414 (vm-match-header) 435 (vm-match-header)
415 (setq h (concat "X-Face: " (vm-matched-header-contents))) 436 (setq h (concat "X-Face: " (vm-matched-header-contents)))
416 (setq g (intern h vm-xface-cache)) 437 (setq g (intern h vm-xface-cache))
417 (if (boundp g) 438 (if (boundp g)
418 (setq g (symbol-value g)) 439 (setq g (symbol-value g))
419 (set g (make-glyph h)) 440 (set g (make-glyph
441 (list
442 (list 'global (cons '(tty) [nothing]))
443 (list 'global (cons '(win) (vector 'xface ':data h))))))
420 (setq g (symbol-value g)) 444 (setq g (symbol-value g))
421 ;; XXX broken. Gives extra pixel lines at the 445 ;; XXX broken. Gives extra pixel lines at the
422 ;; bottom of the glyph in 19.12 446 ;; bottom of the glyph in 19.12
423 ;;(set-glyph-baseline g 100) 447 ;;(set-glyph-baseline g 100)
424 (set-glyph-face g 'vm-xface)) 448 (set-glyph-face g 'vm-xface))
454 (vm-energize-urls))))) 478 (vm-energize-urls)))))
455 479
456 (defun vm-highlight-headers-maybe () 480 (defun vm-highlight-headers-maybe ()
457 ;; highlight the headers 481 ;; highlight the headers
458 (if (or vm-highlighted-header-regexp 482 (if (or vm-highlighted-header-regexp
459 (and (vm-xemacs-p) vm-use-lucid-highlighting)) 483 (and vm-xemacs-p vm-use-lucid-highlighting))
460 (save-restriction 484 (save-restriction
461 (widen) 485 (widen)
462 (narrow-to-region (vm-headers-of (car vm-message-pointer)) 486 (narrow-to-region (vm-headers-of (car vm-message-pointer))
463 (vm-text-end-of (car vm-message-pointer))) 487 (vm-text-end-of (car vm-message-pointer)))
464 (vm-highlight-headers)))) 488 (vm-highlight-headers))))
471 (narrow-to-region (vm-headers-of (car vm-message-pointer)) 495 (narrow-to-region (vm-headers-of (car vm-message-pointer))
472 (vm-text-of (car vm-message-pointer))) 496 (vm-text-of (car vm-message-pointer)))
473 (vm-energize-headers))) 497 (vm-energize-headers)))
474 ;; display xfaces, if we can 498 ;; display xfaces, if we can
475 (if (and vm-display-xfaces 499 (if (and vm-display-xfaces
476 (vm-xemacs-p) 500 vm-xemacs-p
477 (vm-multiple-frames-possible-p)
478 (featurep 'xface)) 501 (featurep 'xface))
479 (save-restriction 502 (save-restriction
480 (widen) 503 (widen)
481 (narrow-to-region (vm-headers-of (car vm-message-pointer)) 504 (narrow-to-region (vm-headers-of (car vm-message-pointer))
482 (vm-text-of (car vm-message-pointer))) 505 (vm-text-of (car vm-message-pointer)))