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.13 1995/10/31 08:53:36 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 gnus-show-mime
  68       (let ((mime-viewer/ignored-field-list
  69              (if (save-excursion
  70                    (set-buffer gnus-article-buffer)
  71                    (some-element
  72                     (lambda (field)
  73                       (rfc822/get-field-body field)
  74                       )
  75                     mime-viewer/ignored-field-list))
  76                  mime-viewer/ignored-field-list)))
  77         (gnus-summary-select-article t t)
  78         )
  79     (gnus-summary-toggle-header arg)
  80     ))
  81
  82 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
  83 (define-key gnus-summary-mode-map
  84   "\e\r" (function tm-gnus/summary-scroll-down))
  85 (define-key gnus-summary-mode-map
  86   "t" (function tm-gnus/summary-toggle-header))
  87
  88
  89 ;;; @ for tm-view
  90 ;;;
  91
  92 (defun mime-viewer/quitting-method-for-sgnus ()
  93   (mime-viewer/kill-buffer)
  94   (delete-other-windows)
  95   (gnus-article-show-summary)
  96   (gnus-summary-display-article (gnus-summary-article-number))
  97   )
  98
  99 (call-after-loaded
 100  'tm-view
 101  (lambda ()
 102    (set-alist 'mime-viewer/quitting-method-alist
 103               'gnus-original-article-mode
 104               (function mime-viewer/quitting-method-for-sgnus))
 105    ))
 106
 107
 108 ;;; @ for tm-partial
 109 ;;;
 110
 111 (call-after-loaded
 112  'tm-partial
 113  (lambda ()
 114    (set-atype 'mime/content-decoding-condition
 115               '((type . "message/partial")
 116                 (method . mime-article/grab-message/partials)
 117                 (major-mode . gnus-original-article-mode)
 118                 (summary-buffer-exp . gnus-summary-buffer)
 119                 ))
 120    (set-alist 'tm-partial/preview-article-method-alist
 121               'gnus-original-article-mode
 122               '(lambda ()
 123                  (tm-gnus/view-message (gnus-summary-article-number))
 124                  ))
 125    ))
 126
 127
 128 ;;; @ summary filter
 129 ;;;
 130
 131 (cond ((not (boundp 'nnheader-encoded-words-decoding))
 132        (defun tm-gnus/decode-summary-from-and-subjects ()
 133          (mapcar (lambda (header)
 134                    (let ((from (mail-header-from header))
 135                          (subj (mail-header-subject header))
 136                          )
 137                      (mail-header-set-from
 138                       header
 139                       (if from
 140                           (mime-eword/decode-string from)
 141                         ""))
 142                      (mail-header-set-subject
 143                       header
 144                       (if subj
 145                           (mime-eword/decode-string subj)
 146                         ""))
 147                      ))
 148                  gnus-newsgroup-headers)
 149          )
 150        (add-hook 'gnus-select-group-hook
 151                  (function tm-gnus/decode-summary-from-and-subjects))
 152        ))
 153
 154
 155 ;;; @ article filter
 156 ;;;
 157
 158 (defun tm-gnus/preview-article ()
 159   (make-local-variable 'tm:mother-button-dispatcher)
 160   (setq tm:mother-button-dispatcher
 161         (function gnus-article-push-button))
 162   (mime/viewer-mode nil nil nil gnus-original-article-buffer
 163                     gnus-article-buffer)
 164   (run-hooks 'tm-gnus/article-prepare-hook)
 165   )
 166
 167 (setq gnus-show-mime-method (function tm-gnus/preview-article))
 168
 169 (or (fboundp 'tm::gnus-article-hide-headers-if-wanted)
 170     (fset 'tm::gnus-article-hide-headers-if-wanted
 171           (symbol-function 'gnus-article-hide-headers-if-wanted))
 172     )
 173
 174 (defun gnus-article-hide-headers-if-wanted ()
 175   (if (not gnus-show-mime)
 176       (tm::gnus-article-hide-headers-if-wanted)
 177     ))
 178
 179
 180 ;;; @ for BBDB
 181 ;;;
 182
 183 (defun tm-gnus/bbdb-setup ()
 184   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 185       (progn
 186         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 187         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 188         )))
 189
 190 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 191
 192 (tm-gnus/bbdb-setup)
 193
 194
 195 ;;; @ end
 196 ;;;
 197
 198 (provide 'tm-sgnus)