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