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.56 $
  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
  45
  46 ;;; @ version
  47 ;;;
  48
  49 (defconst tm-mh-e/RCS-ID
  50   "$Id: tm-mh-e.el,v 7.56 1996/03/06 02:03:17 morioka Exp $")
  51
  52 (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
  53
  54
  55 ;;; @ variable
  56 ;;;
  57
  58 (defvar tm-mh-e/automatic-mime-preview t
  59   "*If non-nil, show MIME processed message.")
  60
  61 (defvar tm-mh-e/decode-encoded-word t
  62   "*If non-nil, decode encoded-word when it is not MIME preview mode.")
  63
  64
  65 ;;; @ functions
  66 ;;;
  67
  68 (if (not (fboundp 'tm-mh-e/original-mh-display-msg))
  69     (fset 'tm-mh-e/original-mh-display-msg
  70           (symbol-function 'mh-display-msg))
  71   )
  72
  73 (defun mh-display-msg (msg-num folder &optional show-buffer mode)
  74   (or mode
  75       (setq mode tm-mh-e/automatic-mime-preview)
  76       )
  77   ;; Display message NUMBER of FOLDER.
  78   ;; Sets the current buffer to the show buffer.
  79   (set-buffer folder)
  80   (or show-buffer
  81       (setq show-buffer mh-show-buffer))
  82   ;; Bind variables in folder buffer in case they are local
  83   (let ((msg-filename (mh-msg-filename msg-num)))
  84     (if (not (file-exists-p msg-filename))
  85         (error "Message %d does not exist" msg-num))
  86     (set-buffer show-buffer)
  87     (cond ((not (equal msg-filename buffer-file-name))
  88            ;; Buffer does not yet contain message.
  89            (clear-visited-file-modtime)
  90            (unlock-buffer)
  91            (setq buffer-file-name nil)  ; no locking during setup
  92            (setq buffer-read-only nil)
  93            (erase-buffer)
  94            (if mode
  95                (let* ((aname (concat "article-" folder))
  96                       (abuf (get-buffer aname))
  97                       )
  98                  (if abuf
  99                      (progn
 100                        (set-buffer abuf)
 101                        (setq buffer-read-only nil)
 102                        (erase-buffer)
 103                        )
 104                    (setq abuf (get-buffer-create aname))
 105                    (set-buffer abuf)
 106                    )
 107                  (let ((file-coding-system-for-read
 108                         (if (boundp 'MULE) *noconv*))
 109                        kanji-fileio-code)
 110                    (insert-file-contents msg-filename)
 111                    ;; (goto-char (point-min))
 112                    (while (re-search-forward "\r$" nil t)
 113                      (replace-match "")
 114                      )
 115                    )
 116                  (set-buffer-modified-p nil)
 117                  (setq buffer-read-only t)
 118                  (setq buffer-file-name msg-filename)
 119                  (mh-show-mode)
 120                  (mime/viewer-mode nil nil nil
 121                                    aname (concat "show-" folder))
 122                  (goto-char (point-min))
 123                  )
 124              (let ((clean-message-header mh-clean-message-header)
 125                    (invisible-headers mh-invisible-headers)
 126                    (visible-headers mh-visible-headers)
 127                    )
 128                ;; 1995/9/21
 129                ;;   modified by ARIURA <ariura@cc.tuat.ac.jp>
 130                ;;   to support mhl.
 131                (if mhl-formfile
 132                    (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
 133                                            (if (stringp mhl-formfile)
 134                                                (list "-form" mhl-formfile))
 135                                            msg-filename)
 136                  (insert-file-contents msg-filename))
 137                ;; end
 138                (goto-char (point-min))
 139                (cond (clean-message-header
 140                       (mh-clean-msg-header (point-min)
 141                                            invisible-headers
 142                                            visible-headers)
 143                       (goto-char (point-min)))
 144                      (t
 145                       (mh-start-of-uncleaned-message)))
 146                (if tm-mh-e/decode-encoded-word
 147                    (mime/decode-message-header)
 148                  )
 149                (set-buffer-modified-p nil)
 150                (setq buffer-read-only t)
 151                (setq buffer-file-name msg-filename)
 152                (mh-show-mode)
 153                ))
 154            (or (eq buffer-undo-list t)  ;don't save undo info for prev msgs
 155                (setq buffer-undo-list nil))
 156 ;;; Added by itokon (02/19/96)
 157            (setq buffer-file-name msg-filename)
 158 ;;;
 159            (set-mark nil)
 160            (setq mode-line-buffer-identification
 161                  (list (format mh-show-buffer-mode-line-buffer-id
 162                                folder msg-num)))
 163            (set-buffer folder)
 164            (setq mh-showing-with-headers nil)))))
 165
 166 (defun tm-mh-e/view-message (&optional msg)
 167   "MIME decode and play this message."
 168   (interactive)
 169   (if (or (null tm-mh-e/automatic-mime-preview)
 170           (null (get-buffer mh-show-buffer))
 171           (save-excursion
 172             (set-buffer mh-show-buffer)
 173             (not (eq major-mode 'mime/viewer-mode))
 174             ))
 175       (let ((tm-mh-e/automatic-mime-preview t))
 176         (mh-invalidate-show-buffer)
 177         (mh-show-msg msg)
 178         ))
 179   (pop-to-buffer mh-show-buffer)
 180   )
 181
 182 (defun tm-mh-e/toggle-decoding-mode (arg)
 183   "Toggle MIME processing mode.
 184 With arg, turn MIME processing on if arg is positive."
 185   (interactive "P")
 186   (setq tm-mh-e/automatic-mime-preview
 187         (if (null arg)
 188             (not tm-mh-e/automatic-mime-preview)
 189           arg))
 190   (save-excursion
 191     (set-buffer mh-show-buffer)
 192     (if (null tm-mh-e/automatic-mime-preview)
 193         (if (and mime::preview/article-buffer
 194                  (get-buffer mime::preview/article-buffer))
 195             (kill-buffer mime::preview/article-buffer)
 196           )))
 197   (mh-invalidate-show-buffer)
 198   (mh-show (mh-get-msg-num t))
 199   )
 200
 201 (defun tm-mh-e/show (&optional message)
 202   (interactive)
 203   (mh-invalidate-show-buffer)
 204   (mh-show message)
 205   )
 206
 207 (defun tm-mh-e/header-display ()
 208   (interactive)
 209   (mh-invalidate-show-buffer)
 210   (let ((mime-viewer/ignored-field-regexp "^:$")
 211         tm-mh-e/decode-encoded-word)
 212     (mh-header-display)
 213     ))
 214
 215 (defun tm-mh-e/raw-display ()
 216   (interactive)
 217   (mh-invalidate-show-buffer)
 218   (let (tm-mh-e/automatic-mime-preview
 219         tm-mh-e/decode-encoded-word)
 220     (mh-header-display)
 221     ))
 222
 223 (defun tm-mh-e/scroll-up-msg (&optional arg)
 224   (interactive)
 225   (mh-page-msg (or arg 1))
 226   )
 227
 228 (defun tm-mh-e/scroll-down-msg (&optional arg)
 229   (interactive)
 230   (mh-page-msg (- (or arg 1)))
 231   )
 232
 233 (defun tm-mh-e/burst-multipart/digest ()
 234   "Burst apart the current message, which should be a multipart/digest.
 235 The message is replaced by its table of contents and the letters from the
 236 digest are inserted into the folder after that message."
 237   (interactive)
 238   (let ((digest (mh-get-msg-num t)))
 239     (mh-process-or-undo-commands mh-current-folder)
 240     (mh-set-folder-modified-p t)                ; lock folder while bursting
 241     (message "Bursting digest...")
 242     (mh-exec-cmd "mhn" "-store" mh-current-folder digest)
 243     (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
 244     (message "Bursting digest...done")
 245     ))
 246
 247
 248 ;;; @ for tm-view
 249 ;;;
 250
 251 (fset 'tm-mh-e/code-convert-region-to-emacs
 252       (symbol-function 'mime/code-convert-region-to-emacs))
 253
 254 (set-alist 'mime-viewer/code-converter-alist
 255            'mh-show-mode
 256            (function tm-mh-e/code-convert-region-to-emacs))
 257
 258 (defun tm-mh-e/content-header-filter ()
 259   (goto-char (point-min))
 260   (mime-preview/cut-header)
 261   (tm-mh-e/code-convert-region-to-emacs (point-min)(point-max)
 262                                         mime/default-coding-system)
 263   (mime/decode-message-header)
 264   )
 265
 266 (set-alist 'mime-viewer/content-header-filter-alist
 267            'mh-show-mode
 268            (function tm-mh-e/content-header-filter))
 269
 270 (defun tm-mh-e/quitting-method ()
 271   (let ((win (get-buffer-window
 272               mime/output-buffer-name))
 273         (buf (current-buffer))
 274         )
 275     (if win
 276         (delete-window win)
 277       )
 278     (pop-to-buffer
 279      (let ((name (buffer-name buf)))
 280        (substring name 5)
 281        ))
 282     (if (not tm-mh-e/automatic-mime-preview)
 283         (mh-invalidate-show-buffer)
 284       )
 285     (mh-show (mh-get-msg-num t))
 286     ))
 287
 288 (set-alist 'mime-viewer/quitting-method-alist
 289            'mh-show-mode
 290            (function tm-mh-e/quitting-method))
 291
 292 ;; (defun tm-mh-e/set-window-configuration ()
 293 ;;   (save-excursion
 294 ;;     (set-buffer mh-show-buffer)
 295 ;;     (setq mime::preview/original-window-configuration
 296 ;;           (current-window-configuration))
 297 ;;     ))
 298
 299 ;; (add-hook 'mh-show-hook 'tm-mh-e/set-window-configuration)
 300
 301
 302 ;;; @@ for tm-partial
 303 ;;;
 304
 305 (call-after-loaded
 306  'tm-partial
 307  (function
 308   (lambda ()
 309     (set-atype 'mime/content-decoding-condition
 310                '((type . "message/partial")
 311                  (method . mime-article/grab-message/partials)
 312                  (major-mode . mh-show-mode)
 313                  (summary-buffer-exp
 314                   . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
 315                              (string-match "^show-\\(.+\\)$" article-buffer))
 316                          (substring article-buffer
 317                                     (match-beginning 1) (match-end 1))
 318                          ))
 319                  ))
 320     (set-alist 'tm-partial/preview-article-method-alist
 321                'mh-show-mode
 322                (function
 323                 (lambda ()
 324                   (let ((tm-mh-e/automatic-mime-preview t))
 325                     (tm-mh-e/show)
 326                     ))))
 327     )))
 328
 329
 330 ;;; @ set up
 331 ;;;
 332
 333 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
 334 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
 335 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
 336 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
 337 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
 338 (define-key mh-folder-mode-map "\r" (function tm-mh-e/scroll-up-msg))
 339 (define-key mh-folder-mode-map "\e\r" (function tm-mh-e/scroll-down-msg))
 340 (define-key mh-folder-mode-map "\C-c\C-b"
 341   (function tm-mh-e/burst-multipart/digest))
 342
 343 (defun tm-mh-e/summary-before-quit ()
 344   (let ((buf (get-buffer mh-show-buffer)))
 345     (if buf
 346         (let ((the-buf (current-buffer)))
 347           (switch-to-buffer buf)
 348           (if (and mime::article/preview-buffer
 349                    (setq buf (get-buffer mime::article/preview-buffer))
 350                    )
 351               (progn
 352                 (switch-to-buffer the-buf)
 353                 (kill-buffer buf)
 354                 )
 355             (switch-to-buffer the-buf)
 356             )
 357           ))))
 358
 359 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
 360
 361
 362 ;;; @@ for tmh-comp.el
 363 ;;;
 364
 365 (autoload 'tm-mh-e/edit-again "tmh-comp"
 366   "Clean-up a draft or a message previously sent and make it resendable." t)
 367 (autoload 'tm-mh-e/extract-rejected-mail "tmh-comp"
 368   "Extract a letter returned by the mail system and make it re-editable." t)
 369 (autoload 'tm-mh-e/forward "tmh-comp"
 370   "Forward a message or message sequence by MIME style." t)
 371
 372 (call-after-loaded
 373  'mime-setup
 374  (function
 375   (lambda ()
 376     (substitute-key-definition
 377      'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map)
 378     (substitute-key-definition
 379      'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail
 380      mh-folder-mode-map)
 381     (substitute-key-definition
 382      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
 383
 384     (call-after-loaded
 385      'mh-comp
 386      (function
 387       (lambda ()
 388         (require 'tmh-comp)
 389         ))
 390      'mh-letter-mode-hook)
 391     )))
 392
 393
 394 ;;; @ for BBDB
 395 ;;;
 396
 397 (call-after-loaded
 398  'bbdb
 399  (function
 400   (lambda ()
 401     (require 'tm-bbdb)
 402     )))
 403
 404
 405 ;;; @ end
 406 ;;;
 407
 408 (provide 'tm-mh-e)
 409
 410 (run-hooks 'tm-mh-e-load-hook)
 411
 412 ;;; tm-mh-e.el ends here