Wanderlustでgmail風なメール転送をするためのelisp

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; gmail-style forward
    (add-hook 'wl-summary-mode-hook
    	  (lambda ()
    	  (define-key wl-summary-mode-map "F" 'my-wl-summary-forward)))

    (defun my-wl-summary-forward ()
      (interactive)
      (let ((summary-buf (current-buffer))
    	(winconf (current-window-configuration))
    	(tmp-buf (get-buffer-create " *wl-draft-edit-string*"))
    	mes-buf
    	to subject in-reply-to cc references mail-followup-to
    	content-type content-transfer-encoding from date
    	to-alist cc-alist decoder string)
        (when (wl-summary-message-number)
          (save-excursion
    	(wl-summary-set-message-buffer-or-redisplay))
          (condition-case err
    	  (when (setq mes-buf (wl-message-get-original-buffer))
    	    (setq string (wl-summary-message-string 'maybe))
    	    (set-buffer tmp-buf)
    	    (erase-buffer)
    	    (insert string)
    	    (setq to (std11-field-body "To"))
    	    (setq subject (std11-field-body "Subject"))
    	    (setq subject (and subject
    			       (eword-decode-string
    				(decode-mime-charset-string
    				 subject
    				 wl-mime-charset))))
    	    (setq from (std11-field-body "From")
    		  from (and from
    			    (eword-decode-string
    			     (decode-mime-charset-string
    			      from
    			      wl-mime-charset))))
    	    (setq cc (std11-field-body "Cc"))
    	    (setq date (std11-field-body "Date"))
    	    (setq in-reply-to (std11-field-body "Message-ID"))
    	    (setq references (nconc
    			      (std11-field-bodies '("References" "In-Reply-To"))
    			      (list in-reply-to))
    		  references (delq nil references)
    		  references (mapconcat 'identity references " ")
    		  references (wl-draft-parse-msg-id-list-string references)
    		  references (wl-delete-duplicates references)
    		  references (when references
    			       (mapconcat 'identity references "\n\t")))
    	    (setq mail-followup-to (std11-field-body "Mail-Followup-To"))
    	    (setq content-type (std11-field-body "Content-Type"))
    	    (setq content-transfer-encoding (std11-field-body "Content-Transfer-Encoding"))
    	    (goto-char (point-min))
    	    (or (re-search-forward "\n\n" nil t)
    		(search-forward (concat mail-header-separator "\n") nil t))
    	    (unwind-protect
    		(set-buffer
    		 (wl-draft (list
    			    (cons 'From
    				  (if (wl-address-user-mail-address-p from) from))
    			    (cons 'To "")
    			    (cons 'Subject (wl-draft-forward-make-subject subject))
    			    (cons 'Mail-Followup-To mail-followup-to)
    			    (cons 'In-Reply-To in-reply-to)
    			    (cons 'References references))
    			   content-type content-transfer-encoding
    			   (buffer-substring (point) (point-max))
    			   'edit-again))
    	      (kill-buffer tmp-buf))
    	    ;; Set cursor point to the top.
    	    (goto-char (point-min))
    	    (search-forward (concat mail-header-separator "\n") nil t)
    	    ;;
    	    (setq to (wl-parse-addresses to)
    		  cc (wl-parse-addresses cc))
    	    (setq to-alist
    		  (mapcar
    		   (lambda (addr)
    		     (setq decoder (mime-find-field-decoder 'To 'plain))
    		     (cons (nth 1 (std11-extract-address-components addr))
    		   (if decoder (funcall decoder addr) addr)))
    		   to))
    	    (setq cc-alist
    		  (mapcar
    		   (lambda (addr)
    		     (setq decoder (mime-find-field-decoder 'Cc 'plain))
    		     (cons (nth 1 (std11-extract-address-components addr))
    			   (if decoder (funcall decoder addr) addr)))
    		   cc))
    	    
    	    (setq to (delq nil (mapcar 'car to-alist)))
    	    (setq cc (delq nil (mapcar 'car cc-alist)))
    	    (and to (setq to (mapconcat
    			      (lambda (addr)
    				(if wl-draft-reply-use-address-with-full-name
    				    (or (cdr (assoc addr to-alist)) addr)
    				  addr))
    			      to ",\n\t")))
    	    (and cc (setq cc (mapconcat
    			      (lambda (addr)
    				(if wl-draft-reply-use-address-with-full-name
    				    (or (cdr (assoc addr cc-alist)) addr)
    				  addr))
    			      cc ",\n\t")))
    	    (wl-draft-reply-position 'body)
    	    (insert (concat
    		     "\n-------- Forwarded Message --------\n"
    		     (and from (format "From: %s\n" from))
    		     (and date (format "Date: %s\n" date))
    		     (and subject (format "Subject: %s\n" subject))
    		     (and to (format "To: %s\n" to))
    		     (and cc (format "Cc: %s\n" cc))
    		     "\n\n"))
    	    (mail-position-on-field "To")
    	    (run-hooks 'wl-draft-forward-hook)
    	    (run-hooks 'wl-mail-setup-hook))
    	(error (set-window-configuration winconf)
    	       (signal (car err) (cdr err))))
          (with-current-buffer summary-buf (run-hooks 'wl-summary-forward-hook))
          t)))