mh-e/tm-mh-e.el

   1 ;;;
   2 ;;; tm-mh-e.el --- MIME extender for mh-e
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
   9 ;;; modified by YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>
  10 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  11 ;;; Created: 1993/11/21 (obsolete mh-e-mime.el)
  12 ;;; Version: $Revision: 7.63 $
  13 ;;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual
  14 ;;;
  15 ;;; This file is part of tm (Tools for MIME).
  16 ;;;
  17 ;;; This program is free software; you can redistribute it and/or
  18 ;;; modify it under the terms of the GNU General Public License as
  19 ;;; published by the Free Software Foundation; either version 2, or
  20 ;;; (at your option) any later version.
  21 ;;;
  22 ;;; This program is distributed in the hope that it will be useful,
  23 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25 ;;; General Public License for more details.
  26 ;;;
  27 ;;; You should have received a copy of the GNU General Public License
  28 ;;; along with This program.  If not, write to the Free Software
  29 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  30 ;;;
  31 ;;; Code:
  32
  33 (require 'tl-str)
  34 (require 'tl-misc)
  35 (require 'mh-e)
  36 (or (featurep 'mh-utils)
  37     (require 'tm-mh-e3)
  38     )
  39 (require 'tm-view)
  40
  41 (or (fboundp 'mh-get-header-field)
  42     (defalias 'mh-get-header-field 'mh-get-field)
  43     )
  44 (or (boundp 'mh-temp-buffer)
  45     (defconst mh-temp-buffer " *mh-temp*")
  46     )
  47
  48
  49 ;;; @ version
  50 ;;;
  51
  52 (defconst tm-mh-e/RCS-ID
  53   "$Id: tm-mh-e.el,v 7.63 1996/05/30 00:18:04 morioka Exp $")
  54
  55 (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
  56
  57
  58 ;;; @ variable
  59 ;;;
  60
  61 (defvar tm-mh-e/automatic-mime-preview t
  62   "*If non-nil, show MIME processed message.")
  63
  64 (defvar tm-mh-e/decode-encoded-word t
  65   "*If non-nil, decode encoded-word when it is not MIME preview mode.")
  66
  67
  68 ;;; @ functions
  69 ;;;
  70
  71 ;; (if (not (fboundp 'tm-mh-e/original-mh-display-msg))
  72 ;;     (fset 'tm-mh-e/original-mh-display-msg
  73 ;;           (symbol-function 'mh-display-msg))
  74 ;;   )
  75
  76 (defun mh-display-msg (msg-num folder &optional show-buffer mode)
  77   (or mode
  78       (setq mode tm-mh-e/automatic-mime-preview)
  79       )
  80   ;; Display message NUMBER of FOLDER.
  81   ;; Sets the current buffer to the show buffer.
  82   (set-buffer folder)
  83   (or show-buffer
  84       (setq show-buffer mh-show-buffer))
  85   ;; Bind variables in folder buffer in case they are local
  86   (let ((msg-filename (mh-msg-filename msg-num)))
  87     (if (not (file-exists-p msg-filename))
  88         (error "Message %d does not exist" msg-num))
  89     (set-buffer show-buffer)
  90     (cond ((not (equal msg-filename buffer-file-name))
  91            ;; Buffer does not yet contain message.
  92            (clear-visited-file-modtime)
  93            (unlock-buffer)
  94            (setq buffer-file-name nil)  ; no locking during setup
  95            (setq buffer-read-only nil)
  96            (erase-buffer)
  97            (if mode
  98                (let* ((aname (concat "article-" folder))
  99                       (abuf (get-buffer aname))
 100                       )
 101                  (if abuf
 102                      (progn
 103                        (set-buffer abuf)
 104                        (setq buffer-read-only nil)
 105                        (erase-buffer)
 106                        )
 107                    (setq abuf (get-buffer-create aname))
 108                    (set-buffer abuf)
 109                    )
 110                  (let ((file-coding-system-for-read
 111                         (if (boundp 'MULE) *noconv*))
 112                        kanji-fileio-code)
 113                    (insert-file-contents msg-filename)
 114                    ;; (goto-char (point-min))
 115                    (while (re-search-forward "\r$" nil t)
 116                      (replace-match "")
 117                      )
 118                    )
 119                  (set-buffer-modified-p nil)
 120                  (setq buffer-read-only t)
 121                  (setq buffer-file-name msg-filename)
 122                  (mh-show-mode)
 123                  (mime/viewer-mode nil nil nil
 124                                    aname (concat "show-" folder))
 125                  (goto-char (point-min))
 126                  )
 127              (let ((clean-message-header mh-clean-message-header)
 128                    (invisible-headers mh-invisible-headers)
 129                    (visible-headers mh-visible-headers)
 130                    )
 131                ;; 1995/9/21
 132                ;;   modified by ARIURA <ariura@cc.tuat.ac.jp>
 133                ;;   to support mhl.
 134                (if mhl-formfile
 135                    (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
 136                                            (if (stringp mhl-formfile)
 137                                                (list "-form" mhl-formfile))
 138                                            msg-filename)
 139                  (insert-file-contents msg-filename))
 140                ;; end
 141                (goto-char (point-min))
 142                (cond (clean-message-header
 143                       (mh-clean-msg-header (point-min)
 144                                            invisible-headers
 145                                            visible-headers)
 146                       (goto-char (point-min)))
 147                      (t
 148                       (mh-start-of-uncleaned-message)))
 149                (if tm-mh-e/decode-encoded-word
 150                    (mime/decode-message-header)
 151                  )
 152                (set-buffer-modified-p nil)
 153                (setq buffer-read-only t)
 154                (setq buffer-file-name msg-filename)
 155                (mh-show-mode)
 156                ))
 157            (or (eq buffer-undo-list t)  ;don't save undo info for prev msgs
 158                (setq buffer-undo-list nil))
 159 ;;; Added by itokon (02/19/96)
 160            (setq buffer-file-name msg-filename)
 161 ;;;
 162            (set-mark nil)
 163            (setq mode-line-buffer-identification
 164                  (list (format mh-show-buffer-mode-line-buffer-id
 165                                folder msg-num)))
 166            (set-buffer folder)
 167            (setq mh-showing-with-headers nil)))))
 168
 169 (defun tm-mh-e/view-message (&optional msg)
 170   "MIME decode and play this message."
 171   (interactive)
 172   (if (or (null tm-mh-e/automatic-mime-preview)
 173           (null (get-buffer mh-show-buffer))
 174           (save-excursion
 175             (set-buffer mh-show-buffer)
 176             (not (eq major-mode 'mime/viewer-mode))
 177             ))
 178       (let ((tm-mh-e/automatic-mime-preview t))
 179         (mh-invalidate-show-buffer)
 180         (mh-show-msg msg)
 181         ))
 182   (pop-to-buffer mh-show-buffer)
 183   )
 184
 185 (defun tm-mh-e/toggle-decoding-mode (arg)
 186   "Toggle MIME processing mode.
 187 With arg, turn MIME processing on if arg is positive."
 188   (interactive "P")
 189   (setq tm-mh-e/automatic-mime-preview
 190         (if (null arg)
 191             (not tm-mh-e/automatic-mime-preview)
 192           arg))
 193   (save-excursion
 194     (set-buffer mh-show-buffer)
 195     (if (null tm-mh-e/automatic-mime-preview)
 196         (if (and mime::preview/article-buffer
 197                  (get-buffer mime::preview/article-buffer))
 198             (kill-buffer mime::preview/article-buffer)
 199           )))
 200   (mh-invalidate-show-buffer)
 201   (mh-show (mh-get-msg-num t))
 202   )
 203
 204 (defun tm-mh-e/show (&optional message)
 205   (interactive)
 206   (mh-invalidate-show-buffer)
 207   (mh-show message)
 208   )
 209
 210 (defun tm-mh-e/header-display ()
 211   (interactive)
 212   (mh-invalidate-show-buffer)
 213   (let ((mime-viewer/ignored-field-regexp "^:$")
 214         tm-mh-e/decode-encoded-word)
 215     (mh-header-display)
 216     ))
 217
 218 (defun tm-mh-e/raw-display ()
 219   (interactive)
 220   (mh-invalidate-show-buffer)
 221   (let (tm-mh-e/automatic-mime-preview
 222         tm-mh-e/decode-encoded-word)
 223     (mh-header-display)
 224     ))
 225
 226 (defun tm-mh-e/scroll-up-msg (&optional arg)
 227   (interactive)
 228   (mh-page-msg (or arg 1))
 229   )
 230
 231 (defun tm-mh-e/scroll-down-msg (&optional arg)
 232   (interactive)
 233   (mh-page-msg (- (or arg 1)))
 234   )
 235
 236 (defun tm-mh-e/burst-multipart/digest ()
 237   "Burst apart the current message, which should be a multipart/digest.
 238 The message is replaced by its table of contents and the letters from the
 239 digest are inserted into the folder after that message."
 240   (interactive)
 241   (let ((digest (mh-get-msg-num t)))
 242     (mh-process-or-undo-commands mh-current-folder)
 243     (mh-set-folder-modified-p t)                ; lock folder while bursting
 244     (message "Bursting digest...")
 245     (mh-exec-cmd "mhn" "-store" mh-current-folder digest)
 246     (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
 247     (message "Bursting digest...done")
 248     ))
 249
 250
 251 ;;; @ for tm-view
 252 ;;;
 253
 254 (fset 'tm-mh-e/charset-decode-region
 255       (symbol-function 'mime-charset-decode-region))
 256
 257 (set-alist 'mime-viewer/code-converter-alist
 258            'mh-show-mode
 259            (function tm-mh-e/charset-decode-region))
 260
 261 (defun tm-mh-e/content-header-filter ()
 262   (goto-char (point-min))
 263   (mime-preview/cut-header)
 264   (tm-mh-e/charset-decode-region (point-min)(point-max)
 265                                  mime/default-coding-system)
 266   (mime/decode-message-header)
 267   )
 268
 269 (set-alist 'mime-viewer/content-header-filter-alist
 270            'mh-show-mode
 271            (function tm-mh-e/content-header-filter))
 272
 273 (defun tm-mh-e/quitting-method ()
 274   (let ((win (get-buffer-window
 275               mime/output-buffer-name))
 276         (buf (current-buffer))
 277         )
 278     (if win
 279         (delete-window win)
 280       )
 281     (pop-to-buffer
 282      (let ((name (buffer-name buf)))
 283        (substring name 5)
 284        ))
 285     (if (not tm-mh-e/automatic-mime-preview)
 286         (mh-invalidate-show-buffer)
 287       )
 288     (mh-show (mh-get-msg-num t))
 289     ))
 290
 291 (set-alist 'mime-viewer/quitting-method-alist
 292            'mh-show-mode
 293            (function tm-mh-e/quitting-method))
 294 (set-alist 'mime-viewer/show-summary-method
 295            'mh-show-mode
 296            (function tm-mh-e/quitting-method))
 297
 298 (defun tm-mh-e/following-method (buf)
 299   (save-excursion
 300     (set-buffer buf)
 301     (goto-char (point-max))
 302     (setq mh-show-buffer buf)
 303     (apply (function mh-send)
 304            (rfc822/get-field-bodies '("To" "cc" "Subject") ""))
 305     (setq mh-sent-from-folder buf)
 306     (setq mh-sent-from-msg 1)
 307     (let ((last (point)))
 308       (mh-yank-cur-msg)
 309       (goto-char last)
 310       )))
 311
 312 (set-alist 'mime-viewer/following-method-alist
 313            'mh-show-mode
 314            (function tm-mh-e/following-method))
 315
 316
 317 ;;; @@ for tm-partial
 318 ;;;
 319
 320 (call-after-loaded
 321  'tm-partial
 322  (function
 323   (lambda ()
 324     (set-atype 'mime/content-decoding-condition
 325                '((type . "message/partial")
 326                  (method . mime-article/grab-message/partials)
 327                  (major-mode . mh-show-mode)
 328                  (summary-buffer-exp
 329                   . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
 330                              (string-match "^show-\\(.+\\)$" article-buffer))
 331                          (substring article-buffer
 332                                     (match-beginning 1) (match-end 1))
 333                          ))
 334                  ))
 335     (set-alist 'tm-partial/preview-article-method-alist
 336                'mh-show-mode
 337                (function
 338                 (lambda ()
 339                   (let ((tm-mh-e/automatic-mime-preview t))
 340                     (tm-mh-e/show)
 341                     ))))
 342     )))
 343
 344
 345 ;;; @ set up
 346 ;;;
 347
 348 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
 349 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
 350 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
 351 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
 352 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
 353 (define-key mh-folder-mode-map "\r" (function tm-mh-e/scroll-up-msg))
 354 (define-key mh-folder-mode-map "\e\r" (function tm-mh-e/scroll-down-msg))
 355 (define-key mh-folder-mode-map "\C-c\C-b"
 356   (function tm-mh-e/burst-multipart/digest))
 357
 358 (defun tm-mh-e/summary-before-quit ()
 359   (let ((buf (get-buffer mh-show-buffer)))
 360     (if buf
 361         (let ((the-buf (current-buffer)))
 362           (switch-to-buffer buf)
 363           (if (and mime::article/preview-buffer
 364                    (setq buf (get-buffer mime::article/preview-buffer))
 365                    )
 366               (progn
 367                 (switch-to-buffer the-buf)
 368                 (kill-buffer buf)
 369                 )
 370             (switch-to-buffer the-buf)
 371             )
 372           ))))
 373
 374 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
 375
 376
 377 ;;; @@ for tmh-comp.el
 378 ;;;
 379
 380 (autoload 'tm-mh-e/edit-again "tmh-comp"
 381   "Clean-up a draft or a message previously sent and make it resendable." t)
 382 (autoload 'tm-mh-e/extract-rejected-mail "tmh-comp"
 383   "Extract a letter returned by the mail system and make it re-editable." t)
 384 (autoload 'tm-mh-e/forward "tmh-comp"
 385   "Forward a message or message sequence by MIME style." t)
 386
 387 (call-after-loaded
 388  'mime-setup
 389  (function
 390   (lambda ()
 391     (substitute-key-definition
 392      'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map)
 393     (substitute-key-definition
 394      'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail
 395      mh-folder-mode-map)
 396     (substitute-key-definition
 397      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
 398
 399     (call-after-loaded
 400      'mh-comp
 401      (function
 402       (lambda ()
 403         (require 'tmh-comp)
 404         ))
 405      'mh-letter-mode-hook)
 406     )))
 407
 408
 409 ;;; @ for BBDB
 410 ;;;
 411
 412 (call-after-loaded
 413  'bbdb
 414  (function
 415   (lambda ()
 416     (require 'tm-bbdb)
 417     )))
 418
 419
 420 ;;; @ end
 421 ;;;
 422
 423 (provide 'tm-mh-e)
 424
 425 (run-hooks 'tm-mh-e-load-hook)
 426
 427 ;;; tm-mh-e.el ends here