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 .. 1996 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.8 $
  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.8 1996/04/08 12:26:21 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                   (truncate-string subject (min (string-width subject)
 109                                                 maxlen))
 110                   (if (> (string-width subject) maxlen) "..." "")
 111                   (make-string (max 0 (- 17 (string-width subject))) ? )
 112                   )))
 113   (set-buffer-modified-p t))
 114
 115 (fset 'gnus-Article-set-mode-line 'tm-gnus/article-set-mode-line)
 116
 117
 118 ;;; @ change MIME encoded-word decoding mode, decoding or non decoding.
 119 ;;;
 120
 121 (defun tm-gnus/set-decoding-mode (arg)
 122   "Set MIME encoded-word processing.
 123 With arg, turn MIME encoded-word processing on iff arg is positive."
 124   (setq tm-gnus/decoding-mode arg)
 125   (setq gnus-have-all-headers (not gnus-have-all-headers))
 126   (gnus-summary-select-article (not gnus-have-all-headers) t)
 127   )
 128
 129 (defun tm-gnus/toggle-decoding-mode ()
 130   "Toggle MIME encoded-word processing.
 131 With arg, turn MIME encoded-word processing on iff arg is positive."
 132   (interactive)
 133   (tm-gnus/set-decoding-mode (not tm-gnus/decoding-mode))
 134   )
 135
 136
 137 ;;; @ for tm-view
 138 ;;;
 139
 140 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
 141
 142 (defun tm-gnus/view-message (arg)
 143   "MIME decode and play this message."
 144   (interactive "P")
 145   (let ((gnus-break-pages nil))
 146     (gnus-Subject-select-article t t)
 147     )
 148   (pop-to-buffer gnus-Article-buffer t)
 149   (mime/viewer-mode)
 150   )
 151
 152 (call-after-loaded
 153  'tm-view
 154  (function
 155   (lambda ()
 156     (set-alist 'mime-viewer/quitting-method-alist
 157                'gnus-Article-mode
 158                (if (string-match (regexp-quote "3.14.4") gnus-version)
 159                    (function
 160                     (lambda ()
 161                       (mime-viewer/kill-buffer)
 162                       (delete-other-windows)
 163                       (gnus-Article-show-summary)
 164                       ))
 165                  (function
 166                   (lambda ()
 167                     (mime-viewer/kill-buffer)
 168                     (delete-other-windows)
 169                     (gnus-Article-show-subjects)
 170                     ))
 171                  ))
 172     )))
 173
 174
 175 ;;; @ for tm-partial
 176 ;;;
 177
 178 (call-after-loaded
 179  'tm-partial
 180  (function
 181   (lambda ()
 182     (set-atype 'mime/content-decoding-condition
 183                '((type . "message/partial")
 184                  (method . mime-article/grab-message/partials)
 185                  (major-mode . gnus-Article-mode)
 186                  (summary-buffer-exp . gnus-Subject-buffer)
 187                  ))
 188
 189     (set-alist 'tm-partial/preview-article-method-alist
 190                'gnus-Article-mode
 191                (function
 192                 (lambda ()
 193                   (tm-gnus/view-message (gnus-Subject-article-number))
 194                   )))
 195     )))
 196
 197
 198 ;;; @ Summary decoding
 199 ;;;
 200
 201 (add-hook 'gnus-Select-group-hook (function tm-gnus/decode-summary-subjects))
 202
 203
 204 ;;; @ set up
 205 ;;;
 206
 207 (define-key gnus-Subject-mode-map "\et" 'tm-gnus/toggle-decoding-mode)
 208 (define-key gnus-Subject-mode-map "v" 'tm-gnus/view-message)
 209
 210 (defun tm-gnus/decode-encoded-word-if-you-need ()
 211   (if (and tm-gnus/decoding-mode
 212            (cond ((boundp 'all-headers) (not all-headers))
 213                  (t                     t))
 214            )
 215       (mime/decode-message-header)
 216     )
 217   (run-hooks 'tm-gnus/article-prepare-hook)
 218   )
 219
 220 (add-hook 'gnus-Article-prepare-hook
 221           (function tm-gnus/decode-encoded-word-if-you-need) t)
 222
 223
 224 ;;; @ for BBDB
 225 ;;;
 226
 227 (call-after-loaded
 228  'bbdb
 229  (function
 230   (lambda ()
 231     (require 'tm-bbdb)
 232     )))
 233
 234 (autoload 'tm-bbdb/update-record "tm-bbdb")
 235
 236 (defun tm-gnus/bbdb-setup ()
 237   (if (memq 'bbdb/gnus-update-record gnus-Article-prepare-hook)
 238       (progn
 239         (remove-hook 'gnus-Article-prepare-hook 'bbdb/gnus-update-record)
 240         (add-hook 'gnus-Article-prepare-hook 'tm-bbdb/update-record)
 241         )))
 242
 243 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 244
 245 (tm-gnus/bbdb-setup)
 246
 247
 248 ;;; @ end
 249 ;;;
 250
 251 (provide 'tm-gnus3)
 252
 253 ;;; tm-gnus3.el ends here