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