gnus/tm-gnus4.el

   1 ;;;
   2 ;;; tm-gnus4.el --- tm-gnus module for GNUS 4, 5.0.* and 5.1.*.
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
   9 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  10 ;;;         and KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
  11 ;;; Created: 1993/11/20 (merged tm-gnus5.el)
  12 ;;; Version: $Revision: 7.20 $
  13 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
  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 ;;; Code:
  32
  33 (require 'tl-str)
  34 (require 'tl-misc)
  35
  36
  37 ;;; @ version
  38 ;;;
  39
  40 (defconst tm-gnus/RCS-ID
  41   "$Id: tm-gnus4.el,v 7.20 1996/06/09 06:53:41 morioka Exp $")
  42
  43 (defconst tm-gnus/version
  44   (concat (get-version-string tm-gnus/RCS-ID) " for 3.15 .. 5.1.*"))
  45
  46
  47 ;;; @ variable
  48 ;;;
  49
  50 (defvar tm-gnus/automatic-mime-preview t
  51   "*If non-nil, show MIME processed article.
  52 This variable is set to `gnus-show-mime'.")
  53
  54 (defvar tm-gnus/original-article-buffer " *Original Article*")
  55 (defvar gnus-original-article-buffer nil)
  56
  57
  58 ;;; @ for tm-view
  59 ;;;
  60
  61 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  62
  63 (defun tm-gnus/view-message (arg)
  64   "MIME decode and play this message."
  65   (interactive "P")
  66   (let ((gnus-break-pages nil)
  67         (gnus-show-mime nil))
  68     (gnus-summary-select-article t t)
  69     )
  70   (pop-to-buffer gnus-article-buffer t)
  71   (let ((str (buffer-string))
  72         (obuf (get-buffer tm-gnus/original-article-buffer))
  73         (pbuf (current-buffer))
  74         )
  75     (if obuf
  76         (progn
  77           (set-buffer obuf)
  78           (setq buffer-read-only nil)
  79           (erase-buffer)
  80           )
  81       (setq obuf (get-buffer-create tm-gnus/original-article-buffer))
  82       (set-buffer obuf)
  83       )
  84     (insert str)
  85     (gnus-article-mode)
  86     (set-buffer pbuf)
  87     (make-local-variable 'tm:mother-button-dispatcher)
  88     (setq tm:mother-button-dispatcher
  89           (function gnus-article-push-button))
  90     (mime/viewer-mode
  91      nil nil nil tm-gnus/original-article-buffer gnus-article-buffer)
  92     (let (buffer-read-only)
  93       (run-hooks 'tm-gnus/article-prepare-hook)
  94       )
  95     ))
  96
  97 (defun tm-gnus/summary-scroll-down ()
  98   "Scroll down one line current article."
  99   (interactive)
 100   (gnus-summary-scroll-up -1)
 101   )
 102
 103 (defun mime-viewer/quitting-method-for-gnus4 ()
 104   (if (not gnus-show-mime)
 105       (mime-viewer/kill-buffer)
 106     )
 107   (delete-other-windows)
 108   (gnus-article-show-summary)
 109   (if (or (not gnus-show-mime)
 110           (null gnus-have-all-headers))
 111       (gnus-summary-select-article nil t)
 112     ))
 113
 114 (call-after-loaded
 115  'tm-view
 116  (function
 117   (lambda ()
 118     (set-alist 'mime-viewer/quitting-method-alist
 119                'gnus-article-mode
 120                (function mime-viewer/quitting-method-for-gnus4))
 121     (set-alist 'mime-viewer/show-summary-method
 122                'gnus-article-mode
 123                (function mime-viewer/quitting-method-for-gnus4))
 124     )))
 125
 126
 127 ;;; @ for tm-edit
 128 ;;;
 129
 130 ;; suggested by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 131 ;;      1995/11/08 (c.f. [tm ML:1067])
 132 (defun tm-gnus/insert-article (&optional message)
 133   (interactive)
 134   (let (;; for Emacs 19
 135         (mail-citation-hook '(mime-editor/inserted-message-filter))
 136         news-reply-header-hook
 137         mail-yank-hooks
 138
 139         ;; for Emacs 18
 140         (mail-yank-ignored-headers mime-editor/yank-ignored-field-regexp)
 141         (news-make-reply-yank-header (function
 142                                       (lambda (message-id from) "")
 143                                       ))
 144         (news-yank-original-quoting-indicator "")
 145
 146         ;; select raw article buffer
 147         (mail-reply-buffer
 148          (save-excursion
 149            (set-buffer gnus-article-buffer)
 150            (if (eq major-mode 'mime/viewer-mode)
 151                mime::preview/article-buffer
 152              gnus-article-buffer)))
 153         )
 154     (news-reply-yank-original 0)
 155     ))
 156
 157 ;;; modified by Steven L. Baur <steve@miranova.com>
 158 ;;;     1995/12/6 (c.f. [tm-en:209])
 159 (defun mime-editor/attach-to-news-reply-menu ()
 160   "Arrange to attach MIME editor's popup menu to VM's"
 161   (if (boundp 'news-reply-menu)
 162       (progn
 163         (setq news-reply-menu (append news-reply-menu
 164                                       '("---")
 165                                       mime-editor/popup-menu-for-xemacs))
 166         (remove-hook 'news-setup-hook
 167                      'mime-editor/attach-to-news-reply-menu)
 168         )))
 169
 170 (call-after-loaded
 171  'tm-edit
 172  (function
 173   (lambda ()
 174     (set-alist 'mime-editor/message-inserter-alist
 175                'news-reply-mode (function tm-gnus/insert-article))
 176
 177     (autoload 'tm-mail/insert-message "tm-mail")
 178     (set-alist 'mime-editor/message-inserter-alist
 179                'mail-mode (function tm-mail/insert-message))
 180     (if (string-match "XEmacs\\|Lucid" emacs-version)
 181         (add-hook 'news-setup-hook 'mime-editor/attach-to-news-reply-menu)
 182       )
 183
 184     (set-alist 'mime-editor/split-message-sender-alist
 185                'news-reply-mode
 186                (function gnus-inews-news))
 187     )))
 188
 189
 190 ;;; @ for tm-partial
 191 ;;;
 192
 193 (call-after-loaded
 194  'tm-partial
 195  (function
 196   (lambda ()
 197     (set-atype 'mime/content-decoding-condition
 198                '((type . "message/partial")
 199                  (method . mime-article/grab-message/partials)
 200                  (major-mode . gnus-article-mode)
 201                  (summary-buffer-exp . gnus-summary-buffer)
 202                  ))
 203
 204     (set-alist 'tm-partial/preview-article-method-alist
 205                'gnus-article-mode
 206                (function
 207                 (lambda ()
 208                   (tm-gnus/view-message (gnus-summary-article-number))
 209                   )))
 210     )))
 211
 212
 213 ;;; @ set up
 214 ;;;
 215
 216 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
 217 (define-key gnus-summary-mode-map
 218   "\e\r" (function tm-gnus/summary-scroll-down))
 219
 220 (defun tm-gnus/article-reset-variable ()
 221   (setq gnus-original-article-buffer nil)
 222   (setq tm-gnus/automatic-mime-preview nil)
 223   (gnus-article-mode)
 224   (setq buffer-read-only nil)
 225   )
 226
 227 (add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable)
 228
 229 (defun tm-gnus/decode-encoded-word-if-you-need ()
 230   (if (not gnus-have-all-headers)
 231       (progn
 232         (mime/decode-message-header)
 233         (run-hooks 'tm-gnus/article-prepare-hook)
 234         )))
 235
 236 (defun tm-gnus/preview-article-if-you-need ()
 237   (if (not gnus-have-all-headers)
 238       (let ((str (buffer-string))
 239             (obuf (get-buffer tm-gnus/original-article-buffer))
 240             (pbuf (current-buffer))
 241             )
 242         (if obuf
 243             (progn
 244               (set-buffer obuf)
 245               (setq buffer-read-only nil)
 246               (erase-buffer)
 247               )
 248           (setq obuf (get-buffer-create tm-gnus/original-article-buffer))
 249           (set-buffer obuf)
 250           )
 251         (insert str)
 252         (gnus-article-mode)
 253         (set-buffer pbuf)
 254         (make-local-variable 'tm:mother-button-dispatcher)
 255         (setq tm:mother-button-dispatcher
 256               (function gnus-article-push-button))
 257         (save-window-excursion
 258           (mime/viewer-mode
 259            nil nil nil tm-gnus/original-article-buffer gnus-article-buffer)
 260           )
 261         (setq tm-gnus/automatic-mime-preview t)
 262         (setq gnus-original-article-buffer tm-gnus/original-article-buffer)
 263         (let (buffer-read-only)
 264           (run-hooks 'tm-gnus/article-prepare-hook)
 265           )
 266         (if (featurep 'tm-gd3)
 267             (setq buffer-read-only nil)
 268           )
 269         )))
 270
 271 (setq gnus-show-mime-method
 272       (if tm-gnus/automatic-mime-preview
 273           (function tm-gnus/preview-article-if-you-need)
 274         (function tm-gnus/decode-encoded-word-if-you-need)
 275         ))
 276
 277 (setq gnus-show-mime t)
 278
 279
 280 ;;; @ for BBDB
 281 ;;;
 282
 283 (call-after-loaded
 284  'bbdb
 285  (function
 286   (lambda ()
 287     (require 'tm-bbdb)
 288     )))
 289
 290 (autoload 'tm-bbdb/update-record "tm-bbdb")
 291
 292 (defun tm-gnus/bbdb-setup ()
 293   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 294       (progn
 295         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 296         ;;(add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 297         (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record)
 298         )))
 299
 300 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 301
 302 (tm-gnus/bbdb-setup)
 303
 304
 305 ;;; @ end
 306 ;;;
 307
 308 (provide 'tm-gnus4)
 309
 310 ;;; tm-gnus4.el ends here