cgit.sxemacs.org Git - packages/blob - xemacs-packages/tm/tm-mh-e.el

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