X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-message.el;h=297e4a3ef507f3078a38e76469af722adc3ee891;hb=1f17ca3778008a59589a183a9440329055089d01;hp=37bb7ba52235b26ff60d5ab9eb7586334166843e;hpb=1e366a559be4aec4ad4d3cf3e954b8e62a20d2f3;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-message.el b/wl/wl-message.el
index 37bb7ba..297e4a3 100644
--- a/wl/wl-message.el
+++ b/wl/wl-message.el
@@ -1,10 +1,9 @@
 ;;; wl-message.el -- Message displaying modules for Wanderlust.
 
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
 
 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
 ;; Keywords: mail, net news
-;; Time-stamp: <2000-03-17 10:19:41 teranisi>
 
 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
 
@@ -40,16 +39,10 @@
 	(require 'mime-view)
 	(require 'mmelmo-imap4))
     (require 'tm-wl))
-  (mapcar
-   (function
-    (lambda (symbol)
-      (unless (boundp symbol)
-	(set (make-local-variable symbol) nil))))
-   '(mime-view-ignored-field-list mmelmo-imap4-skipped-parts))
-  (defun-maybe event-window (a))
-  (defun-maybe posn-window (a))
-  (defun-maybe event-start (a))
-  (defun-maybe mime-open-entity (a b)))
+  (defalias-maybe 'event-window 'ignore)
+  (defalias-maybe 'posn-window 'ignore)
+  (defalias-maybe 'event-start 'ignore)
+  (defalias-maybe 'mime-open-entity 'ignore))
 
 (defvar wl-original-buf-name "*Message*")
 (defvar wl-message-buf-name "Message")
@@ -61,12 +54,10 @@
 (defvar wl-original-buffer-cur-number nil)
 (defvar wl-original-buffer-cur-msgdb  nil)
 
-(mapcar 
- (function make-variable-buffer-local)
- (list 'wl-message-buffer-cur-folder
-       'wl-message-buffer-cur-number))
+(defvar mmelmo-imap4-skipped-parts)
 
-(provide 'wl-message)
+(make-variable-buffer-local 'wl-message-buffer-cur-folder)
+(make-variable-buffer-local 'wl-message-buffer-cur-number)
 
 (defvar wl-fixed-window-configuration nil)
 
@@ -96,9 +87,9 @@
       (setq gbw nil))
     (if gbw
 	(select-window gbw)
-;      (if (or (null mes)
-;	      wl-stay-folder-window)
-;	  (delete-other-windows))
+;;;   (if (or (null mes)
+;;;	      wl-stay-folder-window)
+;;;	  (delete-other-windows))
       (when wl-fixed-window-configuration
         (delete-other-windows)
         (and wl-stay-folder-window
@@ -127,7 +118,7 @@
     (if (bobp)
 	()
       (scroll-down))
-    (select-window (get-buffer-window cur-buf))))  
+    (select-window (get-buffer-window cur-buf))))
 
 (defun wl-message-scroll-up (amount)
   (let ((view-message-buffer (get-buffer-create wl-message-buf-name))
@@ -138,16 +129,16 @@
 	(widen)
 	(forward-page 1)
 	(if (pos-visible-in-window-p (point))
-	    (wl-message-narrow-to-page 1))))		;Go to next page.
+	    (wl-message-narrow-to-page 1)))) ; Go to next page.
     (if (eobp)
 	()
       (scroll-up))
     (select-window (get-buffer-window cur-buf))))
   
 (defun wl-message-follow-current-entity (buffer)
-  "Follow to current message"
+  "Follow to current message."
   (wl-draft-reply (wl-message-get-original-buffer)
-		  'to-all wl-message-buffer-cur-summary-buffer)
+		  nil wl-message-buffer-cur-summary-buffer) ; reply to all
   (let ((mail-reply-buffer buffer))
     (wl-draft-yank-from-mail-reply-buffer nil)))
 
@@ -191,13 +182,21 @@
 	  (select-window (get-buffer-window summary-buf))))
     (run-hooks 'wl-message-exit-hook)))
 
+(defvar wl-message-mode-map nil)
+(if wl-message-mode-map
+    ()
+  (setq wl-message-mode-map (make-sparse-keymap))
+  (define-key wl-message-mode-map "q" 'wl-message-exit)
+  (define-key wl-message-mode-map "n" 'wl-message-exit)
+  (define-key wl-message-mode-map "p" 'wl-message-exit))
+
 (defun wl-message-decode (outbuf inbuf flag)
   (cond
    ((eq flag 'all-header)
     (save-excursion
       (set-buffer inbuf)
       (let ((buffer-read-only nil))
-	(decode-mime-charset-region (point-min) 
+	(decode-mime-charset-region (point-min)
 				    (save-excursion
 				      (goto-char (point-min))
 				      (re-search-forward "^$" nil t)
@@ -208,16 +207,14 @@
     (save-excursion
       (set-buffer inbuf)
       (let ((buffer-read-only nil))
-	(save-excursion 
+	(save-excursion
 	  (set-buffer outbuf)
 	  (elmo-set-buffer-multibyte nil))
 	(copy-to-buffer outbuf (point-min) (point-max))
 	(set-buffer outbuf)
-	(local-set-key "q" 'wl-message-exit)
-	(local-set-key "p" 'wl-message-exit)
-	(local-set-key "n" 'wl-message-exit)
+	(use-local-map wl-message-mode-map)
 	(elmo-set-buffer-multibyte default-enable-multibyte-characters)
-	;;(decode-mime-charset-region (point-min) (point-max) wl-mime-charset)
+;;;	(decode-mime-charset-region (point-min) (point-max) wl-mime-charset)
 	;; we can call decode-coding-region() directly, because multibyte flag is t.
 	(decode-coding-region (point-min) (point-max) wl-cs-autoconv)
 	(wl-highlight-message (point-min)
@@ -228,7 +225,7 @@
     (save-excursion
       (set-buffer inbuf)
       (let ((buffer-read-only nil))
-	(decode-mime-charset-region (point-min) 
+	(decode-mime-charset-region (point-min)
 				    (save-excursion
 				      (goto-char (point-min))
 				      (re-search-forward "^$" nil t)
@@ -237,11 +234,11 @@
     (wl-message-decode-mode outbuf inbuf))))
 
 (defun wl-message-prev-page (&optional lines)
-  "Scroll down this message. Returns non-nil if top of message"
+  "Scroll down this message.  Returns non-nil if top of message."
   (interactive)
   (let ((cur-buf (current-buffer))
 	(view-message-buffer (get-buffer-create wl-message-buf-name))
-	ret-val)  
+	ret-val)
     (wl-select-buffer view-message-buffer)
     (move-to-window-line 0)
     (if (and wl-break-pages
@@ -260,9 +257,9 @@
 (static-if (fboundp 'luna-make-entity)
     (defsubst wl-message-make-mime-entity (backend number backend folder msgdb)
       (luna-make-entity (mm-expand-class-name 'elmo)
-			:location (get-buffer-create 
+			:location (get-buffer-create
 				   (concat mmelmo-entity-buffer-name "0"))
-			:imap (eq backend 'elmo-imap4) 
+			:imap (eq backend 'elmo-imap4)
 			:folder folder
 			:number number
 			:msgdb msgdb :size 0))
@@ -270,7 +267,7 @@
     (mime-open-entity backend (list folder number msgdb nil))))
 
 (defun wl-message-next-page (&optional lines)
-  "Scroll up this message. Returns non-nil if bottom of message"
+  "Scroll up this message.  Returns non-nil if bottom of message."
   (interactive)
   (let ((cur-buf (current-buffer))
 	(view-message-buffer (get-buffer-create wl-message-buf-name))
@@ -289,7 +286,11 @@
 	  (wl-message-narrow-to-page 1)
 	  (setq ret-val nil))
       (condition-case ()
-	  (scroll-up lines)
+	  (static-if (boundp 'window-pixel-scroll-increment)
+	      ;; XEmacs 21.2.20 and later.
+	      (let (window-pixel-scroll-increment)
+		(scroll-up lines))
+	    (scroll-up lines))
 	(end-of-buffer
 	 (goto-char (point-max))))
       (setq ret-val nil))
@@ -337,19 +338,19 @@
 	(setq wl-message-buffer-cur-summary-buffer sum-buf)))))
 
 (defun wl-message-normal-get-original-buffer ()
-  (let (ret-val)
-    (if (setq ret-val (get-buffer wl-original-buf-name))
-	ret-val
-      (set-buffer (setq ret-val 
-			(get-buffer-create wl-original-buf-name)))
-      (wl-message-original-mode)
-      ret-val)))
+  (let ((ret-val (get-buffer wl-original-buf-name)))
+    (if (not ret-val)
+	(save-excursion
+	  (set-buffer (setq ret-val
+			    (get-buffer-create wl-original-buf-name)))
+	  (wl-message-original-mode)))
+    ret-val))
 
 
 (if wl-use-semi
-    (defalias 'wl-message-get-original-buffer 
+    (defalias 'wl-message-get-original-buffer
       'mmelmo-get-original-buffer)
-  (defalias 'wl-message-get-original-buffer 
+  (defalias 'wl-message-get-original-buffer
     'wl-message-normal-get-original-buffer))
 
 (defvar wl-message-redisplay-func 'wl-normal-message-redisplay)
@@ -365,19 +366,19 @@
 
 ;; nil means don't fetch all.
 (defun wl-message-decide-backend (folder number message-id size)
-  (let ((dont-do-that (and 
+  (let ((dont-do-that (and
 		       (not (setq wl-message-cache-used
 				  (or
 				   (elmo-buffer-cache-hit
 				    (list folder number message-id))
-				   (elmo-cache-exists-p message-id 
+				   (elmo-cache-exists-p message-id
 							folder number))))
 		       (integerp size)
 		       (not (elmo-local-file-p folder number))
 		       wl-fetch-confirm-threshold
 		       (>= size wl-fetch-confirm-threshold)
-		       (not (y-or-n-p 
-			     (format "Fetch entire message? (%dbytes)" 
+		       (not (y-or-n-p
+			     (format "Fetch entire message? (%dbytes)"
 				     size))))))
     (message "")
     (cond ((and dont-do-that
@@ -404,11 +405,10 @@
 					   &optional force-reload)
   (let* ((cur-buf (current-buffer))
 	 (view-message-buffer (wl-message-get-buffer-create))
-	 (message-id (cdr (assq number 
+	 (message-id (cdr (assq number
 				(elmo-msgdb-get-number-alist msgdb))))
 	 (size (elmo-msgdb-overview-entity-get-size
-		(assoc message-id 
-		       (elmo-msgdb-get-overview msgdb))))
+		(elmo-msgdb-overview-get-entity number msgdb)))
 	 (backend (wl-message-decide-backend folder number message-id size))
 	 cur-entity ret-val header-end real-fld-num summary-win)
     (require 'mmelmo)
@@ -423,17 +423,17 @@
 	  (erase-buffer)
 	  (if backend
 	      (let (mime-display-header-hook ;; bind to nil...
-		    (mime-view-ignored-field-list 
+		    (wl-message-ignored-field-list
 		     (if (eq flag 'all-header)
 			 nil
-		       mime-view-ignored-field-list))
+		       wl-message-ignored-field-list))
 		    (mmelmo-force-reload force-reload)
 		    (mmelmo-imap4-threshold wl-fetch-confirm-threshold))
 		(setq real-fld-num (elmo-get-real-folder-number
 				    folder number))
 		(setq cur-entity
 		      (wl-message-make-mime-entity
-		       backend 
+		       backend
 		       (if (eq backend 'elmo-imap4)
 			   (cdr real-fld-num)
 			 number)
@@ -443,14 +443,14 @@
 			 folder)
 		       msgdb))
 		(setq mmelmo-imap4-skipped-parts nil)
-		;;; mime-display-message sets buffer-read-only variable as t.
-		;;; which makes buffer read-only status confused...
-		(wl-mime-display-message cur-entity view-message-buffer
-					 nil nil 'mmelmo-original-mode)
+		;; mime-display-message sets buffer-read-only variable as t.
+		;; which makes buffer read-only status confused...
+		(mime-display-message cur-entity view-message-buffer
+				      nil nil 'mmelmo-original-mode)
 		(if mmelmo-imap4-skipped-parts
 		    (progn
 		      (message "Skipped fetching of %s."
-			       (mapconcat 
+			       (mapconcat
 				(lambda (x)
 				  (format "[%s]" x))
 				mmelmo-imap4-skipped-parts ","))))
@@ -488,19 +488,17 @@
     ret-val
     ))
 
-(defun wl-normal-message-redisplay (folder number flag msgdb 
+(defun wl-normal-message-redisplay (folder number flag msgdb
 					   &optional force-reload)
   (interactive)
   (let* ((cur-buf (current-buffer))
 	 (original-message-buffer (wl-message-get-original-buffer))
 	 (view-message-buffer (wl-message-get-buffer-create))
-	 (message-id (cdr (assq number 
+	 (message-id (cdr (assq number
 				(elmo-msgdb-get-number-alist msgdb))))
 	 (size (elmo-msgdb-overview-entity-get-size
-		(assoc message-id 
-		       (elmo-msgdb-get-overview msgdb))))
-	 header-end ret-val summary-win
-	 )
+		(elmo-msgdb-overview-get-entity number msgdb)))
+	 header-end ret-val summary-win)
     (wl-select-buffer view-message-buffer)
     (unwind-protect
 	(progn
@@ -513,10 +511,10 @@
 		  (not (and (integerp size)
 			    wl-fetch-confirm-threshold
 			    (>= size wl-fetch-confirm-threshold)
-			    (not (elmo-cache-exists-p message-id 
+			    (not (elmo-cache-exists-p message-id
 						      folder number))
 			    (not (y-or-n-p
-				  (format "Fetch entire message? (%dbytes)" 
+				  (format "Fetch entire message? (%dbytes)"
 					  size))))))
 	      (progn
 		(save-excursion
@@ -525,8 +523,8 @@
 		    (elmo-read-msg-with-buffer-cache
 		     folder number original-message-buffer msgdb force-reload)))
 		;; decode MIME message.
-		(wl-message-decode 
-		 view-message-buffer 
+		(wl-message-decode
+		 view-message-buffer
 		 original-message-buffer flag)
 		(setq ret-val t))
 	    (save-excursion
@@ -541,7 +539,7 @@
 	  (wl-message-narrow-to-page)
 	(error nil)) ; ignore errors.
       (setq mode-line-buffer-identification
-	    (format "Wanderlust: << %s / %s >>" 
+	    (format "Wanderlust: << %s / %s >>"
 		    (if (memq 'modeline wl-use-folder-petname)
 			(wl-folder-get-petname folder)
 		      folder)
@@ -550,7 +548,7 @@
       (unwind-protect
 	  (run-hooks 'wl-message-redisplay-hook)
 	;; go back to summary mode
-	(set-buffer-modified-p nil)      
+	(set-buffer-modified-p nil)
 	(setq buffer-read-only t)
 	(set-buffer cur-buf)
 	(setq summary-win (get-buffer-window cur-buf))
@@ -559,9 +557,40 @@
       ret-val
       )))
 
+(defvar wl-message-button-map (make-sparse-keymap))
+
+(defun wl-message-add-button (from to function &optional data)
+  "Create a button between FROM and TO with callback FUNCTION and DATA."
+  (add-text-properties
+   from to
+   (nconc (list 'wl-message-button-callback function)
+	  (if data
+	      (list 'wl-message-button-data data))))
+  (let ((ov (make-overlay from to)))
+    (overlay-put ov 'mouse-face 'highlight)
+    (overlay-put ov 'local-map wl-message-button-map)
+    (overlay-put ov 'evaporate t)))
+
+(defun wl-message-button-dispatcher (event)
+  "Select the button under point."
+  (interactive "@e")
+  (mouse-set-point event)
+  (let ((callback (get-text-property (point) 'wl-message-button-callback))
+	(data (get-text-property (point) 'wl-message-button-data)))
+    (if callback
+	(funcall callback data)
+      (wl-message-button-dispatcher-internal event))))
+
+(defun wl-message-button-refer-article (data)
+  "Read article specified by Message-ID DATA at point."
+  (switch-to-buffer-other-window
+   wl-message-buffer-cur-summary-buffer)
+  (if (wl-summary-jump-to-msg-by-message-id data)
+      (wl-summary-redisplay)))
+
 (defun wl-message-refer-article-or-url (e)
-  "Read article specified by message-id around point. If failed,
-   attempt to execute button-dispatcher."
+  "Read article specified by message-id around point.
+If failed, attempt to execute button-dispatcher."
   (interactive "e")
   (let ((window (get-buffer-window (current-buffer)))
 	mouse-window point beg end msg-id)
@@ -573,17 +602,17 @@
 	  (setq beg (save-excursion (beginning-of-line) (point)))
 	  (setq end (save-excursion (end-of-line) (point)))
 	  (search-forward ">" end t)      ;Move point to end of "<....>".
-	  (if (and (re-search-backward "\\(<[^<> \t\n]+@[^<> \t\n]+>\\)" 
+	  (if (and (re-search-backward "\\(<[^<> \t\n]+@[^<> \t\n]+>\\)"
 				       beg t)
-		   (not (string-match "mailto:" 
+		   (not (string-match "mailto:"
 				      (setq msg-id (wl-match-buffer 1)))))
 	      (progn
 		(goto-char point)
-		(switch-to-buffer-other-window 
+		(switch-to-buffer-other-window
 		 wl-message-buffer-cur-summary-buffer)
 		(if (wl-summary-jump-to-msg-by-message-id msg-id)
 		    (wl-summary-redisplay)))
-	    (wl-message-button-dispatcher e)))
+	    (wl-message-button-dispatcher-internal e)))
       (if (eq mouse-window (get-buffer-window (current-buffer)))
 	  (select-window window)))))
 
@@ -593,23 +622,28 @@
     (search-forward "\n\n")
     (let ((sp (point))
 	  ep filename case-fold-search)
-      (if first
-	  (progn
-	    (re-search-forward "^begin[ \t]+[0-9]+[ \t]+\\([^ ].*\\)" nil t)
-	    (setq filename (buffer-substring (match-beginning 1)(match-end 1))))
-	(re-search-forward "^M.*$" nil t)) ; uuencoded string
-      (beginning-of-line)
-      (setq sp (point))
-      (goto-char (point-max))
-      (if last
-	  (re-search-backward "^end" sp t)
-        (re-search-backward "^M.*$" sp t)) ; uuencoded string
-      (forward-line 1)
-      (setq ep (point))
-      (set-buffer outbuf)
-      (goto-char (point-max))
-      (insert-buffer-substring buf sp ep)
-      (set-buffer buf)
-      filename)))
+      (catch 'done
+	(if first
+	    (progn
+	      (if (re-search-forward "^begin[ \t]+[0-9]+[ \t]+\\([^ ].*\\)" nil t)
+		  (setq filename (buffer-substring (match-beginning 1)(match-end 1)))
+		(throw 'done nil)))
+	  (re-search-forward "^M.*$" nil t)) ; uuencoded string
+	(beginning-of-line)
+	(setq sp (point))
+	(goto-char (point-max))
+	(if last
+	    (re-search-backward "^end" sp t)
+	  (re-search-backward "^M.*$" sp t)) ; uuencoded string
+	(forward-line 1)
+	(setq ep (point))
+	(set-buffer outbuf)
+	(goto-char (point-max))
+	(insert-buffer-substring buf sp ep)
+	(set-buffer buf)
+	filename))))
+
+(require 'product)
+(product-provide (provide 'wl-message) (require 'wl-version))
 
 ;;; wl-message.el ends here