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.15 1995/11/12 15:15:15 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                        (mime/Content-Transfer-Encoding "7bit")
  61                        )
  62                  )))))
  63     (narrow-to-region (point-min)
  64                       (save-excursion
  65                         (goto-char (point-max))
  66                         (if (and (re-search-backward "^\n")
  67                                  (eq (match-end 0)(point-max)))
  68                             (match-beginning 0)
  69                           (point-max)
  70                           )))
  71     (mime/viewer-mode nil (car ret)(cdr ret) nil
  72                       (format "*Preview-%s [%d/%d]*"
  73                               (buffer-name)
  74                               rmail-current-message rmail-total-messages))
  75     ))
  76
  77 (defun tm-rmail/preview-message-if-you-need ()
  78   (if tm-rmail/decode-all
  79       (tm-rmail/preview-message)
  80     ))
  81
  82 (add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need)
  83
  84 (define-key rmail-mode-map "v" (function tm-rmail/preview-message))
  85
  86 (defun tm-rmail/setup ()
  87   (local-set-key "v" (function
  88                       (lambda ()
  89                         (interactive)
  90                         (pop-to-buffer rmail-buffer)
  91                         (tm-rmail/preview-message)
  92                         )))
  93   )
  94
  95 (add-hook 'rmail-summary-mode-hook 'tm-rmail/setup)
  96
  97
  98 ;;; @ over-to-* and quitting methods
  99 ;;;
 100
 101 (defun tm-rmail/quitting-method-to-summary ()
 102   (mime-viewer/kill-buffer)
 103   (rmail-summary)
 104   (delete-other-windows)
 105   )
 106
 107 (defun tm-rmail/quitting-method-to-article ()
 108   (setq tm-rmail/decode-all nil)
 109   (mime-viewer/kill-buffer)
 110   )
 111
 112 (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article)
 113
 114
 115 (defun tm-rmail/over-to-previous-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 (defun tm-rmail/over-to-next-method ()
 125   (let (tm-rmail/decode-all)
 126     (mime-viewer/quit)
 127     )
 128   (if (not (eq (rmail-next-undeleted-message 1) t))
 129       (tm-rmail/preview-message)
 130     )
 131   )
 132
 133 (call-after-loaded
 134  'tm-view
 135  (function
 136   (lambda ()
 137     (set-alist 'mime-viewer/quitting-method-alist
 138                'rmail-mode
 139                (function tm-rmail/quitting-method))
 140
 141     (set-alist 'mime-viewer/over-to-previous-method-alist
 142                'rmail-mode
 143                (function tm-rmail/over-to-previous-method))
 144
 145     (set-alist 'mime-viewer/over-to-next-method-alist
 146                'rmail-mode
 147                (function tm-rmail/over-to-next-method))
 148     )))
 149
 150
 151 ;;; @ for tm-partial
 152 ;;;
 153
 154 (call-after-loaded
 155  'tm-partial
 156  (function
 157   (lambda ()
 158     (set-atype 'mime/content-decoding-condition
 159                '((type . "message/partial")
 160                  (method . mime-article/grab-message/partials)
 161                  (major-mode . rmail-mode)
 162                  (summary-buffer-exp
 163                   . (progn
 164                       (rmail-summary)
 165                       (pop-to-buffer rmail-buffer)
 166                       rmail-summary-buffer))
 167                  ))
 168     (set-alist 'tm-partial/preview-article-method-alist
 169                'rmail-mode
 170                (function
 171                 (lambda ()
 172                   (rmail-summary-goto-msg (count-lines 1 (point)))
 173                   (pop-to-buffer rmail-buffer)
 174                   (tm-rmail/preview-message)
 175                   )))
 176     )))
 177
 178
 179 ;;; @ for tm-edit
 180 ;;;
 181
 182 (call-after-loaded
 183  'tm-edit
 184  (function
 185   (lambda ()
 186
 187 (defun tm-rmail/forward ()
 188   "\
 189 Forward current message in message/rfc822 content-type message
 190 from rmail. The message will be appended if being composed."
 191   (interactive)
 192   ;;>> this gets set even if we abort. Can't do anything about it, though.
 193   (rmail-set-attribute "forwarded" t)
 194   (let ((initialized nil)
 195         (beginning nil)
 196         (forwarding-buffer (current-buffer))
 197         (subject (concat "["
 198                          (mail-strip-quoted-names
 199                           (mail-fetch-field "From"))
 200                          ": " (or (mail-fetch-field "Subject") "") "]")))
 201     ;; If only one window, use it for the mail buffer.
 202     ;; Otherwise, use another window for the mail buffer
 203     ;; so that the Rmail buffer remains visible
 204     ;; and sending the mail will get back to it.
 205     (setq initialized
 206           (if (one-window-p t)
 207               (mail nil nil subject)
 208             (mail-other-window nil nil subject)))
 209     (save-excursion
 210       (goto-char (point-max))
 211       (forward-line 1)
 212       (setq beginning (point))
 213       (mime-editor/insert-tag "message" "rfc822")
 214       (insert-buffer forwarding-buffer))
 215     (if (not initialized)
 216         (goto-char beginning))
 217     ))
 218
 219 (substitute-key-definition 'rmail-forward
 220                            'tm-rmail/forward
 221                            rmail-mode-map)
 222
 223 (defun gnus-mail-forward-using-mail-mime ()
 224   "\
 225 Forward current article in message/rfc822 content-type message from
 226 GNUS. The message will be appended if being composed."
 227   (let ((initialized nil)
 228         (beginning nil)
 229         (forwarding-buffer (current-buffer))
 230         (subject
 231          (concat "[" gnus-newsgroup-name "] "
 232                  ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
 233                  (or (gnus-fetch-field "Subject") ""))))
 234     ;; If only one window, use it for the mail buffer.
 235     ;; Otherwise, use another window for the mail buffer
 236     ;; so that the Rmail buffer remains visible
 237     ;; and sending the mail will get back to it.
 238     (setq initialized
 239           (if (one-window-p t)
 240               (mail nil nil subject)
 241             (mail-other-window nil nil subject)))
 242     (save-excursion
 243       (goto-char (point-max))
 244       (setq beginning (point))
 245       (mime-editor/insert-tag "message" "rfc822")
 246       (insert-buffer forwarding-buffer)
 247       ;; You have a chance to arrange the message.
 248       (run-hooks 'gnus-mail-forward-hook)
 249       )
 250     (if (not initialized)
 251         (goto-char beginning))
 252     ))
 253
 254 ;; (setq gnus-mail-forward-method 'mime-forward-from-gnus-using-mail)
 255
 256 )))
 257
 258
 259 ;;; @ end
 260 ;;;
 261
 262 (provide 'tm-rmail)
 263
 264 (run-hooks 'tm-rmail-load-hook)