tm-vm.el

   1 ;;;
   2 ;;; tm-vm.el --- tm-MUA for VM
   3 ;;;
   4 ;;; Copyright (C) 1994 MASUTANI Yasuhiro
   5 ;;; Copyright (C) 1995 WAKAMIYA Kenji
   6 ;;; Copyright (C) 1995,1996 KOBAYASHI Shuhei
   7 ;;; Copyright (C) 1996 Oscar Figueiredo
   8 ;;;
   9 ;;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
  10 ;;;         Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
  11 ;;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
  12 ;;;         KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
  13 ;;;         Oscar Figueiredo <figueire@lspsun2.epfl.ch>
  14 ;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
  15 ;;;             ISHIHARA Akito <aki@bpel.tutics.tut.ac.jp>
  16 ;;;             Rob Kooper <kooper@cc.gatech.edu>
  17 ;;; Maintainer: KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
  18 ;;; Created: 1994/10/29
  19 ;;; Version: $Revision: 7.53 $
  20 ;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
  21 ;;;
  22 ;;; This file is part of tm (Tools for MIME).
  23 ;;;
  24 ;;; This program is free software; you can redistribute it and/or
  25 ;;; modify it under the terms of the GNU General Public License as
  26 ;;; published by the Free Software Foundation; either version 2, or
  27 ;;; (at your option) any later version.
  28 ;;;
  29 ;;; This program is distributed in the hope that it will be useful,
  30 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  31 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  32 ;;; General Public License for more details.
  33 ;;;
  34 ;;; You should have received a copy of the GNU General Public License
  35 ;;; along with This program.  If not, write to the Free Software
  36 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  37 ;;;
  38 ;;; Commentary:
  39 ;;;
  40 ;;; Plese insert `(require 'tm-vm)' in your ~/.vm file.
  41 ;;;
  42 ;;; Code:
  43
  44 (require 'tm-view)
  45 (require 'vm)
  46
  47 (defconst tm-vm/RCS-ID
  48   "$Id: tm-vm.el,v 7.53 1996/05/23 16:51:04 shuhei-k Exp $")
  49 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
  50
  51 (define-key vm-mode-map "Z" 'tm-vm/view-message)
  52 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
  53 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
  54
  55 (defvar tm-vm/use-original-url-button nil
  56   "*If it is t, use original URL button instead of tm's.")
  57
  58 (defvar tm-vm-load-hook nil
  59   "*List of functions called after tm-vm is loaded.")
  60
  61
  62 ;;; @ for MIME encoded-words
  63 ;;;
  64
  65 (defvar tm-vm/use-tm-patch nil
  66   "Does not decode encoded-words in summary buffer if it is t.
  67 If you use tiny-mime patch for VM (by RIKITAKE Kenji
  68 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  69
  70 (or tm-vm/use-tm-patch
  71     (progn
  72 ;;;
  73 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
  74 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
  75
  76 (defun tm-vm/default-chop-full-name (address)
  77   (let* ((ret (vm-default-chop-full-name address))
  78          (full-name (car ret))
  79          )
  80     (if (stringp full-name)
  81         (cons (mime-eword/decode-string full-name)
  82               (cdr ret))
  83       ret)))
  84
  85 (require 'vm-summary)
  86 (or (fboundp 'tm:vm-su-subject)
  87     (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
  88     )
  89 (defun vm-su-subject (m)
  90   (mime-eword/decode-string (tm:vm-su-subject m))
  91   )
  92
  93 (or (fboundp 'tm:vm-su-full-name)
  94     (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name))
  95     )
  96 (defun vm-su-full-name (m)
  97   (mime-eword/decode-string (tm:vm-su-full-name m))
  98   )
  99
 100 (or (fboundp 'tm:vm-su-to-names)
 101     (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names))
 102     )
 103 (defun vm-su-to-names (m)
 104   (mime-eword/decode-string (tm:vm-su-to-names m))
 105   )
 106 ;;;
 107 ))
 108
 109 (defun tm-vm/decode-message-header (&optional count)
 110   "Decode MIME header of current message.
 111 Numeric prefix argument COUNT means to decode the current message plus
 112 the next COUNT-1 messages.  A negative COUNT means decode the current
 113 message and the previous COUNT-1 messages.
 114 When invoked on marked messages (via vm-next-command-uses-marks),
 115 all marked messages are affected, other messages are ignored."
 116   (interactive "p")
 117   (or count (setq count 1))
 118   (vm-follow-summary-cursor)
 119   (vm-select-folder-buffer)
 120   (vm-check-for-killed-summary)
 121   (vm-error-if-folder-empty)
 122   (vm-error-if-folder-read-only)
 123   (let ((mlist (vm-select-marked-or-prefixed-messages count))
 124         (realm nil)
 125         (vlist nil)
 126         (vbufs nil))
 127     (save-excursion
 128       (while mlist
 129         (setq realm (vm-real-message-of (car mlist)))
 130         ;; Go to real folder of this message.
 131         ;; But maybe this message is already real message...
 132         (set-buffer (vm-buffer-of realm))
 133         (let ((buffer-read-only nil))
 134           (vm-save-restriction
 135            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
 136            (mime/decode-message-header))
 137           (let ((vm-message-pointer (list realm))
 138                 (last-command nil))
 139             (vm-discard-cached-data))
 140           ;; Mark each virtual and real message for later summary
 141           ;; update.
 142           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 143           (while vlist
 144             (vm-mark-for-summary-update (car vlist))
 145             ;; Remember virtual and real folders related this message,
 146             ;; for later display update.
 147             (or (memq (vm-buffer-of (car vlist)) vbufs)
 148                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 149             (setq vlist (cdr vlist)))
 150           (if (eq vm-flush-interval t)
 151               (vm-stuff-virtual-attributes realm)
 152             (vm-set-modflag-of realm t)))
 153         (setq mlist (cdr mlist)))
 154       ;; Update mail-buffers and summaries.
 155       (while vbufs
 156         (set-buffer (car vbufs))
 157         (vm-preview-current-message)
 158         (setq vbufs (cdr vbufs))))))
 159
 160 \f
 161 ;;; @ automatic MIME preview
 162 ;;;
 163
 164 (defvar tm-vm/automatic-mime-preview t
 165   "*If non-nil, show MIME processed article.")
 166
 167 (defvar tm-vm/strict-mime t
 168   "*If nil, do MIME processing even if there is not MIME-Version field.")
 169
 170 (defvar tm-vm/select-message-hook nil
 171   "*List of functions called every time a message is selected.
 172 tm-vm uses `vm-select-message-hook', use this hook instead.")
 173
 174 (defvar tm-vm/system-state nil)
 175 (defun tm-vm/system-state ()
 176   (save-excursion
 177     (if mime::preview/article-buffer
 178         (set-buffer mime::preview/article-buffer)
 179       (vm-select-folder-buffer))
 180     tm-vm/system-state))
 181
 182 (defun tm-vm/display-preview-buffer ()
 183   (let* ((mbuf (current-buffer))
 184          (mwin (vm-get-visible-buffer-window mbuf))
 185          (pbuf (and mime::article/preview-buffer
 186                     (get-buffer mime::article/preview-buffer)))
 187          (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
 188     (if (and pbuf (tm-vm/system-state))
 189         ;; display preview buffer
 190         (cond
 191          ((and mwin pwin)
 192           (vm-undisplay-buffer mbuf)
 193           (tm-vm/show-current-message))
 194          ((and mwin (not pwin))
 195           (set-window-buffer mwin pbuf)
 196           (tm-vm/show-current-message))
 197          (pwin
 198           (tm-vm/show-current-message))
 199          (t
 200           ;; don't display if neither mwin nor pwin was displayed before.
 201           ))
 202       ;; display folder buffer
 203       (cond
 204        ((and mwin pwin)
 205         (vm-undisplay-buffer pbuf))
 206        ((and (not mwin) pwin)
 207         (set-window-buffer pwin mbuf))
 208        (mwin
 209         ;; folder buffer is already displayed.
 210         )
 211        (t
 212         ;; don't display if neither mwin nor pwin was displayed before.
 213         )))
 214     (set-buffer mbuf)))
 215
 216 (defun tm-vm/preview-current-message ()
 217   ;; assumed current buffer is folder buffer.
 218   (setq tm-vm/system-state nil)
 219   (if (get-buffer mime/output-buffer-name)
 220       (vm-undisplay-buffer mime/output-buffer-name))
 221   (if (and vm-message-pointer tm-vm/automatic-mime-preview)
 222       (if (or (not tm-vm/strict-mime)
 223               (vm-get-header-contents (car vm-message-pointer)
 224                                       "MIME-Version:"))
 225           ;; do MIME processiong.
 226           (progn
 227             (set (make-local-variable 'tm-vm/system-state) 'previewing)
 228             (save-window-excursion
 229               (vm-widen-page)
 230               (goto-char (point-max))
 231               (widen)
 232               (narrow-to-region (point)
 233                                 (save-excursion
 234                                   (goto-char
 235                                    (vm-start-of (car vm-message-pointer))
 236                                    )
 237                                   (forward-line)
 238                                   (point)
 239                                   ))
 240               (mime/viewer-mode)
 241               (if (and tm-vm/use-original-url-button
 242                        vm-use-menus (vm-menu-support-possible-p))
 243                   (vm-energize-urls))
 244               ;; 1996/2/16, fixed by
 245               ;;    Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 246               ;; Highlight message (and display XFace if supported)
 247               (if (or vm-highlighted-header-regexp
 248                       (and (vm-xemacs-p) vm-use-lucid-highlighting))
 249                   (vm-highlight-headers))
 250               ;;
 251               (goto-char (point-min))
 252               (narrow-to-region (point) (search-forward "\n\n" nil t))
 253               ))
 254         ;; don't do MIME processing. decode header only.
 255         (let (buffer-read-only)
 256           (mime/decode-message-header))
 257         )
 258     ;; don't preview; do nothing.
 259     )
 260   (tm-vm/display-preview-buffer)
 261   (run-hooks 'tm-vm/select-message-hook))
 262
 263 (defun tm-vm/show-current-message ()
 264   (if mime::preview/article-buffer
 265       (set-buffer mime::preview/article-buffer)
 266     (vm-select-folder-buffer))
 267   ;; Now current buffer is folder buffer.
 268   (if (or t ; mime/viewer-mode doesn't support narrowing yet.
 269           (null vm-preview-lines)
 270           (and (not vm-preview-read-messages)
 271                (not (vm-new-flag
 272                      (car vm-message-pointer)))
 273                (not (vm-unread-flag
 274                      (car vm-message-pointer)))))
 275       (save-excursion
 276         (set-buffer mime::article/preview-buffer)
 277         (save-excursion
 278           (save-excursion
 279             (goto-char (point-min))
 280             (widen))
 281           ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
 282           )))
 283   (if (vm-get-visible-buffer-window mime::article/preview-buffer)
 284       (progn
 285         (setq tm-vm/system-state 'reading)
 286         (if (vm-new-flag (car vm-message-pointer))
 287             (vm-set-new-flag (car vm-message-pointer) nil))
 288         (if (vm-unread-flag (car vm-message-pointer))
 289             (vm-set-unread-flag (car vm-message-pointer) nil))
 290         (vm-update-summary-and-mode-line)
 291         (tm-vm/howl-if-eom))
 292     (vm-update-summary-and-mode-line)))
 293
 294 (defun tm-vm/toggle-preview-mode ()
 295   (interactive)
 296   (vm-select-folder-buffer)
 297   (vm-display (current-buffer) t (list this-command)
 298               (list this-command 'reading-message))
 299   (if tm-vm/automatic-mime-preview
 300       (setq tm-vm/automatic-mime-preview nil
 301             tm-vm/system-state nil)
 302     (setq tm-vm/automatic-mime-preview t
 303           tm-vm/system-state nil)
 304     (save-restriction
 305        (vm-widen-page)
 306        (let* ((mp (car vm-message-pointer))
 307               (exposed (= (point-min) (vm-start-of mp))))
 308          (if (or (not tm-vm/strict-mime)
 309                  (vm-get-header-contents mp "MIME-Version:"))
 310              ;; do MIME processiong.
 311              (progn
 312                (set (make-local-variable 'tm-vm/system-state) 'previewing)
 313                (save-window-excursion
 314                  (mime/viewer-mode)
 315                  (goto-char (point-min))
 316                  (narrow-to-region (point)
 317                                    (search-forward "\n\n" nil t))
 318                  ))
 319            ;; don't do MIME processing. decode header only.
 320            (let (buffer-read-only)
 321              (mime/decode-message-header))
 322            )
 323          ;; don't preview; do nothing.
 324          ))
 325     (tm-vm/display-preview-buffer)
 326     ))
 327
 328 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 329 (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
 330 \f
 331 ;;; tm-vm move commands
 332 ;;;
 333
 334 (defmacro tm-vm/save-window-excursion (&rest forms)
 335   (list 'let '((tm-vm/selected-window (selected-window)))
 336         (list 'unwind-protect
 337               (cons 'progn forms)
 338               '(if (window-live-p tm-vm/selected-window)
 339                    (select-window tm-vm/selected-window)))))
 340
 341 ;;; based on vm-scroll-forward [vm-page.el]
 342 (defun tm-vm/scroll-forward (&optional arg)
 343   (interactive "P")
 344   (let ((this-command 'vm-scroll-forward))
 345     (if (not (tm-vm/system-state))
 346         (vm-scroll-forward arg)
 347       (let* ((mp-changed (vm-follow-summary-cursor))
 348              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 349              (mwin (vm-get-buffer-window mbuf))
 350              (pbuf (and mime::article/preview-buffer
 351                         (get-buffer mime::article/preview-buffer)))
 352              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 353              (was-invisible (and (null mwin) (null pwin)))
 354              )
 355         ;; now current buffer is folder buffer.
 356         (tm-vm/save-window-excursion
 357          (if (or mp-changed was-invisible)
 358              (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 359                          (list this-command 'reading-message)))
 360          (tm-vm/display-preview-buffer)
 361          (setq mwin (vm-get-buffer-window mbuf)
 362                pwin (and pbuf (vm-get-buffer-window pbuf)))
 363          (cond
 364           ((or mp-changed was-invisible)
 365            nil
 366            )
 367           ((null pbuf)
 368            ;; preview buffer is killed.
 369            (tm-vm/preview-current-message)
 370            (vm-update-summary-and-mode-line))
 371           ((eq (tm-vm/system-state) 'previewing)
 372            (tm-vm/show-current-message))
 373           (t
 374            (select-window pwin)
 375            (set-buffer pbuf)
 376            (if (pos-visible-in-window-p (point-max) pwin)
 377                (tm-vm/next-message)
 378              ;; not end of message. scroll preview buffer only.
 379              (scroll-up)
 380              (tm-vm/howl-if-eom)
 381              (set-buffer mbuf))
 382            ))))
 383       )))
 384
 385 ;;; based on vm-scroll-backward [vm-page.el]
 386 (defun tm-vm/scroll-backward (&optional arg)
 387   (interactive "P")
 388   (let ((this-command 'vm-scroll-backward))
 389     (if (not (tm-vm/system-state))
 390         (vm-scroll-backward arg)
 391       (let* ((mp-changed (vm-follow-summary-cursor))
 392              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 393              (mwin (vm-get-buffer-window mbuf))
 394              (pbuf (and mime::article/preview-buffer
 395                         (get-buffer mime::article/preview-buffer)))
 396              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 397              (was-invisible (and (null mwin) (null pwin)))
 398              )
 399         ;; now current buffer is folder buffer.
 400         (if (or mp-changed was-invisible)
 401             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 402                         (list this-command 'reading-message)))
 403         (tm-vm/save-window-excursion
 404          (tm-vm/display-preview-buffer)
 405          (setq mwin (vm-get-buffer-window mbuf)
 406                pwin (and pbuf (vm-get-buffer-window pbuf)))
 407          (cond
 408           (was-invisible
 409            nil
 410            )
 411           ((null pbuf)
 412            ;; preview buffer is killed.
 413            (tm-vm/preview-current-message)
 414            (vm-update-summary-and-mode-line))
 415           ((eq (tm-vm/system-state) 'previewing)
 416            (tm-vm/show-current-message))
 417           (t
 418            (select-window pwin)
 419            (set-buffer pbuf)
 420            (if (pos-visible-in-window-p (point-min) pwin)
 421                nil
 422              ;; scroll preview buffer only.
 423              (scroll-down)
 424              (set-buffer mbuf))
 425            ))))
 426       )))
 427
 428 ;;; based on vm-beginning-of-message [vm-page.el]
 429 (defun tm-vm/beginning-of-message ()
 430   "Moves to the beginning of the current message."
 431   (interactive)
 432   (if (not (tm-vm/system-state))
 433       (progn
 434         (setq this-command 'vm-beginning-of-message)
 435         (vm-beginning-of-message))
 436     (vm-follow-summary-cursor)
 437     (vm-select-folder-buffer)
 438     (vm-check-for-killed-summary)
 439     (vm-error-if-folder-empty)
 440     (let ((mbuf (current-buffer))
 441           (pbuf (and mime::article/preview-buffer
 442                      (get-buffer mime::article/preview-buffer))))
 443       (if (null pbuf)
 444           (progn
 445             (tm-vm/preview-current-message)
 446             (setq pbuf (get-buffer mime::article/preview-buffer))
 447             ))
 448       (vm-display mbuf t '(vm-beginning-of-message)
 449                   '(vm-beginning-of-message reading-message))
 450       (tm-vm/display-preview-buffer)
 451       (set-buffer pbuf)
 452       (tm-vm/save-window-excursion
 453        (select-window (vm-get-buffer-window pbuf))
 454        (push-mark)
 455        (goto-char (point-min))
 456        ))))
 457
 458 ;;; based on vm-end-of-message [vm-page.el]
 459 (defun tm-vm/end-of-message ()
 460   "Moves to the end of the current message."
 461   (interactive)
 462   (if (not (tm-vm/system-state))
 463       (progn
 464         (setq this-command 'vm-end-of-message)
 465         (vm-end-of-message))
 466     (vm-follow-summary-cursor)
 467     (vm-select-folder-buffer)
 468     (vm-check-for-killed-summary)
 469     (vm-error-if-folder-empty)
 470     (let ((mbuf (current-buffer))
 471           (pbuf (and mime::article/preview-buffer
 472                      (get-buffer mime::article/preview-buffer))))
 473       (if (null pbuf)
 474           (progn
 475             (tm-vm/preview-current-message)
 476             (setq pbuf (get-buffer mime::article/preview-buffer))
 477             ))
 478       (vm-display mbuf t '(vm-end-of-message)
 479                   '(vm-end-of-message reading-message))
 480       (tm-vm/display-preview-buffer)
 481       (set-buffer pbuf)
 482       (tm-vm/save-window-excursion
 483        (select-window (vm-get-buffer-window pbuf))
 484        (push-mark)
 485        (goto-char (point-max))
 486        ))))
 487
 488 ;;; based on vm-howl-if-eom [vm-page.el]
 489 (defun tm-vm/howl-if-eom ()
 490   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
 491          (pwin (and (vm-get-visible-buffer-window pbuf))))
 492     (and pwin
 493          (save-excursion
 494            (save-window-excursion
 495              (condition-case ()
 496                  (let ((next-screen-context-lines 0))
 497                    (select-window pwin)
 498                    (save-excursion
 499                      (save-window-excursion
 500                        (let ((scroll-in-place-replace-original nil))
 501                          (scroll-up))))
 502                    nil)
 503                (error t))))
 504          (tm-vm/emit-eom-blurb)
 505          )))
 506
 507 ;;; based on vm-emit-eom-blurb [vm-page.el]
 508 (defun tm-vm/emit-eom-blurb ()
 509   (save-excursion
 510     (if mime::preview/article-buffer
 511         (set-buffer mime::preview/article-buffer))
 512     (vm-emit-eom-blurb)))
 513
 514 ;;; based on vm-quit [vm-folder.el]
 515 (defun tm-vm/quit ()
 516   (interactive)
 517   (save-excursion
 518     (vm-select-folder-buffer)
 519     (if (and mime::article/preview-buffer
 520              (get-buffer mime::article/preview-buffer))
 521         (kill-buffer mime::article/preview-buffer)))
 522   (vm-quit))
 523
 524 (substitute-key-definition 'vm-scroll-forward
 525                            'tm-vm/scroll-forward vm-mode-map)
 526 (substitute-key-definition 'vm-scroll-backward
 527                            'tm-vm/scroll-backward vm-mode-map)
 528 (substitute-key-definition 'vm-beginning-of-message
 529                            'tm-vm/beginning-of-message vm-mode-map)
 530 (substitute-key-definition 'vm-end-of-message
 531                            'tm-vm/end-of-message vm-mode-map)
 532 (substitute-key-definition 'vm-quit
 533                            'tm-vm/quit vm-mode-map)
 534
 535 ;;; based on vm-next-message [vm-motion.el]
 536 (defun tm-vm/next-message ()
 537   (set-buffer mime::preview/article-buffer)
 538   (let ((this-command 'vm-next-message)
 539         (owin (selected-window))
 540         (vm-preview-lines nil)
 541         )
 542     (vm-next-message 1 nil t)
 543     (if (window-live-p owin)
 544         (select-window owin))))
 545
 546 ;;; based on vm-previous-message [vm-motion.el]
 547 (defun tm-vm/previous-message ()
 548   (set-buffer mime::preview/article-buffer)
 549   (let ((this-command 'vm-previous-message)
 550         (owin (selected-window))
 551         (vm-preview-lines nil)
 552         )
 553     (vm-previous-message 1 nil t)
 554     (if (window-live-p owin)
 555         (select-window owin))))
 556
 557 (set-alist 'mime-viewer/over-to-previous-method-alist
 558            'vm-mode 'tm-vm/previous-message)
 559 (set-alist 'mime-viewer/over-to-next-method-alist
 560            'vm-mode 'tm-vm/next-message)
 561 (set-alist 'mime-viewer/over-to-previous-method-alist
 562            'vm-virtual-mode 'tm-vm/previous-message)
 563 (set-alist 'mime-viewer/over-to-next-method-alist
 564            'vm-virtual-mode 'tm-vm/next-message)
 565
 566 ;;; @@ vm-yank-message
 567 ;;;
 568 ;; 1996/3/28 by Oscar Figueiredo <figueire@lspsun16.epfl.ch>
 569
 570 (require 'vm-reply)
 571
 572 (defun vm-yank-message (&optional message)
 573   "Yank message number N into the current buffer at point.
 574 When called interactively N is always read from the minibuffer.  When
 575 called non-interactively the first argument is expected to be a
 576 message struct.
 577
 578 This function originally provided by vm-reply has been patched for TM in
 579 order to provide better citation of MIME messages : if a MIME Preview
 580 buffer is displayed for the message then its contents are inserted
 581 instead of the raw message.
 582
 583 This command is meant to be used in VM created Mail mode buffers; the
 584 yanked message comes from the mail buffer containing the message you
 585 are replying to, forwarding, or invoked VM's mail command from.
 586
 587 All message headers are yanked along with the text.  Point is
 588 left before the inserted text, the mark after.  Any hook
 589 functions bound to mail-citation-hook are run, after inserting
 590 the text and setting point and mark.  For backward compatibility,
 591 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
 592 instead.
 593
 594 If mail-citation-hook and mail-yank-hooks are both nil, this
 595 default action is taken: the yanked headers are trimmed as
 596 specified by vm-included-text-headers and
 597 vm-included-text-discard-header-regexp, and the value of
 598 vm-included-text-prefix is prepended to every yanked line."
 599   (interactive
 600    (list
 601     ;; What we really want for the first argument is a message struct,
 602     ;; but if called interactively, we let the user type in a message
 603     ;; number instead.
 604     (let (mp default
 605              (result 0)
 606              prompt
 607              (last-command last-command)
 608              (this-command this-command))
 609       (if (bufferp vm-mail-buffer)
 610           (save-excursion
 611             (vm-select-folder-buffer)
 612             (setq default (and vm-message-pointer
 613                                (vm-number-of (car vm-message-pointer)))
 614                   prompt (if default
 615                              (format "Yank message number: (default %s) "
 616                                      default)
 617                            "Yank message number: "))
 618             (while (zerop result)
 619               (setq result (read-string prompt))
 620               (and (string= result "") default (setq result default))
 621               (setq result (string-to-int result)))
 622             (if (null (setq mp (nthcdr (1- result) vm-message-list)))
 623                 (error "No such message."))
 624             (car mp))
 625         nil))))
 626   (if (null message)
 627       (if mail-reply-buffer
 628           (tm-vm/yank-content)
 629         (error "This is not a VM Mail mode buffer."))
 630     (if (null (buffer-name vm-mail-buffer))
 631         (error "The folder buffer containing message %d has been killed."
 632                (vm-number-of message)))
 633     (vm-display nil nil '(vm-yank-message)
 634                 '(vm-yank-message composing-message))
 635     (setq message (vm-real-message-of message))
 636     (let ((b (current-buffer)) (start (point)) end)
 637       (save-restriction
 638         (widen)
 639         (save-excursion
 640           (set-buffer (vm-buffer-of message))
 641           (let* ((mbuf (current-buffer))
 642                  (pbuf (and mime::article/preview-buffer
 643                             (get-buffer mime::article/preview-buffer)))
 644                  (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
 645             (if pwin
 646                 (if running-xemacs
 647                     (let ((tmp (generate-new-buffer "tm-vm/tmp")))
 648                       (set-buffer pbuf)
 649                       (append-to-buffer tmp (point-min) (point-max))
 650                       (set-buffer tmp)
 651                       (map-extents
 652                        '(lambda (ext maparg)
 653                           (set-extent-property ext 'begin-glyph nil)))
 654                       (append-to-buffer b (point-min) (point-max))
 655                       (setq end (vm-marker
 656                                  (+ start (length (buffer-string))) b))
 657                       (kill-buffer tmp))
 658                   (set-buffer pbuf)
 659                   (append-to-buffer b (point-min) (point-max))
 660                   (setq end (vm-marker
 661                              (+ start (length (buffer-string))) b)))
 662               (save-restriction
 663                 (widen)
 664                 (append-to-buffer
 665                  b (vm-headers-of message) (vm-text-end-of message))
 666                 (setq end
 667                       (vm-marker (+ start (- (vm-text-end-of message)
 668                                              (vm-headers-of message))) b))))))
 669         (push-mark end)
 670         (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 671               (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 672               (t (vm-mail-yank-default message)))
 673         ))
 674     ))
 675
 676 \f
 677 ;;; @ for tm-view
 678 ;;;
 679
 680 ;;; based on vm-do-reply [vm-reply.el]
 681 (defun tm-vm/do-reply (buf to-all include-text)
 682   (save-excursion
 683     (set-buffer buf)
 684     (let ((dir default-directory)
 685           to cc subject mp in-reply-to references newsgroups)
 686       (cond ((setq to
 687                    (let ((reply-to (rfc822/get-field-body "Reply-To")))
 688                      (if (vm-ignored-reply-to reply-to)
 689                          nil
 690                        reply-to))))
 691             ((setq to (rfc822/get-field-body "From")))
 692             ;; (t (error "No From: or Reply-To: header in message"))
 693             )
 694       (if to-all
 695           (setq cc (delq nil (cons cc (rfc822/get-field-bodies '("To" "Cc"))))
 696                 cc (mapconcat 'identity cc ","))
 697         )
 698       (setq subject (rfc822/get-field-body "Subject"))
 699       (and subject vm-reply-subject-prefix
 700            (let ((case-fold-search t))
 701              (not
 702               (equal
 703                (string-match (regexp-quote vm-reply-subject-prefix)
 704                              subject)
 705                0)))
 706            (setq subject (concat vm-reply-subject-prefix subject)))
 707       (setq in-reply-to (rfc822/get-field-body "Message-Id")
 708             references (nconc
 709                         (rfc822/get-field-bodies '("References" "In-Reply-To"))
 710                         (list in-reply-to))
 711             newsgroups (list (or (and to-all
 712                                       (rfc822/get-field-body "Followup-To"))
 713                                  (rfc822/get-field-body "Newsgroups"))))
 714       (setq to (vm-parse-addresses to)
 715             cc (vm-parse-addresses cc))
 716       (if vm-reply-ignored-addresses
 717           (setq to (vm-strip-ignored-addresses to)
 718                 cc (vm-strip-ignored-addresses cc)))
 719       (setq to (vm-delete-duplicates to nil t))
 720       (setq cc (vm-delete-duplicates
 721                 (append (vm-delete-duplicates cc nil t)
 722                         to (copy-sequence to))
 723                 t t))
 724       (and to (setq to (mapconcat 'identity to ",\n ")))
 725       (and cc (setq cc (mapconcat 'identity cc ",\n ")))
 726       (and (null to) (setq to cc cc nil))
 727       (setq references (delq nil references)
 728             references (mapconcat 'identity references " ")
 729             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
 730             references (vm-delete-duplicates references)
 731             references (if references (mapconcat 'identity references "\n\t")))
 732       (setq newsgroups (delq nil newsgroups)
 733             newsgroups (mapconcat 'identity newsgroups ",")
 734             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 735             newsgroups (vm-delete-duplicates newsgroups)
 736             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 737       (vm-mail-internal
 738        (if to
 739            (format "reply to %s%s"
 740                    (rfc822/full-name-string
 741                     (car (rfc822/parse-address
 742                           (rfc822/lexical-analyze to))))
 743                    (if cc ", ..." "")))
 744        to subject in-reply-to cc references newsgroups)
 745       (setq mail-reply-buffer buf
 746             ;; vm-system-state 'replying
 747             default-directory dir))
 748     (if include-text
 749         (save-excursion
 750           (goto-char (point-min))
 751           (let ((case-fold-search nil))
 752             (re-search-forward
 753              (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
 754           (forward-char 1)
 755           (tm-vm/yank-content)))
 756     (run-hooks 'vm-reply-hook)
 757     (run-hooks 'vm-mail-mode-hook)
 758     ))
 759
 760 (defun tm-vm/following-method (buf)
 761   (tm-vm/do-reply buf 'to-all 'include-text)
 762   )
 763
 764 (defun tm-vm/yank-content ()
 765   (interactive)
 766   (let ((this-command 'vm-yank-message))
 767     (vm-display nil nil '(vm-yank-message)
 768                 '(vm-yank-message composing-message))
 769     (save-restriction
 770       (narrow-to-region (point)(point))
 771       (insert-buffer mail-reply-buffer)
 772       (goto-char (point-max))
 773       (push-mark)
 774       (goto-char (point-min)))
 775     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 776           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 777           (t (mail-indent-citation)))
 778     ))
 779
 780 (set-alist 'mime-viewer/following-method-alist
 781            'vm-mode
 782            (function tm-vm/following-method))
 783 (set-alist 'mime-viewer/following-method-alist
 784            'vm-virtual-mode
 785            (function tm-vm/following-method))
 786
 787
 788 (defun tm-vm/quit-view-message ()
 789   "Quit MIME-viewer and go back to VM.
 790 This function is called by `mime-viewer/quit' command via
 791 `mime-viewer/quitting-method-alist'."
 792   (if (get-buffer mime/output-buffer-name)
 793       (vm-undisplay-buffer mime/output-buffer-name))
 794   (if (and tm-vm/automatic-mime-preview
 795            (save-excursion
 796              (set-buffer mime::preview/article-buffer)
 797              vm-summary-buffer))
 798       (switch-to-buffer mime::preview/article-buffer)
 799     (mime-viewer/kill-buffer)
 800     (vm-select-folder-buffer)
 801     (setq tm-vm/system-state nil))
 802   (vm-display (current-buffer) t (list this-command)
 803               (list this-command 'reading-message))
 804   (tm-vm/display-preview-buffer)
 805   )
 806
 807 (defun tm-vm/view-message ()
 808   "Decode and view MIME encoded message, under VM."
 809   (interactive)
 810   (vm-follow-summary-cursor)
 811   (vm-select-folder-buffer)
 812   (vm-check-for-killed-summary)
 813   (vm-error-if-folder-empty)
 814   (vm-display (current-buffer) t '(tm-vm/view-message)
 815               '(tm-vm/view-mesage reading-message))
 816   (let* ((mp (car vm-message-pointer))
 817          (ct  (vm-get-header-contents mp "Content-Type:"))
 818          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 819          (exposed (= (point-min) (vm-start-of mp))))
 820     (save-restriction
 821       (vm-widen-page)
 822       ;; vm-widen-page hides exposed header if pages are delimited.
 823       ;; So, here we expose it again.
 824       (if exposed
 825           (narrow-to-region (vm-start-of mp) (point-max)))
 826       (select-window (vm-get-buffer-window (current-buffer)))
 827       (mime/viewer-mode nil
 828                         (mime/parse-Content-Type (or ct ""))
 829                         cte)
 830       )))
 831
 832 (set-alist 'mime-viewer/quitting-method-alist
 833            'vm-mode
 834            'tm-vm/quit-view-message)
 835
 836 (set-alist 'mime-viewer/quitting-method-alist
 837            'vm-virtual-mode
 838            'tm-vm/quit-view-message)
 839
 840
 841 ;;; @ for tm-partial
 842 ;;;
 843
 844 (call-after-loaded
 845  'tm-partial
 846  (function
 847   (lambda ()
 848     (set-atype 'mime/content-decoding-condition
 849                '((type . "message/partial")
 850                  (method . mime-article/grab-message/partials)
 851                  (major-mode . vm-mode)
 852                  (summary-buffer-exp . vm-summary-buffer)
 853                  ))
 854     (set-alist 'tm-partial/preview-article-method-alist
 855                'vm-mode
 856                (function
 857                 (lambda ()
 858                   (tm-vm/view-message)
 859                   )))
 860     )))
 861
 862
 863 ;;; @ for tm-edit
 864 ;;;
 865
 866 ;;; @@ for multipart/digest
 867 ;;;
 868
 869 (defvar tm-vm/forward-message-hook nil
 870   "*List of functions called after a Mail mode buffer has been
 871 created to forward a message in message/rfc822 type format.
 872 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
 873 hook instead of `vm-forward-message-hook'.")
 874
 875 (defvar tm-vm/send-digest-hook nil
 876   "*List of functions called after a Mail mode buffer has been
 877 created to send a digest in multipart/digest type format.
 878 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
 879 instead of `vm-send-digest-hook'.")
 880
 881 (defun tm-vm/enclose-messages (mlist &optional preamble)
 882   "Enclose the messages in MLIST as multipart/digest.
 883 The resulting digest is inserted at point in the current buffer.
 884
 885 MLIST should be a list of message structs (real or virtual).
 886 These are the messages that will be enclosed."
 887   (if mlist
 888       (let ((digest (consp (cdr mlist)))
 889             (mp mlist)
 890             m)
 891         (save-restriction
 892           (narrow-to-region (point) (point))
 893           (while mlist
 894             (setq m (vm-real-message-of (car mlist)))
 895             (mime-editor/insert-tag "message" "rfc822")
 896             (tm-mail/insert-message m)
 897             (goto-char (point-max))
 898             (setq mlist (cdr mlist)))
 899           (if preamble
 900               (progn
 901                 (goto-char (point-min))
 902                 (mime-editor/insert-tag "text" "plain")
 903                 (vm-unsaved-message "Building digest preamble...")
 904                 (while mp
 905                   (let ((vm-summary-uninteresting-senders nil))
 906                     (insert
 907                      (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 908                   (if vm-digest-center-preamble
 909                       (progn
 910                         (forward-char -1)
 911                         (center-line)
 912                         (forward-char 1)))
 913                   (setq mp (cdr mp)))))
 914           (if digest
 915               (mime-editor/enclose-digest-region (point-min) (point-max)))
 916           ))))
 917
 918 (defun tm-vm/forward-message ()
 919   "Forward the current message to one or more recipients.
 920 You will be placed in a Mail mode buffer as you would with a
 921 reply, but you must fill in the To: header and perhaps the
 922 Subject: header manually."
 923   (interactive)
 924   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 925       (vm-forward-message)
 926     (vm-follow-summary-cursor)
 927     (vm-select-folder-buffer)
 928     (vm-check-for-killed-summary)
 929     (vm-error-if-folder-empty)
 930     (if (eq last-command 'vm-next-command-uses-marks)
 931         (let ((vm-digest-send-type vm-forwarding-digest-type))
 932           (setq this-command 'vm-next-command-uses-marks)
 933           (command-execute 'tm-vm/send-digest))
 934       (let ((dir default-directory)
 935             (mp vm-message-pointer))
 936         (save-restriction
 937           (widen)
 938           (vm-mail-internal
 939            (format "forward of %s's note re: %s"
 940                    (vm-su-full-name (car vm-message-pointer))
 941                    (vm-su-subject (car vm-message-pointer)))
 942            nil
 943            (and vm-forwarding-subject-format
 944                 (let ((vm-summary-uninteresting-senders nil))
 945                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 946           (make-local-variable 'vm-forward-list)
 947           (setq vm-system-state 'forwarding
 948                 vm-forward-list (list (car mp))
 949                 default-directory dir)
 950           (goto-char (point-min))
 951           (re-search-forward
 952            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 953           (tm-vm/enclose-messages vm-forward-list)
 954           (mail-position-on-field "To"))
 955         (run-hooks 'tm-vm/forward-message-hook)
 956         (run-hooks 'vm-mail-mode-hook)))))
 957
 958 (defun tm-vm/send-digest (&optional arg)
 959   "Send a digest of all messages in the current folder to recipients.
 960 The type of the digest is specified by the variable vm-digest-send-type.
 961 You will be placed in a Mail mode buffer as is usual with replies, but you
 962 must fill in the To: and Subject: headers manually.
 963
 964 If invoked on marked messages (via vm-next-command-uses-marks),
 965 only marked messages will be put into the digest."
 966   (interactive "P")
 967   (if (not (equal vm-digest-send-type "rfc1521"))
 968       (vm-send-digest arg)
 969     (vm-select-folder-buffer)
 970     (vm-check-for-killed-summary)
 971     (vm-error-if-folder-empty)
 972     (let ((dir default-directory)
 973           (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
 974                                (vm-select-marked-or-prefixed-messages 0)
 975                              vm-message-list))
 976           start)
 977       (save-restriction
 978         (widen)
 979         (vm-mail-internal (format "digest from %s" (buffer-name)))
 980         (setq vm-system-state 'forwarding
 981               default-directory dir)
 982         (goto-char (point-min))
 983         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 984                                    "\n"))
 985         (goto-char (match-end 0))
 986         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 987         (tm-vm/enclose-messages vm-forward-list arg)
 988         (mail-position-on-field "To")
 989         (message "Building %s digest... done" vm-digest-send-type)))
 990     (run-hooks 'tm-vm/send-digest-hook)
 991     (run-hooks 'vm-mail-mode-hook)))
 992
 993 (substitute-key-definition 'vm-forward-message
 994                            'tm-vm/forward-message vm-mode-map)
 995 (substitute-key-definition 'vm-send-digest
 996                            'tm-vm/send-digest vm-mode-map)
 997 \f
 998
 999 ;;; @@ setting
1000 ;;;
1001
1002 (defvar tm-vm/use-xemacs-popup-menu t)
1003
1004 ;;; modified by Steven L. Baur <steve@miranova.com>
1005 ;;;     1995/12/6 (c.f. [tm-en:209])
1006 (defun mime-editor/attach-to-vm-mode-menu ()
1007   "Arrange to attach MIME editor's popup menu to VM's"
1008   (if (boundp 'vm-menu-mail-menu)
1009       (progn
1010         (setq vm-menu-mail-menu
1011               (append vm-menu-mail-menu
1012                       (list "----"
1013                             mime-editor/popup-menu-for-xemacs)))
1014         (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1015         )))
1016
1017 (call-after-loaded
1018  'tm-edit
1019  (function
1020   (lambda ()
1021     (autoload 'tm-mail/insert-message "tm-mail")
1022     (set-alist 'mime-editor/message-inserter-alist
1023                'mail-mode (function tm-mail/insert-message))
1024     (if (and (string-match "XEmacs\\|Lucid" emacs-version)
1025              tm-vm/use-xemacs-popup-menu)
1026         (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1027       )
1028     )))
1029
1030 (call-after-loaded
1031  'mime-setup
1032  (function
1033   (lambda ()
1034     (setq vm-forwarding-digest-type "rfc1521")
1035     (setq vm-digest-send-type "rfc1521")
1036     )))
1037
1038
1039 ;;; @ for BBDB
1040 ;;;
1041
1042 (call-after-loaded
1043  'bbdb
1044  (function
1045   (lambda ()
1046     (require 'bbdb-vm)
1047     (require 'tm-bbdb)
1048     (or (fboundp 'tm:bbdb/vm-update-record)
1049         (fset 'tm:bbdb/vm-update-record
1050               (symbol-function 'bbdb/vm-update-record)))
1051     (defun bbdb/vm-update-record (&optional offer-to-create)
1052       (vm-select-folder-buffer)
1053       (if (and (tm-vm/system-state)
1054                mime::article/preview-buffer
1055                (get-buffer mime::article/preview-buffer))
1056           (tm-bbdb/update-record offer-to-create)
1057         (tm:bbdb/vm-update-record offer-to-create)
1058         ))
1059     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
1060     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
1061     (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
1062     )))
1063
1064
1065 ;;; @ end
1066 ;;;
1067
1068 (provide 'tm-vm)
1069
1070 (run-hooks 'tm-vm-load-hook)
1071
1072 ;;; tm-vm.el ends here.