gnus/tm-sgnus.el

   1 ;;;
   2 ;;; tm-sgnus.el --- tm-gnus module for September GNUS
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
   9 ;;;
  10 ;;; This file is part of tm (Tools for MIME).
  11 ;;;
  12
  13 (require 'tl-str)
  14 (require 'tl-list)
  15 (require 'tl-misc)
  16 (require 'gnus)
  17
  18 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  19 (autoload 'mime/decode-message-header
  20   "tm-ew-d" "Decode MIME encoded-words in message header." t)
  21 (autoload 'mime-eword/decode-string
  22   "tm-ew-d" "Decode MIME encoded-words in string." t)
  23
  24
  25 ;;; @ version
  26 ;;;
  27
  28 (defconst tm-gnus/RCS-ID
  29   "$Id: tm-sgnus.el,v 7.12 1995/10/29 14:13:08 morioka Exp $")
  30
  31 (defconst tm-gnus/version
  32   (concat (get-version-string tm-gnus/RCS-ID) " for September"))
  33
  34
  35 ;;; @ variables
  36 ;;;
  37
  38 (defvar tm-gnus/automatic-mime-preview t
  39   "*If non-nil, show MIME processed article.
  40 This variable is set to `gnus-show-mime'.")
  41
  42 (setq gnus-show-mime tm-gnus/automatic-mime-preview)
  43
  44
  45 ;;; @ command functions
  46 ;;;
  47
  48 (defun tm-gnus/view-message (arg)
  49   "MIME decode and play this message."
  50   (interactive "P")
  51   (let ((gnus-break-pages nil))
  52     (gnus-summary-select-article t t)
  53     )
  54   (pop-to-buffer gnus-original-article-buffer t)
  55   (let (buffer-read-only)
  56     (if (text-property-any (point-min) (point-max) 'invisible t)
  57         (remove-text-properties (point-min) (point-max)
  58                                 gnus-hidden-properties)
  59       ))
  60   (mime/viewer-mode nil nil nil gnus-original-article-buffer
  61                     gnus-article-buffer)
  62   )
  63
  64 (defun tm-gnus/summary-scroll-down ()
  65   "Scroll down one line current article."
  66   (interactive)
  67   (gnus-summary-scroll-up -1)
  68   )
  69
  70 (defun tm-gnus/summary-toggle-header (&optional arg)
  71   (interactive "P")
  72   (if gnus-show-mime
  73       (let ((mime-viewer/ignored-field-list
  74              (if (save-excursion
  75                    (set-buffer gnus-article-buffer)
  76                    (some-element
  77                     (lambda (field)
  78                       (rfc822/get-field-body field)
  79                       )
  80                     mime-viewer/ignored-field-list))
  81                  mime-viewer/ignored-field-list)))
  82         (gnus-summary-select-article t t)
  83         )
  84     (gnus-summary-toggle-header arg)
  85     ))
  86
  87 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
  88 (define-key gnus-summary-mode-map
  89   "\e\r" (function tm-gnus/summary-scroll-down))
  90 (define-key gnus-summary-mode-map
  91   "t" (function tm-gnus/summary-toggle-header))
  92
  93
  94 ;;; @ for tm-view
  95 ;;;
  96
  97 (defun mime-viewer/quitting-method-for-sgnus ()
  98   (mime-viewer/kill-buffer)
  99   (delete-other-windows)
 100   (gnus-article-show-summary)
 101   (gnus-summary-display-article (gnus-summary-article-number))
 102   )
 103
 104 (call-after-loaded
 105  'tm-view
 106  (lambda ()
 107    (set-alist 'mime-viewer/quitting-method-alist
 108               'gnus-original-article-mode
 109               (function mime-viewer/quitting-method-for-sgnus))
 110    ))
 111
 112
 113 ;;; @ for tm-partial
 114 ;;;
 115
 116 (call-after-loaded
 117  'tm-partial
 118  (lambda ()
 119    (set-atype 'mime/content-decoding-condition
 120               '((type . "message/partial")
 121                 (method . mime-article/grab-message/partials)
 122                 (major-mode . gnus-original-article-mode)
 123                 (summary-buffer-exp . gnus-summary-buffer)
 124                 ))
 125    (set-alist 'tm-partial/preview-article-method-alist
 126               'gnus-original-article-mode
 127               '(lambda ()
 128                  (tm-gnus/view-message (gnus-summary-article-number))
 129                  ))
 130    ))
 131
 132
 133 ;;; @ summary filter
 134 ;;;
 135
 136 (cond ((not (boundp 'nnheader-encoded-words-decoding))
 137        (defun tm-gnus/decode-summary-from-and-subjects ()
 138          (mapcar (lambda (header)
 139                    (let ((from (mail-header-from header))
 140                          (subj (mail-header-subject header))
 141                          )
 142                      (mail-header-set-from
 143                       header
 144                       (if from
 145                           (mime-eword/decode-string from)
 146                         ""))
 147                      (mail-header-set-subject
 148                       header
 149                       (if subj
 150                           (mime-eword/decode-string subj)
 151                         ""))
 152                      ))
 153                  gnus-newsgroup-headers)
 154          )
 155        (add-hook 'gnus-select-group-hook
 156                  (function tm-gnus/decode-summary-from-and-subjects))
 157        ))
 158
 159
 160 ;;; @ article filter
 161 ;;;
 162
 163 (defun tm-gnus/preview-article ()
 164   (make-local-variable 'tm:mother-button-dispatcher)
 165   (setq tm:mother-button-dispatcher
 166         (function gnus-article-push-button))
 167   (mime/viewer-mode nil nil nil gnus-original-article-buffer
 168                     gnus-article-buffer)
 169   (run-hooks 'tm-gnus/article-prepare-hook)
 170   )
 171
 172 (setq gnus-show-mime-method (function tm-gnus/preview-article))
 173
 174 (or (fboundp 'tm::gnus-article-hide-headers-if-wanted)
 175     (fset 'tm::gnus-article-hide-headers-if-wanted
 176           (symbol-function 'gnus-article-hide-headers-if-wanted))
 177     )
 178
 179 (defun gnus-article-hide-headers-if-wanted ()
 180   (if (not gnus-show-mime)
 181       (tm::gnus-article-hide-headers-if-wanted)
 182     ))
 183
 184
 185 ;;; @ for BBDB
 186 ;;;
 187
 188 (defun tm-gnus/bbdb-setup ()
 189   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 190       (progn
 191         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 192         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 193         )))
 194
 195 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 196
 197 (tm-gnus/bbdb-setup)
 198
 199
 200 ;;; @ end
 201 ;;;
 202
 203 (provide 'tm-sgnus)