tm-rmail.el

   1 ;;;
   2 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   3 ;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
   4 ;;;
   5 ;;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;;; Version:
   7 ;;;     $Id: tm-rmail.el,v 7.8 1995/10/30 05:52:36 morioka Exp $
   8 ;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
   9 ;;;
  10 ;;; This file is part of tm (Tools for MIME).
  11 ;;;
  12
  13 (require 'tl-list)
  14 (require 'tl-misc)
  15 (require 'rmail)
  16
  17 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  18 (autoload 'mime/Content-Type "tm-view" "parse Content-Type field.")
  19 (autoload 'mime/decode-message-header "tm-ew-d" "Decode MIME encoded-word." t)
  20
  21
  22 ;;; @ variables
  23 ;;;
  24
  25 (defvar tm-rmail/decode-all nil)
  26
  27
  28 ;;; @ message filter
  29 ;;;
  30
  31 (setq rmail-message-filter
  32       (function
  33        (lambda ()
  34          (let ((mf (buffer-modified-p))
  35                (buffer-read-only nil))
  36            (mime/decode-message-header)
  37            (set-buffer-modified-p mf)
  38            ))))
  39
  40
  41 ;;; @ MIME preview
  42 ;;;
  43
  44 (defun tm-rmail/show-all-header-p ()
  45   (save-restriction
  46     (narrow-to-region (point-min)
  47                       (and (re-search-forward "^$" nil t)
  48                            (match-beginning 0)))
  49     (goto-char (point-min))
  50     (re-search-forward rmail-ignored-headers nil t)
  51     ))
  52
  53 (defun tm-rmail/preview-message ()
  54   (interactive)
  55   (setq tm-rmail/decode-all t)
  56   (let ((ret (rmail-widen-to-current-msgbeg
  57               (function
  58                (lambda ()
  59                  (cons (mime/Content-Type)
  60                        (mail-fetch-field "Content-Transfer-Encoding"))
  61                  )))))
  62     (mime/viewer-mode nil (car ret)(cdr ret) nil
  63                       (format "*Preview-%s [%d/%d]*"
  64                               (buffer-name)
  65                               rmail-current-message rmail-total-messages))
  66     ))
  67
  68 (defun tm-rmail/preview-message-if-you-need ()
  69   (if tm-rmail/decode-all
  70       (tm-rmail/preview-message)
  71     ))
  72
  73 (add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need)
  74
  75 (define-key rmail-mode-map "v" (function tm-rmail/preview-message))
  76
  77 (defun tm-rmail/setup ()
  78   (local-set-key "v" (function
  79                       (lambda ()
  80                         (interactive)
  81                         (pop-to-buffer rmail-buffer)
  82                         (tm-rmail/preview-message)
  83                         )))
  84   )
  85
  86 (add-hook 'rmail-summary-mode-hook 'tm-rmail/setup)
  87
  88
  89 ;;; @ over-to-* and quitting methods
  90 ;;;
  91
  92 (defun tm-rmail/quitting-method-to-summary ()
  93   (mime-viewer/kill-buffer)
  94   (rmail-summary)
  95   (delete-other-windows)
  96   )
  97
  98 (defun tm-rmail/quitting-method-to-article ()
  99   (setq tm-rmail/decode-all nil)
 100   (mime-viewer/kill-buffer)
 101   )
 102
 103 (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article)
 104
 105
 106 (defun tm-rmail/over-to-previous-method ()
 107   (let (tm-rmail/decode-all)
 108     (mime-viewer/quit)
 109     )
 110   (if (not (eq (rmail-next-undeleted-message -1) t))
 111       (tm-rmail/preview-message)
 112     )
 113   )
 114
 115 (defun tm-rmail/over-to-next-method ()
 116   (let (tm-rmail/decode-all)
 117     (mime-viewer/quit)
 118     )
 119   (if (not (eq (rmail-next-undeleted-message 1) t))
 120       (tm-rmail/preview-message)
 121     )
 122   )
 123
 124 (call-after-loaded
 125  'tm-view
 126  (function
 127   (lambda ()
 128     (set-alist 'mime-viewer/quitting-method-alist
 129                'rmail-mode
 130                (function tm-rmail/quitting-method))
 131
 132     (set-alist 'mime-viewer/over-to-previous-method-alist
 133                'rmail-mode
 134                (function tm-rmail/over-to-previous-method))
 135
 136     (set-alist 'mime-viewer/over-to-next-method-alist
 137                'rmail-mode
 138                (function tm-rmail/over-to-next-method))
 139     )))
 140
 141
 142 ;;; @ for tm-partial
 143 ;;;
 144
 145 (call-after-loaded
 146  'tm-partial
 147  (function
 148   (lambda ()
 149     (set-atype 'mime/content-decoding-condition
 150                '((type . "message/partial")
 151                  (method . mime-article/grab-message/partials)
 152                  (major-mode . rmail-mode)
 153                  (summary-buffer-exp
 154                   . (progn
 155                       (rmail-summary)
 156                       (pop-to-buffer rmail-buffer)
 157                       rmail-summary-buffer))
 158                  ))
 159     (set-alist 'tm-partial/preview-article-method-alist
 160                'rmail-mode
 161                (function
 162                 (lambda ()
 163                   (rmail-summary-goto-msg (count-lines 1 (point)))
 164                   (pop-to-buffer rmail-buffer)
 165                   (tm-rmail/view-message)
 166                   )))
 167     )))
 168
 169
 170 ;;; @ for tm-edit
 171 ;;;
 172
 173 (call-after-loaded
 174  'tm-edit
 175  (function
 176   (lambda ()
 177
 178 (defun tm-rmail/forward ()
 179   "\
 180 Forward current message in message/rfc822 content-type message
 181 from rmail. The message will be appended if being composed."
 182   (interactive)
 183   ;;>> this gets set even if we abort. Can't do anything about it, though.
 184   (rmail-set-attribute "forwarded" t)
 185   (let ((initialized nil)
 186         (beginning nil)
 187         (forwarding-buffer (current-buffer))
 188         (subject (concat "["
 189                          (mail-strip-quoted-names
 190                           (mail-fetch-field "From"))
 191                          ": " (or (mail-fetch-field "Subject") "") "]")))
 192     ;; If only one window, use it for the mail buffer.
 193     ;; Otherwise, use another window for the mail buffer
 194     ;; so that the Rmail buffer remains visible
 195     ;; and sending the mail will get back to it.
 196     (setq initialized
 197           (if (one-window-p t)
 198               (mail nil nil subject)
 199             (mail-other-window nil nil subject)))
 200     (save-excursion
 201       (goto-char (point-max))
 202       (forward-line 1)
 203       (setq beginning (point))
 204       (tm-edit/insert-tag "message" "rfc822")
 205       (insert-buffer forwarding-buffer))
 206     (if (not initialized)
 207         (goto-char beginning))
 208     ))
 209
 210 (substitute-key-definition 'rmail-forward
 211                            'tm-rmail/forward
 212                            rmail-mode-map)
 213
 214 (defun tm-rmail/forward-from-gnus ()
 215   "\
 216 Forward current article in message/rfc822 content-type message from
 217 GNUS. The message will be appended if being composed."
 218   (let ((initialized nil)
 219         (beginning nil)
 220         (forwarding-buffer (current-buffer))
 221         (subject
 222          (concat "[" gnus-newsgroup-name "] "
 223                  ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
 224                  (or (gnus-fetch-field "Subject") ""))))
 225     ;; If only one window, use it for the mail buffer.
 226     ;; Otherwise, use another window for the mail buffer
 227     ;; so that the Rmail buffer remains visible
 228     ;; and sending the mail will get back to it.
 229     (setq initialized
 230           (if (one-window-p t)
 231               (mail nil nil subject)
 232             (mail-other-window nil nil subject)))
 233     (save-excursion
 234       (goto-char (point-max))
 235       (setq beginning (point))
 236       (mime-editor/insert-tag "message" "rfc822")
 237       (insert-buffer forwarding-buffer)
 238       ;; You have a chance to arrange the message.
 239       (run-hooks 'gnus-mail-forward-hook)
 240       )
 241     (if (not initialized)
 242         (goto-char beginning))
 243     ))
 244
 245 ;; (setq gnus-mail-forward-method 'mime-forward-from-gnus-using-mail)
 246
 247 )))
 248
 249
 250 ;;; @ end
 251 ;;;
 252
 253 (provide 'tm-rmail)
 254
 255 (run-hooks 'tm-rmail-load-hook)