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,1994,1995 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.26 $
  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 (require 'tl-str)
  32 (require 'tl-misc)
  33 (require 'mh-e)
  34 (if (not (boundp 'mh-e-version))
  35     (require 'tm-mh-e3)
  36   )
  37 (require 'tm-view)
  38
  39
  40 ;;; @ version
  41 ;;;
  42
  43 (defconst tm-mh-e/RCS-ID
  44   "$Id: tm-mh-e.el,v 7.26 1995/11/21 08:55:01 morioka Exp $")
  45
  46 (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
  47
  48
  49 ;;; @ variable
  50 ;;;
  51
  52 (defvar tm-mh-e/automatic-mime-preview t
  53   "If non-nil, show MIME processed message.")
  54
  55 (defvar tm-mh-e/decode-encoded-word t
  56   "If non-nil, decode encoded-word when it is not MIME preview mode.")
  57
  58 (defvar tm-mh-e/forwcomps "forwcomps")
  59
  60
  61 ;;; @ functions
  62 ;;;
  63
  64 (if (not (fboundp 'tm-mh-e/original-mh-display-msg))
  65     (fset 'tm-mh-e/original-mh-display-msg
  66           (symbol-function 'mh-display-msg))
  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 ((msg-filename (mh-msg-filename msg-num)))
  80     (if (not (file-exists-p msg-filename))
  81         (error "Message %d does not exist" msg-num))
  82     (set-buffer show-buffer)
  83     (cond ((not (equal msg-filename buffer-file-name))
  84            ;; Buffer does not yet contain message.
  85            (clear-visited-file-modtime)
  86            (unlock-buffer)
  87            (setq buffer-file-name nil)  ; no locking during setup
  88            (setq buffer-read-only nil)
  89            (erase-buffer)
  90            (if mode
  91                (let* ((aname (concat "article-" folder))
  92                       (abuf (get-buffer aname))
  93                       )
  94                  (if abuf
  95                      (progn
  96                        (set-buffer abuf)
  97                        (setq buffer-read-only nil)
  98                        (erase-buffer)
  99                        )
 100                    (setq abuf (get-buffer-create aname))
 101                    (set-buffer abuf)
 102                    )
 103                  (let ((file-coding-system-for-read
 104                         (if (boundp 'MULE) *noconv*))
 105                        kanji-fileio-code)
 106                    (insert-file-contents msg-filename)
 107                    ;; (goto-char (point-min))
 108                    (while (re-search-forward "\r$" nil t)
 109                      (replace-match "")
 110                      )
 111                    )
 112                  (set-buffer-modified-p nil)
 113                  (setq buffer-read-only t)
 114                  (mh-show-mode)
 115                  (mime/viewer-mode nil nil nil
 116                                    aname (concat "show-" folder))
 117                  (goto-char (point-min))
 118                  )
 119              (let ((clean-message-header mh-clean-message-header)
 120                    (invisible-headers mh-invisible-headers)
 121                    (visible-headers mh-visible-headers)
 122                    )
 123                ;; 1995/9/21
 124                ;;   modified by ARIURA <ariura@cc.tuat.ac.jp>
 125                ;;   to support mhl.
 126                (if mhl-formfile
 127                    (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
 128                                            (if (stringp mhl-formfile)
 129                                                (list "-form" mhl-formfile))
 130                                            msg-filename)
 131                  (insert-file-contents msg-filename))
 132                ;; end
 133                (goto-char (point-min))
 134                (cond (clean-message-header
 135                       (mh-clean-msg-header (point-min)
 136                                            invisible-headers
 137                                            visible-headers)
 138                       (goto-char (point-min)))
 139                      (t
 140                       (mh-start-of-uncleaned-message)))
 141                (if tm-mh-e/decode-encoded-word
 142                    (mime/decode-message-header)
 143                  )
 144                (set-buffer-modified-p nil)
 145                (setq buffer-read-only t)
 146                (mh-show-mode)
 147                ))
 148            (or (eq buffer-undo-list t)  ;don't save undo info for prev msgs
 149                (setq buffer-undo-list nil))
 150            (setq buffer-file-name msg-filename)
 151            (set-mark nil)
 152            (setq mode-line-buffer-identification
 153                  (list (format mh-show-buffer-mode-line-buffer-id
 154                                folder msg-num)))
 155            (set-buffer folder)
 156            (setq mh-showing-with-headers nil)))))
 157
 158 (defun tm-mh-e/view-message (&optional msg)
 159   "MIME decode and play this message."
 160   (interactive)
 161   (if (or (null tm-mh-e/automatic-mime-preview)
 162           (null (get-buffer mh-show-buffer))
 163           (save-excursion
 164             (set-buffer mh-show-buffer)
 165             (not (eq major-mode 'mime/viewer-mode))
 166             ))
 167       (let ((tm-mh-e/automatic-mime-preview t))
 168         (mh-invalidate-show-buffer)
 169         (mh-show-msg msg)
 170         ))
 171   (pop-to-buffer mh-show-buffer)
 172   )
 173
 174 (defun tm-mh-e/toggle-decoding-mode (arg)
 175   "Toggle MIME processing mode.
 176 With arg, turn MIME processing on if arg is positive."
 177   (interactive "P")
 178   (setq tm-mh-e/automatic-mime-preview
 179         (if (null arg)
 180             (not tm-mh-e/automatic-mime-preview)
 181           arg))
 182   (save-excursion
 183     (set-buffer mh-show-buffer)
 184     (if (null tm-mh-e/automatic-mime-preview)
 185         (if (and mime::preview/article-buffer
 186                  (get-buffer mime::preview/article-buffer))
 187             (kill-buffer mime::preview/article-buffer)
 188           )))
 189   (mh-invalidate-show-buffer)
 190   (mh-show (mh-get-msg-num t))
 191   )
 192
 193 (defun tm-mh-e/show (&optional message)
 194   (interactive)
 195   (mh-invalidate-show-buffer)
 196   (mh-show message)
 197   )
 198
 199 (defun tm-mh-e/header-display ()
 200   (interactive)
 201   (mh-invalidate-show-buffer)
 202   (let (mime-viewer/ignored-field-list
 203         tm-mh-e/decode-encoded-word)
 204     (mh-header-display)
 205     ))
 206
 207 (defun tm-mh-e/raw-display ()
 208   (interactive)
 209   (mh-invalidate-show-buffer)
 210   (let (tm-mh-e/automatic-mime-preview
 211         tm-mh-e/decode-encoded-word)
 212     (mh-header-display)
 213     ))
 214
 215
 216 ;;; @ for tm-view
 217 ;;;
 218
 219 (fset 'tm-mh-e/code-convert-region-to-emacs
 220       (symbol-function 'mime/code-convert-region-to-emacs))
 221
 222 (defun tm-mh-e/content-header-filter ()
 223   (goto-char (point-min))
 224   (while (and (re-search-forward mime-viewer/ignored-field-regexp nil t)
 225               (progn
 226                 (delete-region
 227                  (match-beginning 0)
 228                  (save-excursion
 229                    (and
 230                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 231                     (match-beginning 0)
 232                     )))
 233                 t)))
 234   (tm-mh-e/code-convert-region-to-emacs (point-min)(point-max)
 235                                         mime/default-coding-system)
 236   (mime/decode-message-header)
 237   (if (featurep 'hilit19)
 238       (hilit-rehighlight-buffer-quietly)
 239     )
 240   )
 241
 242 (defun tm-mh-e/quitting-method ()
 243   (let ((win (get-buffer-window
 244               mime/output-buffer-name))
 245         (buf (current-buffer))
 246         )
 247     (if win
 248         (delete-window win)
 249       )
 250     (pop-to-buffer
 251      (let ((name (buffer-name buf)))
 252        (substring name 5)
 253        ))
 254     (if (not tm-mh-e/automatic-mime-preview)
 255         (mh-invalidate-show-buffer)
 256       )
 257     (mh-show (mh-get-msg-num t))
 258     ))
 259
 260
 261 ;;; @ for tm-partial
 262 ;;;
 263
 264 (call-after-loaded
 265  'tm-partial
 266  (function
 267   (lambda ()
 268     (set-atype 'mime/content-decoding-condition
 269                '((type . "message/partial")
 270                  (method . mime-article/grab-message/partials)
 271                  (major-mode . mh-show-mode)
 272                  (summary-buffer-exp
 273                   . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
 274                              (string-match "^show-\\(.+\\)$" article-buffer))
 275                          (substring article-buffer
 276                                     (match-beginning 1) (match-end 1))
 277                          ))
 278                  ))
 279     (set-alist 'tm-partial/preview-article-method-alist
 280                'mh-show-mode
 281                (function
 282                 (lambda ()
 283                   (let ((tm-mh-e/automatic-mime-preview t))
 284                     (tm-mh-e/show)
 285                     ))))
 286     )))
 287
 288
 289 ;;; @ for tm-edit
 290 ;;;
 291
 292 (defun tm-mh-e::make-message (folder number)
 293   (vector folder number)
 294   )
 295
 296 (defun tm-mh-e::message/folder (message)
 297   (elt message 0)
 298   )
 299
 300 (defun tm-mh-e::message/number (message)
 301   (elt message 1)
 302   )
 303
 304 (defun tm-mh-e::message/file-name (message)
 305   (expand-file-name
 306    (tm-mh-e::message/number message)
 307    (mh-expand-file-name (tm-mh-e::message/folder message))
 308    ))
 309
 310 ;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 311 ;;;     1995/11/14 (cf. [tm-ja:1096])
 312 (defun tm-mh-e/prompt-for-message (prompt folder &optional default)
 313   (let* ((files
 314           (directory-files (mh-expand-file-name folder) nil "^[0-9]+$")
 315           )
 316          (folder-buf (get-buffer folder))
 317          (default
 318            (if folder-buf
 319                (save-excursion
 320                  (set-buffer folder-buf)
 321                  (let ((show-buffer (get-buffer mh-show-buffer)))
 322                    (if show-buffer
 323                        (file-name-nondirectory
 324                         (buffer-file-name show-buffer))
 325                      ))))))
 326     (if (or (null default)
 327             (not (string-match "^[0-9]+$" default)))
 328         (setq default
 329               (if (string= folder mh-sent-from-folder)
 330                   (int-to-string mh-sent-from-msg)
 331                 (car files)
 332                 )))
 333     (completing-read prompt
 334                      (let ((i 0))
 335                        (mapcar (function
 336                                 (lambda (file)
 337                                   (setq i (+ i 1))
 338                                   (list file i)
 339                                   ))
 340                                files)
 341                        ) nil nil default)
 342     ))
 343
 344 (defun tm-mh-e/query-message ()
 345   (let* ((folder (mh-prompt-for-folder
 346                   "Message from" (or mh-sent-from-folder "+inbox") nil))
 347          (number (tm-mh-e/prompt-for-message "Message number: " folder))
 348          )
 349     (tm-mh-e::make-message folder number)
 350     ))
 351 ;;; end
 352
 353 ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 354 ;;;     1995/11/14 (cf. [tm-ja:1099])
 355 (defun tm-mh-e/forward (to cc &optional msg-or-seq)
 356   "Forward a message or message sequence as MIME multipart/digest.
 357 Defaults to displayed message. If optional prefix argument provided,
 358 then prompt for the message sequence. See also documentation for
 359 `\\[mh-send]' function."
 360   (interactive (progn
 361                  (require 'mh-comp)
 362                  (list (mh-read-address "To: ")
 363                        (mh-read-address "Cc: ")
 364                        (if current-prefix-arg
 365                            (mh-read-seq-default "Forward" t)
 366                          (mh-get-msg-num t)
 367                          ))))
 368   (or msg-or-seq
 369       (setq msg-or-seq (mh-get-msg-num t)))
 370   (if (numberp msg-or-seq)
 371       (setq msg-or-seq (int-to-string msg-or-seq)))
 372   (let* ((folder mh-current-folder)
 373          (config (current-window-configuration))
 374          ;; use "draft" for compatibility with forw.
 375          ;; forw always leaves file in "draft" since it doesn't have -draft
 376          (draft-name (expand-file-name "draft" mh-user-path))
 377          (draft (cond ((or (not (file-exists-p draft-name))
 378                            (y-or-n-p "The file `draft' exists.  Discard it? "))
 379                        (mh-exec-cmd "comp"
 380                                     "-noedit" "-nowhatnowproc"
 381                                     "-form" tm-mh-e/forwcomps
 382                                     "-nodraftfolder")
 383                        (prog1
 384                            (mh-read-draft "" draft-name t)
 385                          (mh-insert-fields "To:" to "Cc:" cc)
 386                          (set-buffer-modified-p nil)))
 387                       (t
 388                        (mh-read-draft "" draft-name nil)))))
 389     (let (orig-from orig-subject)
 390       (require 'tm-edit)
 391       (goto-char (point-min))
 392       (save-excursion
 393         (save-restriction
 394           (re-search-forward "^-*\n")
 395           ;; modified by Katsumi Yamaoka <yamaoka@ga.sony.co.jp>
 396           ;;    1995/11/17 (cf.[tm-ja:1116])
 397           (and (< (point) (point-max))
 398                (not (re-search-forward "^[\t ]*\n" nil t))
 399                (goto-char (point-max))
 400                (insert "\n"))
 401           (insert "--<<digest>>-{\n")
 402           (mh-exec-cmd-output "pick" nil folder msg-or-seq)
 403           (narrow-to-region (point) (mark t))
 404           (while (re-search-forward "^\\([0-9]+\\)\n" nil t)
 405             (let ((forw-msg
 406                    (buffer-substring (match-beginning 1) (match-end 1))))
 407               (replace-match "--[[message/rfc822]]\n" nil nil)
 408               (insert-file (mh-expand-file-name
 409                             forw-msg (mh-expand-file-name folder)))
 410               (if (not (bolp)) (insert "\n"))
 411               (mime-editor/inserted-message-filter))
 412             (goto-char (mark t)))
 413           (insert-string "--}-<<digest>>")))
 414       (re-search-forward "^--\\[\\[message/rfc822\\]")
 415       (forward-line 1)
 416       (save-restriction
 417         (narrow-to-region (point) (point-max))
 418         (setq orig-from (mh-get-header-field "From:"))
 419         (setq orig-subject (mh-get-header-field "Subject:")))
 420       (let ((forw-subject
 421              (mh-forwarded-letter-subject orig-from orig-subject)))
 422         (mh-insert-fields "Subject:" forw-subject)
 423         (goto-char (point-min))
 424         (re-search-forward "^--\\[\\[message/rfc822\\]")
 425         (forward-line -1)
 426         (delete-other-windows)
 427         (if (numberp msg-or-seq)
 428             (mh-add-msgs-to-seq msg-or-seq 'forwarded t)
 429           (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t))
 430         (mh-compose-and-send-mail draft "" folder msg-or-seq
 431                                   to forw-subject cc
 432                                   mh-note-forw "Forwarded:"
 433                                   config)))))
 434 ;;; end
 435
 436 (defun tm-mh-e/insert-message (&optional message)
 437   (if (null message)
 438       (setq message (tm-mh-e/query-message))
 439     )
 440   (insert-file (tm-mh-e::message/file-name message))
 441   (mime-editor/inserted-message-filter)
 442   )
 443
 444 (call-after-loaded
 445  'tm-edit
 446  (function
 447   (lambda ()
 448     (set-alist
 449      'mime-editor/message-inserter-alist
 450      'mh-letter-mode (function tm-mh-e/insert-message))
 451     (set-alist
 452      'mime-editor/mail-inserter-alist
 453      'mh-letter-mode (function tm-mh-e/insert-message))
 454     (set-alist
 455      'mime-editor/mail-inserter-alist
 456      'news-reply-mode (function tm-mh-e/insert-message))
 457     )))
 458
 459 (call-after-loaded
 460  'mime-setup
 461  (function
 462   (lambda ()
 463     (substitute-key-definition
 464      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
 465     )))
 466
 467
 468 ;;; @ set up
 469 ;;;
 470
 471 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
 472 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
 473 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
 474 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
 475 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
 476 (define-key mh-folder-mode-map "\r"
 477   (function (lambda ()
 478               (interactive)
 479               (scroll-other-window 1)
 480               )))
 481 (define-key mh-folder-mode-map "\e\r"
 482   (function (lambda ()
 483               (interactive)
 484               (scroll-other-window -1)
 485               )))
 486
 487 (defun tm-mh-e/summary-before-quit ()
 488   (let ((buf (get-buffer mh-show-buffer)))
 489     (if buf
 490         (let ((the-buf (current-buffer)))
 491           (switch-to-buffer buf)
 492           (if (and mime::article/preview-buffer
 493                    (setq buf (get-buffer mime::article/preview-buffer))
 494                    )
 495               (progn
 496                 (switch-to-buffer the-buf)
 497                 (kill-buffer buf)
 498                 )
 499             (switch-to-buffer the-buf)
 500             )
 501           ))))
 502
 503 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
 504
 505 (set-alist 'mime-viewer/quitting-method-alist
 506            'mh-show-mode
 507            (function tm-mh-e/quitting-method))
 508
 509 (set-alist 'mime-viewer/content-header-filter-alist
 510            'mh-show-mode
 511            (function tm-mh-e/content-header-filter))
 512
 513 (set-alist 'mime-viewer/code-converter-alist
 514            'mh-show-mode
 515            (function tm-mh-e/code-convert-region-to-emacs))
 516
 517
 518 ;;; @ end
 519 ;;;
 520
 521 (provide 'tm-mh-e)
 522
 523 (run-hooks 'tm-mh-e-load-hook)