Mercurial > hg > xemacs-beta
diff lisp/vm/vm-page.el @ 20:859a2309aef8 r19-15b93
Import from CVS: tag r19-15b93
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:50:05 +0200 |
parents | 376386a54a3c |
children | 4103f0995bd7 |
line wrap: on
line diff
--- a/lisp/vm/vm-page.el Mon Aug 13 08:49:44 2007 +0200 +++ b/lisp/vm/vm-page.el Mon Aug 13 08:50:05 2007 +0200 @@ -1,5 +1,5 @@ ;;; Commands to move around within a VM message -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989-1997 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 @@ -28,18 +28,24 @@ (was-invisible nil)) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (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)))) + (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 (= (window-start w) (point-max)) - (set-window-start w (point-min)))) - (setq was-invisible t))) + (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 @@ -103,14 +109,20 @@ (t (and (> (prefix-numeric-value arg) 0) (vm-howl-if-eom))))))) - (if (not (or vm-startup-message-displayed vm-inhibit-startup-message)) + (if (not vm-startup-message-displayed) (vm-display-startup-message))) (defun vm-scroll-forward-internal (arg) (let ((direction (prefix-numeric-value arg)) (w (selected-window))) (condition-case error-data - (progn (scroll-up arg) nil) + (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)))) @@ -237,7 +249,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)) + search-pairs n) (if (and search-limit (> (- (point-max) (point-min)) search-limit)) (setq search-pairs (list (cons (point-min) (+ (point-min) (/ search-limit 2))) @@ -256,14 +268,18 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq e (make-extent (match-beginning 0) (match-end 0))) + (setq n 1) + (while (null (match-beginning n)) + (vm-increment n)) + (setq e (make-extent (match-beginning n) (match-end n))) (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))) (define-key keymap 'button2 'vm-mouse-send-url-at-event) - (define-key keymap 'button3 'vm-menu-popup-url-browser-menu) + (if vm-popup-menu-on-mouse-3 + (define-key keymap 'button3 'vm-menu-popup-url-browser-menu)) (define-key keymap "\r" (function (lambda () (interactive) (vm-mouse-send-url-at-position (point))))) @@ -288,12 +304,21 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq o (make-overlay (match-beginning 0) (match-end 0))) + (setq n 1) + (while (null (match-beginning n)) + (vm-increment n)) + (setq o (make-overlay (match-beginning n) (match-end n))) (overlay-put o 'vm-url t) (if vm-highlight-url-face (overlay-put o 'face vm-highlight-url-face)) (if vm-url-browser - (overlay-put o 'mouse-face 'highlight))) + (let ((keymap (make-sparse-keymap))) + (overlay-put o 'mouse-face 'highlight) + (setq keymap (nconc keymap (current-local-map))) + (define-key keymap "\r" + (function (lambda () (interactive) + (vm-mouse-send-url-at-position (point))))) + (overlay-put o 'local-map keymap)))) (setq search-pairs (cdr search-pairs)))))))) (defun vm-energize-headers () @@ -324,9 +349,10 @@ (define-key keymap 'button2 (list 'lambda () '(interactive) (list 'popup-menu (list 'quote menu)))) - (define-key keymap 'button3 - (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))))) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help) (set-extent-property e 'highlight t)) @@ -410,10 +436,48 @@ "Netscape") (t (symbol-name vm-url-browser))))) -(defun vm-preview-current-message () - (setq vm-system-state 'previewing) - (if vm-real-buffers - (vm-make-virtual-copy (car vm-message-pointer))) +(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) + (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)))) + +(defun vm-narrow-for-preview () (widen) ;; hide as much of the message body as vm-preview-lines specifies (narrow-to-region @@ -425,86 +489,104 @@ (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))))) - ;; 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))) + (t (vm-text-end-of (car vm-message-pointer)))))) + +(defun vm-preview-current-message () + (vm-save-buffer-excursion + (setq vm-system-state 'previewing) + (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))) - ;; 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-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)))) - (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)) + ;; at this point the current buffer is the presentation buffer + ;; if we're using one for this message. + + (vm-energize-urls-in-message-region) + (vm-highlight-headers-maybe) + (vm-energize-headers-and-xfaces) - (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 () - (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))) + (and vm-display-using-mime + vm-auto-decode-mime-messages + (not vm-mime-decoded) + (not (vm-mime-plain-message-p (car vm-message-pointer))) + (vm-decode-mime-message)) + (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)))) (defun vm-expose-hidden-headers () "Toggle exposing and hiding message headers that are normally not visible." @@ -512,7 +594,10 @@ (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))))) @@ -561,7 +646,10 @@ (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) @@ -583,7 +671,10 @@ (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)