Mercurial > hg > xemacs-beta
diff lisp/vm/vm-page.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 05472e90ae02 |
children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/vm/vm-page.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/vm/vm-page.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; Commands to move around within a VM message -;;; Copyright (C) 1989-1997 Kyle E. Jones +;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -25,35 +25,22 @@ Prefix argument N means scroll forward N lines." (interactive "P") (let ((mp-changed (vm-follow-summary-cursor)) - needs-decoding (was-invisible nil)) (vm-select-folder-buffer) (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (setq needs-decoding (and vm-display-using-mime - (not vm-mime-decoded) - (not (vm-mime-plain-message-p - (car vm-message-pointer))) - vm-auto-decode-mime-messages - (eq vm-system-state 'previewing))) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (let ((point (point)) - (w (vm-get-visible-buffer-window (current-buffer)))) - (if (or (null w) - (not (vm-frame-totally-visible-p (vm-window-frame w)))) - (progn - (vm-display (current-buffer) t - '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message)) - ;; window start sticks to end of clip region when clip - ;; region moves back past it in the buffer. fix it. - (setq w (vm-get-visible-buffer-window (current-buffer))) + (if (null (vm-get-visible-buffer-window (current-buffer))) + (let ((point (point))) + (vm-display (current-buffer) t + '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message)) + ;; window start sticks to end of clip region when clip + ;; region moves back past it in the buffer. fix it. + (let ((w (vm-get-visible-buffer-window (current-buffer)))) (if (= (window-start w) (point-max)) - (set-window-start w (point-min))) - (setq was-invisible t)))) - (if (or mp-changed was-invisible needs-decoding + (set-window-start w (point-min)))) + (setq was-invisible t))) + (if (or mp-changed was-invisible (and (eq vm-system-state 'previewing) (pos-visible-in-window-p (point-max) @@ -116,7 +103,7 @@ (t (and (> (prefix-numeric-value arg) 0) (vm-howl-if-eom))))))) - (if (not vm-startup-message-displayed) + (if (not (or vm-startup-message-displayed vm-inhibit-startup-message)) (vm-display-startup-message))) (defun vm-scroll-forward-internal (arg) @@ -124,18 +111,6 @@ (w (selected-window))) (condition-case error-data (progn (scroll-up arg) nil) -;; this looks like it should work, but doesn't because the -;; redisplay code is schizophrenic when it comes to updates. A -;; window position may no longer be visible but -;; pos-visible-in-window-p will still say it is because it was -;; visible before some window size change happened. -;; (progn -;; (if (and (> direction 0) -;; (pos-visible-in-window-p -;; (vm-text-end-of (car vm-message-pointer)))) -;; (signal 'end-of-buffer nil) -;; (scroll-up arg)) -;; nil ) (error (if (or (and (< direction 0) (> (point-min) (vm-text-of (car vm-message-pointer)))) @@ -171,7 +146,7 @@ ;; answer about where the end of the message is going to be ;; visible when redisplay finally does occur. (defun vm-howl-if-eom () - (let ((w (get-buffer-window (current-buffer)))) + (let ((w (vm-get-visible-buffer-window (current-buffer)))) (and w (save-excursion (save-window-excursion @@ -194,13 +169,13 @@ (defun vm-emit-eom-blurb () (if (vm-full-name-of (car vm-message-pointer)) - (message "End of message %s from %s" + (vm-unsaved-message "End of message %s from %s" (vm-number-of (car vm-message-pointer)) (vm-full-name-of (car vm-message-pointer))) - (message "End of message %s" + (vm-unsaved-message "End of message %s" (vm-number-of (car vm-message-pointer))))) -(defun vm-scroll-backward (&optional arg) +(defun vm-scroll-backward (arg) "Scroll backward a screenful of text. Prefix N scrolls backward N lines." (interactive "P") @@ -212,14 +187,14 @@ (defun vm-highlight-headers () (cond - ((and vm-xemacs-p vm-use-lucid-highlighting) + ((and (vm-xemacs-p) vm-use-lucid-highlighting) (require 'highlight-headers) ;; disable the url marking stuff, since VM has its own interface. (let ((highlight-headers-mark-urls nil) (highlight-headers-regexp (or vm-highlighted-header-regexp highlight-headers-regexp))) (highlight-headers (point-min) (point-max) t))) - (vm-xemacs-p + ((vm-xemacs-p) (let (e) (map-extents (function (lambda (e ignore) @@ -262,7 +237,7 @@ ;; large, search just the head and the tail of the region since ;; they tend to contain the interesting text. (let ((search-limit vm-url-search-limit) - search-pairs n) + (search-pairs)) (if (and search-limit (> (- (point-max) (point-min)) search-limit)) (setq search-pairs (list (cons (point-min) (+ (point-min) (/ search-limit 2))) @@ -270,7 +245,7 @@ (point-max)))) (setq search-pairs (list (cons (point-min) (point-max))))) (cond - (vm-xemacs-p + ((vm-xemacs-p) (let (e) (map-extents (function (lambda (e ignore) @@ -281,24 +256,14 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq n 1) - (while (null (match-beginning n)) - (vm-increment n)) - (setq e (make-extent (match-beginning n) (match-end n))) + (setq e (make-extent (match-beginning 0) (match-end 0))) (set-extent-property e 'vm-url t) (if vm-highlight-url-face (set-extent-property e 'face vm-highlight-url-face)) (if vm-url-browser - (let ((keymap (make-sparse-keymap)) - (popup-function - (if (save-excursion - (goto-char (match-beginning n)) - (looking-at "mailto:")) - 'vm-menu-popup-mailto-url-browser-menu - 'vm-menu-popup-url-browser-menu))) + (let ((keymap (make-sparse-keymap))) (define-key keymap 'button2 'vm-mouse-send-url-at-event) - (if vm-popup-menu-on-mouse-3 - (define-key keymap 'button3 popup-function)) + (define-key keymap 'button3 'vm-menu-popup-url-browser-menu) (define-key keymap "\r" (function (lambda () (interactive) (vm-mouse-send-url-at-position (point))))) @@ -306,7 +271,7 @@ (set-extent-property e 'balloon-help 'vm-url-help) (set-extent-property e 'highlight t)))) (setq search-pairs (cdr search-pairs))))) - ((and vm-fsfemacs-19-p + ((and (vm-fsfemacs-19-p) (fboundp 'overlay-put)) (let (o-lists o p) (setq o-lists (overlay-lists) @@ -323,34 +288,17 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq n 1) - (while (null (match-beginning n)) - (vm-increment n)) - (setq o (make-overlay (match-beginning n) (match-end n))) + (setq o (make-overlay (match-beginning 0) (match-end 0))) (overlay-put o 'vm-url t) (if vm-highlight-url-face (overlay-put o 'face vm-highlight-url-face)) (if vm-url-browser - (let ((keymap (make-sparse-keymap)) - (popup-function - (if (save-excursion - (goto-char (match-beginning n)) - (looking-at "mailto:")) - 'vm-menu-popup-mailto-url-browser-menu - 'vm-menu-popup-url-browser-menu))) - (overlay-put o 'mouse-face 'highlight) - (setq keymap (nconc keymap (current-local-map))) - (if vm-popup-menu-on-mouse-3 - (define-key keymap [mouse-3] popup-function)) - (define-key keymap "\r" - (function (lambda () (interactive) - (vm-mouse-send-url-at-position (point))))) - (overlay-put o 'local-map keymap)))) + (overlay-put o 'mouse-face 'highlight))) (setq search-pairs (cdr search-pairs)))))))) (defun vm-energize-headers () (cond - (vm-xemacs-p + ((vm-xemacs-p) (let ((search-tuples '(("^From:" vm-menu-author-menu) ("^Subject:" vm-menu-subject-menu))) regexp menu keymap e) @@ -376,15 +324,14 @@ (define-key keymap 'button2 (list 'lambda () '(interactive) (list 'popup-menu (list 'quote menu)))) - (if vm-popup-menu-on-mouse-3 - (define-key keymap 'button3 - (list 'lambda () '(interactive) - (list 'popup-menu (list 'quote menu))))) + (define-key keymap 'button3 + (list 'lambda () '(interactive) + (list 'popup-menu (list 'quote menu)))) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help) (set-extent-property e 'highlight t)) (setq search-tuples (cdr search-tuples))))) - ((and vm-fsfemacs-19-p + ((and (vm-fsfemacs-19-p) (fboundp 'overlay-put)) (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu) ("^Subject:" vm-menu-fsfemacs-subject-menu))) @@ -433,14 +380,11 @@ (progn (goto-char (match-beginning 0)) (vm-match-header) - (setq h (concat "X-Face: " (vm-matched-header-contents))) + (setq h (vm-matched-header)) (setq g (intern h vm-xface-cache)) (if (boundp g) (setq g (symbol-value g)) - (set g (make-glyph - (list - (list 'global (cons '(tty) [nothing])) - (list 'global (cons '(win) (vector 'xface ':data h)))))) + (set g (make-glyph h)) (setq g (symbol-value g)) ;; XXX broken. Gives extra pixel lines at the ;; bottom of the glyph in 19.12 @@ -466,46 +410,10 @@ "Netscape") (t (symbol-name vm-url-browser))))) -(defun vm-energize-urls-in-message-region (&optional start end) - (save-excursion - (or start (setq start (vm-headers-of (car vm-message-pointer)))) - (or end (setq end (vm-text-end-of (car vm-message-pointer)))) - ;; energize the URLs - (if (or vm-highlight-url-face vm-url-browser) - (save-restriction - (widen) - (narrow-to-region start end) - (vm-energize-urls))))) - -(defun vm-highlight-headers-maybe () - ;; highlight the headers - (if (or vm-highlighted-header-regexp - (and vm-xemacs-p vm-use-lucid-highlighting)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer))) - (vm-highlight-headers)))) - -(defun vm-energize-headers-and-xfaces () - ;; energize certain headers - (if (and vm-use-menus (vm-menu-support-possible-p)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-energize-headers))) - ;; display xfaces, if we can - (if (and vm-display-xfaces - vm-xemacs-p - (featurep 'xface)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-display-xface)))) - -(defun vm-narrow-for-preview () +(defun vm-preview-current-message () + (setq vm-system-state 'previewing) + (if vm-real-buffers + (vm-make-virtual-copy (car vm-message-pointer))) (widen) ;; hide as much of the message body as vm-preview-lines specifies (narrow-to-region @@ -517,112 +425,86 @@ (goto-char (vm-text-of (car vm-message-pointer))) (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0)) (point)))) - (t (vm-text-end-of (car vm-message-pointer)))))) - -(defun vm-preview-current-message () - (vm-save-buffer-excursion - (setq vm-system-state 'previewing - vm-mime-decoded nil) - (if vm-real-buffers - (vm-make-virtual-copy (car vm-message-pointer))) - - ;; run the message select hooks. - (save-excursion - (vm-select-folder-buffer) - (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook) - (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-new-message-hook)) - (and vm-select-unread-message-hook - (vm-unread-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-unread-message-hook))) + (t (vm-text-end-of (car vm-message-pointer))))) + ;; highlight the headers + (if (or vm-highlighted-header-regexp + (and (vm-xemacs-p) vm-use-lucid-highlighting)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-end-of (car vm-message-pointer))) + (vm-highlight-headers))) + ;; energize the URLs + (if (or vm-highlight-url-face vm-url-browser) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-end-of (car vm-message-pointer))) + (vm-energize-urls))) + ;; energize certain headers + (if (and vm-use-menus (vm-menu-support-possible-p)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-of (car vm-message-pointer))) + (vm-energize-headers))) - (vm-narrow-for-preview) - (if (or vm-mime-display-function - (and vm-display-using-mime - (not (vm-mime-plain-message-p (car vm-message-pointer))))) - (let ((layout (vm-mm-layout (car vm-message-pointer)))) - (vm-make-presentation-copy (car vm-message-pointer)) - (vm-save-buffer-excursion - (vm-replace-buffer-in-windows (current-buffer) - vm-presentation-buffer)) - (set-buffer vm-presentation-buffer) - (setq vm-system-state 'previewing) - (vm-narrow-for-preview)) - (setq vm-presentation-buffer nil) - (and vm-presentation-buffer-handle - (vm-replace-buffer-in-windows vm-presentation-buffer-handle - (current-buffer)))) - - ;; at this point the current buffer is the presentation buffer - ;; if we're using one for this message. + ;; display xfaces, if we can + (if (and vm-display-xfaces + (vm-xemacs-p) + (vm-multiple-frames-possible-p) + (featurep 'xface)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-of (car vm-message-pointer))) + (vm-display-xface))) - (vm-unbury-buffer (current-buffer)) - (vm-energize-urls-in-message-region) - (vm-highlight-headers-maybe) - (vm-energize-headers-and-xfaces) + (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook) + (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) + (vm-run-message-hook (car vm-message-pointer) + 'vm-select-new-message-hook)) + (and vm-select-unread-message-hook (vm-unread-flag (car vm-message-pointer)) + (vm-run-message-hook (car vm-message-pointer) + 'vm-select-unread-message-hook)) - (if vm-honor-page-delimiters - (vm-narrow-to-page)) - (goto-char (vm-text-of (car vm-message-pointer))) - ;; If we have a window, set window start appropriately. - (let ((w (vm-get-visible-buffer-window (current-buffer)))) - (if w - (progn (set-window-start w (point-min)) - (set-window-point w (vm-text-of (car vm-message-pointer)))))) - (if (or (null vm-preview-lines) - (and (not vm-preview-read-messages) - (not (vm-new-flag (car vm-message-pointer))) - (not (vm-unread-flag (car vm-message-pointer))))) - (vm-show-current-message) - (vm-update-summary-and-mode-line)))) + (if vm-honor-page-delimiters + (vm-narrow-to-page)) + (goto-char (vm-text-of (car vm-message-pointer))) + ;; If we have a window, set window start appropriately. + (let ((w (vm-get-visible-buffer-window (current-buffer)))) + (if w + (progn (set-window-start w (point-min)) + (set-window-point w (vm-text-of (car vm-message-pointer)))))) + (if (or (null vm-preview-lines) + (and (not vm-preview-read-messages) + (not (vm-new-flag (car vm-message-pointer))) + (not (vm-unread-flag (car vm-message-pointer))))) + (vm-show-current-message) + (vm-update-summary-and-mode-line))) (defun vm-show-current-message () - (and vm-display-using-mime - vm-auto-decode-mime-messages - (if vm-mail-buffer - (not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded)) - (not vm-mime-decoded)) - (not (vm-mime-plain-message-p (car vm-message-pointer))) - (condition-case data - (vm-decode-mime-message) - (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer) - (car (cdr data))) - (message "%s" (car (cdr data)))))) - (vm-save-buffer-excursion - (save-excursion - (save-excursion - (goto-char (point-min)) - (widen) - (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) - (if vm-honor-page-delimiters - (progn - (if (looking-at page-delimiter) - (forward-page 1)) - (vm-narrow-to-page)))) - ;; don't mark the message as read if the user can't see it! - (if (vm-get-visible-buffer-window (current-buffer)) - (progn - (save-excursion - (setq vm-system-state 'showing) - (if vm-mail-buffer - (vm-set-buffer-variable vm-mail-buffer 'vm-system-state - 'showing)) - ;; We could be in the presentation buffer here. Since - ;; the presentation buffer's message pointer and sole - ;; message are a mockup, they will cause trouble if - ;; passed into the undo/update system. So we switch - ;; into the real message buffer to do attribute - ;; updates. - (vm-select-folder-buffer) - (cond ((vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil))) - (cond ((vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil)))) - (vm-update-summary-and-mode-line) - (vm-howl-if-eom)) - (vm-update-summary-and-mode-line)))) + (save-excursion + (save-excursion + (goto-char (point-min)) + (widen) + (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) + (if vm-honor-page-delimiters + (progn + (if (looking-at page-delimiter) + (forward-page 1)) + (vm-narrow-to-page)))) + ;; don't mark the message as read if the user can't see it! + (if (vm-get-visible-buffer-window (current-buffer)) + (progn + (setq vm-system-state 'showing) + (cond ((vm-new-flag (car vm-message-pointer)) + (vm-set-new-flag (car vm-message-pointer) nil))) + (cond ((vm-unread-flag (car vm-message-pointer)) + (vm-set-unread-flag (car vm-message-pointer) nil))) + (vm-update-summary-and-mode-line) + (vm-howl-if-eom)) + (vm-update-summary-and-mode-line))) (defun vm-expose-hidden-headers () "Toggle exposing and hiding message headers that are normally not visible." @@ -630,10 +512,7 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) (vm-display (current-buffer) t '(vm-expose-hidden-headers) '(vm-expose-hidden-headers reading-message)) (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer))))) @@ -682,10 +561,7 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) (vm-widen-page) (push-mark) (vm-display (current-buffer) t '(vm-beginning-of-message) @@ -707,10 +583,7 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading)