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.59 $
  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 (if (not (boundp 'mh-e-version))
  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.59 1996/04/25 22:19:02 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/code-convert-region-to-emacs
 255       (symbol-function 'mime/code-convert-region-to-emacs))
 256
 257 (set-alist 'mime-viewer/code-converter-alist
 258            'mh-show-mode
 259            (function tm-mh-e/code-convert-region-to-emacs))
 260
 261 (defun tm-mh-e/content-header-filter ()
 262   (goto-char (point-min))
 263   (mime-preview/cut-header)
 264   (tm-mh-e/code-convert-region-to-emacs (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
 295 ;; (defun tm-mh-e/set-window-configuration ()
 296 ;;   (save-excursion
 297 ;;     (set-buffer mh-show-buffer)
 298 ;;     (setq mime::preview/original-window-configuration
 299 ;;           (current-window-configuration))
 300 ;;     ))
 301
 302 ;; (add-hook 'mh-show-hook 'tm-mh-e/set-window-configuration)
 303
 304 (defun tm-mh-e/following-method (buf)
 305   (save-excursion
 306     (set-buffer buf)
 307     (goto-char (point-max))
 308     (setq mh-show-buffer buf)
 309     (apply (function mh-send)
 310            (rfc822/get-field-bodies '("To" "cc" "Subject") ""))
 311     (setq mh-sent-from-folder buf)
 312     (setq mh-sent-from-msg 1)
 313     (let ((last (point)))
 314       (mh-yank-cur-msg)
 315       (goto-char last)
 316       )))
 317
 318 (set-alist 'mime-viewer/following-method-alist
 319            'mh-show-mode
 320            (function tm-mh-e/following-method))
 321
 322
 323 ;;; @@ for tm-partial
 324 ;;;
 325
 326 (call-after-loaded
 327  'tm-partial
 328  (function
 329   (lambda ()
 330     (set-atype 'mime/content-decoding-condition
 331                '((type . "message/partial")
 332                  (method . mime-article/grab-message/partials)
 333                  (major-mode . mh-show-mode)
 334                  (summary-buffer-exp
 335                   . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
 336                              (string-match "^show-\\(.+\\)$" article-buffer))
 337                          (substring article-buffer
 338                                     (match-beginning 1) (match-end 1))
 339                          ))
 340                  ))
 341     (set-alist 'tm-partial/preview-article-method-alist
 342                'mh-show-mode
 343                (function
 344                 (lambda ()
 345                   (let ((tm-mh-e/automatic-mime-preview t))
 346                     (tm-mh-e/show)
 347                     ))))
 348     )))
 349
 350
 351 ;;; @ set up
 352 ;;;
 353
 354 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
 355 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
 356 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
 357 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
 358 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
 359 (define-key mh-folder-mode-map "\r" (function tm-mh-e/scroll-up-msg))
 360 (define-key mh-folder-mode-map "\e\r" (function tm-mh-e/scroll-down-msg))
 361 (define-key mh-folder-mode-map "\C-c\C-b"
 362   (function tm-mh-e/burst-multipart/digest))
 363
 364 (defun tm-mh-e/summary-before-quit ()
 365   (let ((buf (get-buffer mh-show-buffer)))
 366     (if buf
 367         (let ((the-buf (current-buffer)))
 368           (switch-to-buffer buf)
 369           (if (and mime::article/preview-buffer
 370                    (setq buf (get-buffer mime::article/preview-buffer))
 371                    )
 372               (progn
 373                 (switch-to-buffer the-buf)
 374                 (kill-buffer buf)
 375                 )
 376             (switch-to-buffer the-buf)
 377             )
 378           ))))
 379
 380 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
 381
 382
 383 ;;; @@ for tmh-comp.el
 384 ;;;
 385
 386 (autoload 'tm-mh-e/edit-again "tmh-comp"
 387   "Clean-up a draft or a message previously sent and make it resendable." t)
 388 (autoload 'tm-mh-e/extract-rejected-mail "tmh-comp"
 389   "Extract a letter returned by the mail system and make it re-editable." t)
 390 (autoload 'tm-mh-e/forward "tmh-comp"
 391   "Forward a message or message sequence by MIME style." t)
 392
 393 (call-after-loaded
 394  'mime-setup
 395  (function
 396   (lambda ()
 397     (substitute-key-definition
 398      'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map)
 399     (substitute-key-definition
 400      'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail
 401      mh-folder-mode-map)
 402     (substitute-key-definition
 403      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
 404
 405     (call-after-loaded
 406      'mh-comp
 407      (function
 408       (lambda ()
 409         (require 'tmh-comp)
 410         ))
 411      'mh-letter-mode-hook)
 412     )))
 413
 414
 415 ;;; @ for BBDB
 416 ;;;
 417
 418 (call-after-loaded
 419  'bbdb
 420  (function
 421   (lambda ()
 422     (require 'tm-bbdb)
 423     )))
 424
 425
 426 ;;; @ end
 427 ;;;
 428
 429 (provide 'tm-mh-e)
 430
 431 (run-hooks 'tm-mh-e-load-hook)
 432
 433 ;;; tm-mh-e.el ends here