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 ;;; modified by KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>
   7 ;;; Created: 1994/8/30
   8 ;;; Version:
   9 ;;;     $Revision: 7.19 $
  10 ;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14 ;;; This program is free software; you can redistribute it and/or
  15 ;;; modify it under the terms of the GNU General Public License as
  16 ;;; published by the Free Software Foundation; either version 2, or
  17 ;;; (at your option) any later version.
  18 ;;;
  19 ;;; This program is distributed in the hope that it will be useful,
  20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;;; General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with This program.  If not, write to the Free Software
  26 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27 ;;;
  28 ;;; Code:
  29
  30 (require 'tl-list)
  31 (require 'tl-misc)
  32 (require 'rmail)
  33
  34 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  35 (autoload 'mime/Content-Type "tm-view" "parse Content-Type field.")
  36 (autoload 'mime/decode-message-header "tm-ew-d" "Decode MIME encoded-word." t)
  37
  38
  39 ;;; @ variables
  40 ;;;
  41
  42 (defconst tm-rmail/RCS-ID
  43   "$Id: tm-rmail.el,v 7.19 1995/12/07 04:55:49 morioka Exp $")
  44 (defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID))
  45
  46 (defvar tm-rmail/decode-all nil)
  47
  48
  49 ;;; @ message filter
  50 ;;;
  51
  52 (setq rmail-message-filter
  53       (function
  54        (lambda ()
  55          (let ((mf (buffer-modified-p))
  56                (buffer-read-only nil))
  57            (mime/decode-message-header)
  58            (set-buffer-modified-p mf)
  59            ))))
  60
  61
  62 ;;; @ MIME preview
  63 ;;;
  64
  65 (defun tm-rmail/show-all-header-p ()
  66   (save-restriction
  67     (narrow-to-region (point-min)
  68                       (and (re-search-forward "^$" nil t)
  69                            (match-beginning 0)))
  70     (goto-char (point-min))
  71     (re-search-forward rmail-ignored-headers nil t)
  72     ))
  73
  74 (defun tm-rmail/preview-message ()
  75   (interactive)
  76   (setq tm-rmail/decode-all t)
  77   (let ((ret (rmail-widen-to-current-msgbeg
  78               (function
  79                (lambda ()
  80                  (cons (mime/Content-Type)
  81                        (mime/Content-Transfer-Encoding "7bit")
  82                        )
  83                  )))))
  84     (narrow-to-region (point-min)
  85                       (save-excursion
  86                         (goto-char (point-max))
  87                         (if (and (re-search-backward "^\n")
  88                                  (eq (match-end 0)(point-max)))
  89                             (match-beginning 0)
  90                           (point-max)
  91                           )))
  92     (mime/viewer-mode nil (car ret)(cdr ret) nil
  93                       (format "*Preview-%s [%d/%d]*"
  94                               (buffer-name)
  95                               rmail-current-message rmail-total-messages))
  96     ))
  97
  98 (defun tm-rmail/preview-message-if-you-need ()
  99   (if tm-rmail/decode-all
 100       (tm-rmail/preview-message)
 101     ))
 102
 103 (add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need)
 104
 105 (define-key rmail-mode-map "v" (function tm-rmail/preview-message))
 106
 107 (defun tm-rmail/setup ()
 108   (local-set-key "v" (function
 109                       (lambda ()
 110                         (interactive)
 111                         (pop-to-buffer rmail-buffer)
 112                         (tm-rmail/preview-message)
 113                         )))
 114   )
 115
 116 (add-hook 'rmail-summary-mode-hook 'tm-rmail/setup)
 117
 118
 119 ;;; @ over-to-* and quitting methods
 120 ;;;
 121
 122 (defun tm-rmail/quitting-method-to-summary ()
 123   (mime-viewer/kill-buffer)
 124   (rmail-summary)
 125   (delete-other-windows)
 126   )
 127
 128 (defun tm-rmail/quitting-method-to-article ()
 129   (setq tm-rmail/decode-all nil)
 130   (mime-viewer/kill-buffer)
 131   )
 132
 133 (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article)
 134
 135
 136 (defun tm-rmail/over-to-previous-method ()
 137   (let (tm-rmail/decode-all)
 138     (mime-viewer/quit)
 139     )
 140   (if (not (eq (rmail-next-undeleted-message -1) t))
 141       (tm-rmail/preview-message)
 142     )
 143   )
 144
 145 (defun tm-rmail/over-to-next-method ()
 146   (let (tm-rmail/decode-all)
 147     (mime-viewer/quit)
 148     )
 149   (if (not (eq (rmail-next-undeleted-message 1) t))
 150       (tm-rmail/preview-message)
 151     )
 152   )
 153
 154 (call-after-loaded
 155  'tm-view
 156  (function
 157   (lambda ()
 158     (set-alist 'mime-viewer/quitting-method-alist
 159                'rmail-mode
 160                (function tm-rmail/quitting-method))
 161
 162     (set-alist 'mime-viewer/over-to-previous-method-alist
 163                'rmail-mode
 164                (function tm-rmail/over-to-previous-method))
 165
 166     (set-alist 'mime-viewer/over-to-next-method-alist
 167                'rmail-mode
 168                (function tm-rmail/over-to-next-method))
 169     )))
 170
 171
 172 ;;; @ for tm-partial
 173 ;;;
 174
 175 (call-after-loaded
 176  'tm-partial
 177  (function
 178   (lambda ()
 179     (set-atype 'mime/content-decoding-condition
 180                '((type . "message/partial")
 181                  (method . mime-article/grab-message/partials)
 182                  (major-mode . rmail-mode)
 183                  (summary-buffer-exp
 184                   . (progn
 185                       (rmail-summary)
 186                       (pop-to-buffer rmail-buffer)
 187                       rmail-summary-buffer))
 188                  ))
 189     (set-alist 'tm-partial/preview-article-method-alist
 190                'rmail-mode
 191                (function
 192                 (lambda ()
 193                   (rmail-summary-goto-msg (count-lines 1 (point)))
 194                   (pop-to-buffer rmail-buffer)
 195                   (tm-rmail/preview-message)
 196                   )))
 197     )))
 198
 199
 200 ;;; @ for tm-edit
 201 ;;;
 202
 203 (defun tm-rmail/forward ()
 204   "Forward current message in message/rfc822 content-type message
 205 from rmail. The message will be appended if being composed."
 206   (interactive)
 207   ;;>> this gets set even if we abort. Can't do anything about it, though.
 208   (rmail-set-attribute "forwarded" t)
 209   (let ((initialized nil)
 210         (beginning nil)
 211         (msgnum rmail-current-message)
 212         (rmail-buffer (current-buffer))
 213         (subject (concat "["
 214                          (mail-strip-quoted-names
 215                           (mail-fetch-field "From"))
 216                          ": " (or (mail-fetch-field "Subject") "") "]")))
 217     ;; If only one window, use it for the mail buffer.
 218     ;; Otherwise, use another window for the mail buffer
 219     ;; so that the Rmail buffer remains visible
 220     ;; and sending the mail will get back to it.
 221     (setq initialized
 222           (if (one-window-p t)
 223               (mail nil nil subject)
 224             (mail-other-window nil nil subject)))
 225     (save-excursion
 226       ;; following two variables are used in 19.29 or later.
 227       (make-local-variable 'rmail-send-actions-rmail-buffer)
 228       (make-local-variable 'rmail-send-actions-rmail-msg-number)
 229       (make-local-variable 'mail-reply-buffer)
 230       (setq rmail-send-actions-rmail-buffer rmail-buffer)
 231       (setq rmail-send-actions-rmail-msg-number msgnum)
 232       (setq mail-reply-buffer rmail-buffer)
 233       (goto-char (point-max))
 234       (forward-line 1)
 235       (setq beginning (point))
 236       (mime-editor/insert-tag "message" "rfc822")
 237 ;;       (insert-buffer rmail-buffer))
 238 ;;       (mime-editor/inserted-message-filter))
 239       (tm-mail/insert-message))
 240     (if (not initialized)
 241         (goto-char beginning))
 242     ))
 243
 244 (defun gnus-mail-forward-using-mail-mime ()
 245   "Forward current article in message/rfc822 content-type message from
 246 GNUS. The message will be appended if being composed."
 247   (let ((initialized nil)
 248         (beginning nil)
 249         (forwarding-buffer (current-buffer))
 250         (subject
 251          (concat "[" gnus-newsgroup-name "] "
 252                  ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
 253                  (or (gnus-fetch-field "Subject") ""))))
 254     ;; If only one window, use it for the mail buffer.
 255     ;; Otherwise, use another window for the mail buffer
 256     ;; so that the Rmail buffer remains visible
 257     ;; and sending the mail will get back to it.
 258     (setq initialized
 259           (if (one-window-p t)
 260               (mail nil nil subject)
 261             (mail-other-window nil nil subject)))
 262     (save-excursion
 263       (goto-char (point-max))
 264       (setq beginning (point))
 265       (mime-editor/insert-tag "message" "rfc822")
 266       (insert-buffer forwarding-buffer)
 267       ;; You have a chance to arrange the message.
 268       (run-hooks 'gnus-mail-forward-hook)
 269       )
 270     (if (not initialized)
 271         (goto-char beginning))
 272     ))
 273
 274 (call-after-loaded
 275  'mime-setup
 276  (function
 277   (lambda ()
 278     (substitute-key-definition
 279      'rmail-forward 'tm-rmail/forward rmail-mode-map)
 280
 281     ;; (setq gnus-mail-forward-method 'gnus-mail-forward-using-mail-mime)
 282
 283     (call-after-loaded
 284      'tm-edit
 285      (function
 286       (lambda ()
 287         (autoload 'tm-mail/insert-message "tm-mail")
 288         (set-alist 'mime-editor/message-inserter-alist
 289                    'mail-mode (function tm-mail/insert-message))
 290         )))
 291     )))
 292
 293
 294 ;;; @ end
 295 ;;;
 296
 297 (provide 'tm-rmail)
 298
 299 (run-hooks 'tm-rmail-load-hook)