gnus/tm-gnus3.el

   1 ;;;
   2 ;;; tm-gnus3.el --- tm-gnus module for GNUS 3.*
   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 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Created: 1993/11/20
  10 ;;; Version: $Revision: 7.4 $
  11 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
  12 ;;;
  13 ;;; This file is part of tm (Tools for MIME).
  14 ;;;
  15 ;;; This program is free software; you can redistribute it and/or
  16 ;;; modify it under the terms of the GNU General Public License as
  17 ;;; published by the Free Software Foundation; either version 2, or
  18 ;;; (at your option) any later version.
  19 ;;;
  20 ;;; This program is distributed in the hope that it will be useful,
  21 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 ;;; General Public License for more details.
  24 ;;;
  25 ;;; You should have received a copy of the GNU General Public License
  26 ;;; along with This program.  If not, write to the Free Software
  27 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  28 ;;;
  29 ;;; Code:
  30
  31 (require 'tl-list)
  32 (require 'tl-str)
  33 (require 'tl-misc)
  34 (require 'gnus)
  35 (require 'tm-gd3)
  36
  37 (autoload 'mime/decode-message-header
  38   "tm-ew-d" "Decode MIME encoded-words in message header." t)
  39 (autoload 'mime-eword/decode-string
  40   "tm-ew-d" "Decode MIME encoded-words in string." t)
  41
  42 (fset 'gnus-summary-select-article 'gnus-Subject-select-article)
  43
  44
  45 ;;; @ version
  46 ;;;
  47
  48 (defconst tm-gnus/RCS-ID
  49   "$Id: tm-gnus3.el,v 7.4 1996/01/23 04:53:43 morioka Exp $")
  50
  51 (defconst tm-gnus/version
  52   (concat (get-version-string tm-gnus/RCS-ID) " for GNUS 3"))
  53
  54
  55 ;;; @ variable
  56 ;;;
  57
  58 (defvar tm-gnus/decoding-mode t "*Decode MIME header if non-nil.")
  59
  60
  61 ;;; @ mode-line
  62 ;;;
  63
  64 (defun tm-gnus/add-decoding-mode-to-mode-line ()
  65   (or (assq 'tm-gnus/decoding-mode minor-mode-alist)
  66       (setq minor-mode-alist
  67             (cons (list 'tm-gnus/decoding-mode " MIME")
  68                   minor-mode-alist))
  69       ))
  70
  71 (if (not (string-match "^GNUS 3\.14\.4" gnus-version))
  72     (progn
  73       (add-hook 'gnus-Article-mode-hook
  74                 (function
  75                  (lambda ()
  76                    (make-local-variable 'minor-mode-alist)
  77                    (tm-gnus/add-decoding-mode-to-mode-line)
  78                    )))
  79       )
  80   (progn
  81     (add-hook 'gnus-Article-mode-hook
  82               (function tm-gnus/add-decoding-mode-to-mode-line))
  83     ))
  84
  85 ;;; @@ to decode subjects in mode-line
  86 ;;;
  87 ;; This function imported from gnus.el.
  88 ;;
  89 ;; New implementation in gnus 3.14.3
  90 ;;
  91
  92 (defun tm-gnus/article-set-mode-line ()
  93   "Set Article mode line string.
  94 If you don't like it, define your own gnus-article-set-mode-line."
  95   (let ((maxlen 15)                     ;Maximum subject length
  96         (subject
  97          (if gnus-current-headers
  98              (mime-eword/decode-string
  99               (nntp-header-subject gnus-current-headers))
 100            "")
 101          ))
 102     ;; The value must be a string to escape %-constructs because of subject.
 103     (setq mode-line-buffer-identification
 104           (format "GNUS: %s%s %s%s%s"
 105                   gnus-newsgroup-name
 106                   (if gnus-current-article
 107                       (format "/%d" gnus-current-article) "")
 108                   (rightful-boundary-short-string subject
 109                                                   (min (string-width subject)
 110                                                        maxlen))
 111                   (if (> (string-width subject) maxlen) "..." "")
 112                   (make-string (max 0 (- 17 (string-width subject))) ? )
 113                   )))
 114   (set-buffer-modified-p t))
 115
 116 (fset 'gnus-Article-set-mode-line 'tm-gnus/article-set-mode-line)
 117
 118
 119 ;;; @ change MIME encoded-word decoding mode, decoding or non decoding.
 120 ;;;
 121
 122 (defun tm-gnus/set-decoding-mode (arg)
 123   "Set MIME encoded-word processing.
 124 With arg, turn MIME encoded-word processing on iff arg is positive."
 125   (setq tm-gnus/decoding-mode arg)
 126   (setq gnus-have-all-headers (not gnus-have-all-headers))
 127   (gnus-summary-select-article (not gnus-have-all-headers) t)
 128   )
 129
 130 (defun tm-gnus/toggle-decoding-mode ()
 131   "Toggle MIME encoded-word processing.
 132 With arg, turn MIME encoded-word processing on iff arg is positive."
 133   (interactive)
 134   (tm-gnus/set-decoding-mode (not tm-gnus/decoding-mode))
 135   )
 136
 137
 138 ;;; @ for tm-view
 139 ;;;
 140
 141 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
 142
 143 (defun tm-gnus/view-message (arg)
 144   "MIME decode and play this message."
 145   (interactive "P")
 146   (let ((gnus-break-pages nil))
 147     (gnus-Subject-select-article t t)
 148     )
 149   (pop-to-buffer gnus-Article-buffer t)
 150   (mime/viewer-mode)
 151   )
 152
 153 (call-after-loaded
 154  'tm-view
 155  (function
 156   (lambda ()
 157     (set-alist 'mime-viewer/quitting-method-alist
 158                'gnus-Article-mode
 159                (if (string-match (regexp-quote "3.14.4") gnus-version)
 160                    (function
 161                     (lambda ()
 162                       (mime-viewer/kill-buffer)
 163                       (delete-other-windows)
 164                       (gnus-Article-show-summary)
 165                       ))
 166                  (function
 167                   (lambda ()
 168                     (mime-viewer/kill-buffer)
 169                     (delete-other-windows)
 170                     (gnus-Article-show-subjects)
 171                     ))
 172                  ))
 173     )))
 174
 175
 176 ;;; @ for tm-partial
 177 ;;;
 178
 179 (call-after-loaded
 180  'tm-partial
 181  (function
 182   (lambda ()
 183     (set-atype 'mime/content-decoding-condition
 184                '((type . "message/partial")
 185                  (method . mime-article/grab-message/partials)
 186                  (major-mode . gnus-Article-mode)
 187                  (summary-buffer-exp . gnus-Subject-buffer)
 188                  ))
 189
 190     (set-alist 'tm-partial/preview-article-method-alist
 191                'gnus-Article-mode
 192                (function
 193                 (lambda ()
 194                   (tm-gnus/view-message (gnus-Subject-article-number))
 195                   )))
 196     )))
 197
 198
 199 ;;; @ Summary decoding
 200 ;;;
 201
 202 (add-hook 'gnus-Select-group-hook (function tm-gnus/decode-summary-subjects))
 203
 204
 205 ;;; @ set up
 206 ;;;
 207
 208 (define-key gnus-Subject-mode-map "\et" 'tm-gnus/toggle-decoding-mode)
 209 (define-key gnus-Subject-mode-map "v" 'tm-gnus/view-message)
 210
 211 (defun tm-gnus/decode-encoded-word-if-you-need ()
 212   (if (and tm-gnus/decoding-mode
 213            (cond ((boundp 'all-headers) (not all-headers))
 214                  (t                     t))
 215            )
 216       (mime/decode-message-header)
 217     )
 218   (run-hooks 'tm-gnus/article-prepare-hook)
 219   )
 220
 221 (add-hook 'gnus-Article-prepare-hook
 222           (function tm-gnus/decode-encoded-word-if-you-need) t)
 223
 224
 225 ;;; @ for BBDB
 226 ;;;
 227
 228 (defun tm-gnus/bbdb-setup ()
 229   (if (memq 'bbdb/gnus-update-record gnus-Article-prepare-hook)
 230       (progn
 231         (remove-hook 'gnus-Article-prepare-hook 'bbdb/gnus-update-record)
 232         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 233         )))
 234
 235 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 236
 237 (tm-gnus/bbdb-setup)
 238
 239 (call-after-loaded
 240  'bbdb
 241  (function
 242   (lambda ()
 243     (require 'tm-bbdb)
 244     )))
 245
 246
 247 ;;; @ end
 248 ;;;
 249
 250 (provide 'tm-gnus3)
 251
 252 ;;; tm-gnus3.el ends here