tm-vm.el

   1 ;;;
   2 ;;; tm-vm.el --- tm-MUA for VM
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;;
   6 ;;; Author:   MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
   7 ;;;           Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
   8 ;;;           MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;;           Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
  10 ;;;           Oscar Figueiredo <figueire@lspsun2.epfl.ch>
  11 ;;; modified by SHIONO Jun'ichi <jun@p5.nm.fujitsu.co.jp>,
  12 ;;;         and Steinar Bang <steinarb@falch.no>,
  13 ;;;
  14 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
  15 ;;;
  16 ;;; This file is part of tm (Tools for MIME).
  17 ;;;
  18 ;;; Plese insert (require 'tm-vm) in your ~/.vm or ~/.emacs file.
  19 ;;;
  20
  21 (require 'tm-view)
  22 (require 'vm)
  23
  24 (defconst tm-vm/RCS-ID
  25   "$Id: tm-vm.el,v 7.7 1995/11/15 15:35:54 morioka Exp $")
  26 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
  27
  28 (define-key vm-mode-map "Z" 'tm-vm/view-message)
  29 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
  30 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
  31
  32
  33 ;;; @ for MIME encoded-words
  34 ;;;
  35
  36 (defvar tm-vm/use-tm-patch nil
  37   "Does not decode encoded-words in summary buffer if it is t.
  38 If you use tiny-mime patch for VM (by RIKITAKE Kenji
  39 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  40
  41 (or tm-vm/use-tm-patch
  42     (progn
  43 ;;;
  44 ;; by Steinar Bang <steinarb@falch.no>
  45 (setq vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c, %I\"%UA\"\n")
  46
  47 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
  48 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
  49
  50 (defun tm-vm/default-chop-full-name (address)
  51   (let* ((ret (vm-default-chop-full-name address))
  52          (full-name (car ret))
  53          )
  54     (if (stringp full-name)
  55         (cons (mime-eword/decode-string full-name)
  56               (cdr ret))
  57       ret)))
  58
  59 ;; by Steinar Bang <steinarb@falch.no>
  60 (defun vm-summary-function-A (m)
  61   (mime-eword/decode-string (vm-su-subject m))
  62   )
  63 ;;;
  64 ))
  65
  66 (defun tm-vm/decode-message-header (&optional count)
  67   "Decode MIME header of current message through tiny-mime.
  68 Numeric prefix argument COUNT means to decode the current message plus
  69 the next COUNT-1 messages.  A negative COUNT means decode the current
  70 message and the previous COUNT-1 messages.
  71 When invoked on marked messages (via vm-next-command-uses-marks),
  72 all marked messages are affected, other messages are ignored."
  73   (interactive "p")
  74   (or count (setq count 1))
  75   (vm-follow-summary-cursor)
  76   (vm-select-folder-buffer)
  77   (vm-check-for-killed-summary)
  78   (vm-error-if-folder-empty)
  79   (vm-error-if-folder-read-only)
  80   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  81         (realm nil)
  82         (vlist nil)
  83         (vbufs nil))
  84     (save-excursion
  85       (while mlist
  86         (setq realm (vm-real-message-of (car mlist)))
  87         ;; Go to real folder of this message.
  88         ;; But maybe this message is already real message...
  89         (set-buffer (vm-buffer-of realm))
  90         (let ((buffer-read-only nil))
  91           (vm-save-restriction
  92            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
  93            (mime/decode-message-header))
  94           (let ((vm-message-pointer (list realm))
  95                 (last-command nil))
  96             (vm-discard-cached-data))
  97           ;; Mark each virtual and real message for later summary
  98           ;; update.
  99           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 100           (while vlist
 101             (vm-mark-for-summary-update (car vlist))
 102             ;; Remember virtual and real folders related this message,
 103             ;; for later display update.
 104             (or (memq (vm-buffer-of (car vlist)) vbufs)
 105                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 106             (setq vlist (cdr vlist)))
 107           (if (eq vm-flush-interval t)
 108               (vm-stuff-virtual-attributes realm)
 109             (vm-set-modflag-of realm t)))
 110         (setq mlist (cdr mlist)))
 111       ;; Update mail-buffers and summaries.
 112       (while vbufs
 113         (set-buffer (car vbufs))
 114         (vm-preview-current-message)
 115         (setq vbufs (cdr vbufs))))))
 116
 117
 118 ;;; @ automatic MIME preview
 119 ;;;
 120
 121 (defvar tm-vm/automatic-mime-preview t
 122   "If non-nil, show MIME processed article.")
 123
 124 (defun tm-vm/preview-current-message ()
 125   ;;; suggested by Simon Rowe <smr@robots.oxford.ac.uk>
 126   ;;;   (c.f. [tm-eng:163])
 127   ;; Selecting a new mail message, but we're already displaying a mime
 128   ;; on in the window, make sure that the mail buffer is displayed.
 129   (if (get-buffer-window "*MIME-out*")
 130       (delete-window (get-buffer-window (get-buffer "*MIME-out*")))
 131     )
 132   (display-buffer (current-buffer))
 133   (if (and tm-vm/automatic-mime-preview
 134            (let* ((mp (car vm-message-pointer))
 135                   (ct  (vm-get-header-contents mp "Content-Type:"))
 136                   (cte (vm-get-header-contents
 137                         mp "Content-Transfer-Encoding:"))
 138                   )
 139              ;; Check if this message actually is a mime, or just a text
 140              ;; one sent by someone using PINE or similar.
 141              (and ct
 142                   (not (and (string= (car (mime/parse-Content-Type ct))
 143                                      "text/plain")
 144                             (member cte '("7bit" "8bit" "binary"))
 145                             ))))
 146            )
 147       (let ((win (selected-window)))
 148         (vm-display (current-buffer) t
 149                     '(tm-vm/preview-current-message
 150                       vm-preview-current-message)
 151                     '(tm-vm/preview-current-message reading-message))
 152         (mime/viewer-mode)
 153         (select-window win)
 154         )))
 155
 156 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 157 (add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message)
 158
 159 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 160 ;;      1995/11/14 (c.f. [tm-eng:162])
 161 (defun tm-vm/scroll-forward ()
 162   (interactive)
 163   (if (not tm-vm/automatic-mime-preview)
 164       (vm-scroll-forward)
 165     (let* ((summary-buffer (or vm-summary-buffer
 166                                (and (eq major-mode 'vm-summary-mode)
 167                                     (current-buffer))))
 168            (summary-win (get-buffer-window summary-buffer))
 169            (mail-buffer (save-excursion
 170                           (set-buffer summary-buffer)
 171                           vm-mail-buffer))
 172            (mail-win (get-buffer-window mail-buffer))
 173            (preview-win (get-buffer-window
 174                          (save-excursion
 175                            (set-buffer mail-buffer)
 176                            mime::article/preview-buffer))))
 177       (if preview-win
 178           (progn
 179             (select-window preview-win)
 180             (if (pos-visible-in-window-p (point-max) preview-win)
 181                 (progn
 182                   (switch-to-buffer mail-buffer)
 183                   (goto-char (point-max))
 184                   (select-window summary-win))
 185               (scroll-up)
 186               (switch-to-buffer mail-buffer)
 187               (select-window summary-win))))
 188       (vm-scroll-forward)
 189       (save-excursion
 190         (set-buffer summary-buffer)
 191         (setq mail-win (get-buffer-window vm-mail-buffer)))
 192       (if mail-win
 193           (progn
 194             (select-window mail-win)
 195             (switch-to-buffer mime::article/preview-buffer)
 196             (select-window summary-win)))
 197       )))
 198
 199 (defun tm-vm/scroll-backward ()
 200   (interactive)
 201   (if (not tm-vm/automatic-mime-preview)
 202       (vm-scroll-backward)
 203     (let* ((summary-buffer (or vm-summary-buffer
 204                                (and (eq major-mode 'vm-summary-mode)
 205                                     (current-buffer))))
 206            (summary-win (get-buffer-window summary-buffer))
 207            (mail-buffer (save-excursion
 208                           (set-buffer summary-buffer)
 209                           vm-mail-buffer))
 210            (mail-win (get-buffer-window mail-buffer))
 211            (preview-win (get-buffer-window
 212                          (save-excursion
 213                            (set-buffer mail-buffer)
 214                            mime::article/preview-buffer))))
 215       (if preview-win
 216           (progn
 217             (select-window preview-win)
 218             (if (pos-visible-in-window-p (point-min) preview-win)
 219                 (progn
 220                   (switch-to-buffer mail-buffer)
 221                   (goto-char (point-min))
 222                   (select-window summary-win))
 223               (scroll-down)
 224               (switch-to-buffer mail-buffer)
 225               (select-window summary-win))))
 226       (vm-scroll-backward nil)
 227       (save-excursion
 228         (set-buffer summary-buffer)
 229         (setq mail-win (get-buffer-window vm-mail-buffer)))
 230       (if mail-win
 231           (progn
 232             (select-window mail-win)
 233             (switch-to-buffer mime::article/preview-buffer)
 234             (select-window summary-win)))
 235       )))
 236
 237 (defun tm-vm/quit ()
 238   (interactive)
 239   (save-excursion
 240     (set-buffer vm-mail-buffer)
 241     (if mime::article/preview-buffer
 242         (kill-buffer mime::article/preview-buffer)))
 243   (vm-quit)
 244   )
 245
 246 (substitute-key-definition 'vm-scroll-forward
 247                            'tm-vm/scroll-forward vm-mode-map)
 248 (substitute-key-definition 'vm-scroll-backward
 249                            'tm-vm/scroll-backward vm-mode-map)
 250 (substitute-key-definition 'vm-quit
 251                            'tm-vm/quit vm-mode-map)
 252 ;; end
 253
 254
 255 (defun tm-vm/toggle-preview-mode ()
 256   (interactive)
 257   (if tm-vm/automatic-mime-preview
 258       (progn
 259         (setq tm-vm/automatic-mime-preview nil)
 260         (vm-select-folder-buffer)
 261         (vm-display (current-buffer) t
 262                     '(tm-vm/toggle-preview-mode)
 263                     '(tm-vm/toggle-preview-mode reading-message))
 264         )
 265     (setq tm-vm/automatic-mime-preview t)
 266     (let ((win (selected-window)))
 267       (vm-select-folder-buffer)
 268       (save-window-excursion
 269         (let* ((mp (car vm-message-pointer))
 270                (ct  (vm-get-header-contents mp "Content-Type:"))
 271                (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 272                )
 273           (mime/viewer-mode nil (mime/parse-Content-Type (or ct "")) cte)
 274           ))
 275       (vm-display mime::article/preview-buffer t
 276                   '(tm-vm/toggle-preview-mode)
 277                   '(tm-vm/toggle-preview-mode reading-message))
 278       (select-window win)
 279       )
 280     ))
 281
 282
 283 ;;; @ for tm-view
 284 ;;;
 285
 286 (defun tm-vm/quit-view-message ()
 287   "Quit MIME-viewer and go back to VM.
 288 This function is called by `mime-viewer/quit' command via
 289 `mime-viewer/quitting-method-alist'."
 290   (mime-viewer/kill-buffer)
 291   (if (get-buffer mime/output-buffer-name)
 292       (bury-buffer mime/output-buffer-name))
 293   (vm-select-folder-buffer)
 294   (vm-display (current-buffer) t '(mime-viewer/quit mime-viewer/up-content)
 295               '(mime-viewer/quit reading-message)))
 296
 297 (defun tm-vm/view-message ()
 298   "Decode and view MIME encoded message, under VM."
 299   (interactive)
 300   (vm-follow-summary-cursor)
 301   (vm-select-folder-buffer)
 302   (vm-check-for-killed-summary)
 303   (vm-error-if-folder-empty)
 304   (vm-display (current-buffer) t '(tm-vm/view-message)
 305               '(tm-vm/view-mesage reading-message))
 306   (let* ((mp (car vm-message-pointer))
 307          (ct  (vm-get-header-contents mp "Content-Type:"))
 308          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 309          (exposed (= (point-min) (vm-start-of mp))))
 310     (save-restriction
 311       (vm-widen-page)
 312       ;; vm-widen-page hides exposed header if pages are delimited.
 313       ;; So, here we expose it again.
 314       (if exposed
 315           (narrow-to-region (vm-start-of mp) (point-max)))
 316       (select-window (vm-get-buffer-window (current-buffer)))
 317       (mime/viewer-mode nil
 318                         (mime/parse-Content-Type (or ct ""))
 319                         cte)
 320       )))
 321
 322 (set-alist 'mime-viewer/quitting-method-alist
 323            'vm-mode
 324            'tm-vm/quit-view-message)
 325
 326 (set-alist 'mime-viewer/quitting-method-alist
 327            'vm-virtual-mode
 328            'tm-vm/quit-view-message)
 329
 330
 331 ;;; @ for tm-partial
 332 ;;;
 333
 334 (call-after-loaded
 335  'tm-partial
 336  (function
 337   (lambda ()
 338     (set-atype 'mime/content-decoding-condition
 339                '((type . "message/partial")
 340                  (method . mime-article/grab-message/partials)
 341                  (major-mode . vm-mode)
 342                  (summary-buffer-exp . vm-summary-buffer)
 343                  ))
 344     (set-alist 'tm-partial/preview-article-method-alist
 345                'vm-mode
 346                (function
 347                 (lambda ()
 348                   (tm-vm/view-message)
 349                   )))
 350     )))
 351
 352
 353 ;;; @ for tm-edit
 354 ;;;
 355
 356 ;; 1995/11/9 by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
 357 ;;      (c.f. [tm ML:1075])
 358 (defun tm-vm/insert-message (&optional message)
 359   (interactive)
 360   (let* (mail-yank-hooks
 361          (mail-citation-hook '(mime-editor/inserted-message-filter))
 362          (mail-reply-buffer vm-mail-buffer)
 363          )
 364     (if (null message)
 365         (call-interactively 'vm-yank-message)
 366       (vm-yank-message message))
 367     ))
 368
 369
 370 ;;; @@ for multipart/digest
 371 ;;;
 372
 373 (defun tm-vm/enclose-messages (mlist)
 374   "Enclose the messages in MLIST as multipart/digest.
 375 The resulting digest is inserted at point in the current buffer.
 376
 377 MLIST should be a list of message structs (real or virtual).
 378 These are the messages that will be enclosed."
 379   (if mlist
 380       (let ((digest (consp (cdr mlist)))
 381             m)
 382         (save-restriction
 383           (narrow-to-region (point) (point))
 384           (while mlist
 385             (setq m (vm-real-message-of (car mlist)))
 386             (mime-editor/insert-tag "message" "rfc822")
 387             (tm-vm/insert-message m)
 388             (goto-char (point-max))
 389             (setq mlist (cdr mlist)))
 390           (if digest
 391               (mime-editor/enclose-digest-region (point-min) (point-max)))
 392           ))))
 393
 394 (defun tm-vm/forward-message ()
 395   "Forward the current message to one or more recipients.
 396 You will be placed in a Mail mode buffer as you would with a
 397 reply, but you must fill in the To: header and perhaps the
 398 Subject: header manually."
 399   (interactive)
 400   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 401       (vm-forward-message)
 402     (vm-follow-summary-cursor)
 403     (vm-select-folder-buffer)
 404     (vm-check-for-killed-summary)
 405     (vm-error-if-folder-empty)
 406     (if (eq last-command 'vm-next-command-uses-marks)
 407         (let ((vm-digest-send-type vm-forwarding-digest-type))
 408           (setq this-command 'vm-next-command-uses-marks)
 409           (command-execute 'tm-vm/send-digest))
 410       (let ((dir default-directory)
 411             (mp vm-message-pointer))
 412         (save-restriction
 413           (widen)
 414           (vm-mail-internal
 415            (format "forward of %s's note re: %s"
 416                    (vm-su-full-name (car vm-message-pointer))
 417                    (vm-su-subject (car vm-message-pointer)))
 418            nil
 419            (and vm-forwarding-subject-format
 420                 (let ((vm-summary-uninteresting-senders nil))
 421                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 422           (make-local-variable 'vm-forward-list)
 423           (setq vm-system-state 'forwarding
 424                 vm-forward-list (list (car mp))
 425                 default-directory dir)
 426           (goto-char (point-min))
 427           (re-search-forward
 428            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 429           (tm-vm/enclose-messages vm-forward-list)
 430           (mail-position-on-field "To"))
 431         ;; (run-hooks 'tm-vm/forward-message-hook) ; Is it necessary?
 432         (run-hooks 'vm-mail-mode-hook)))))
 433
 434 (defun tm-vm/send-digest (&optional prefix)
 435   "Send a digest of all messages in the current folder to recipients.
 436 The type of the digest is specified by the variable vm-digest-send-type.
 437 You will be placed in a Mail mode buffer as is usual with replies, but you
 438 must fill in the To: and Subject: headers manually.
 439
 440 If invoked on marked messages (via vm-next-command-uses-marks),
 441 only marked messages will be put into the digest."
 442   (interactive "P")
 443   (if (not (equal vm-digest-send-type "rfc1521"))
 444       (vm-send-digest prefix)
 445     (vm-select-folder-buffer)
 446     (vm-check-for-killed-summary)
 447     (vm-error-if-folder-empty)
 448     (let ((dir default-directory)
 449           (mp vm-message-pointer)
 450           (mlist (if (eq last-command 'vm-next-command-uses-marks)
 451                      (vm-select-marked-or-prefixed-messages 0)
 452                    vm-message-list))
 453           start)
 454       (save-restriction
 455         (widen)
 456         (vm-mail-internal (format "digest from %s" (buffer-name)))
 457         (setq vm-system-state 'forwarding
 458               vm-forward-list mlist
 459               default-directory dir)
 460         (goto-char (point-min))
 461         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 462                                    "\n"))
 463         (goto-char (match-end 0))
 464         (setq start (point)
 465               mp mlist)
 466         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 467         (tm-vm/enclose-messages mlist)
 468         (goto-char start)
 469         (setq mp mlist)
 470         (if prefix
 471           (progn
 472             (mime-editor/insert-tag "text" "plain")
 473             (vm-unsaved-message "Building digest preamble...")
 474             (while mp
 475               (let ((vm-summary-uninteresting-senders nil))
 476                 (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 477               (if vm-digest-center-preamble
 478                   (progn
 479                     (forward-char -1)
 480                     (center-line)
 481                     (forward-char 1)))
 482               (setq mp (cdr mp)))))
 483         (mail-position-on-field "To")
 484         (message "Building %s digest... done" vm-digest-send-type)))
 485     ;; (run-hooks 'tm-vm/send-digest-hook) ; Is it necessary?
 486     (run-hooks 'vm-mail-mode-hook)))
 487
 488
 489 ;;; @@ setting
 490 ;;;
 491
 492 (substitute-key-definition 'vm-forward-message
 493                            'tm-vm/forward-message vm-mode-map)
 494 (substitute-key-definition 'vm-send-digest
 495                            'tm-vm/send-digest vm-mode-map)
 496
 497 (call-after-loaded
 498  'tm-edit
 499  (function
 500   (lambda ()
 501     (set-alist 'mime-editor/message-inserter-alist
 502                'mail-mode (function tm-vm/insert-message))
 503     )))
 504
 505 (call-after-loaded
 506  'mime-setup
 507  (function
 508   (lambda ()
 509     (remove-hook 'mail-mode-hook 'mime/editor-mode)
 510     (add-hook 'vm-mail-mode-hook 'mime/editor-mode)
 511     (setq vm-forwarding-digest-type "rfc1521")
 512     (setq vm-digest-send-type "rfc1521")
 513     )))
 514
 515
 516 ;;; @ end
 517 ;;;
 518
 519 (provide 'tm-vm)