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)