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 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Created: 1995/09/24
  10 ;;; Version: $Revision: 7.24 $
  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-str)
  32 (require 'tl-list)
  33 (require 'tl-misc)
  34 (require 'tm-view)
  35 (require 'gnus)
  36 (require 'tm-gd5)
  37
  38
  39 ;;; @ version
  40 ;;;
  41
  42 (defconst tm-gnus/RCS-ID
  43   "$Id: tm-sgnus.el,v 7.24 1995/12/15 13:47:36 morioka Exp $")
  44
  45 (defconst tm-gnus/version
  46   (concat (get-version-string tm-gnus/RCS-ID) " for September"))
  47
  48
  49 ;;; @ variables
  50 ;;;
  51
  52 (defvar tm-gnus/automatic-mime-preview t
  53   "*If non-nil, show MIME processed article.
  54 This variable is set to `gnus-show-mime'.")
  55
  56 (setq gnus-show-mime tm-gnus/automatic-mime-preview)
  57
  58
  59 ;;; @ command functions
  60 ;;;
  61
  62 (defun tm-gnus/view-message (arg)
  63   "MIME decode and play this message."
  64   (interactive "P")
  65   (let ((gnus-break-pages nil))
  66     (gnus-summary-select-article t t)
  67     )
  68   (pop-to-buffer gnus-original-article-buffer t)
  69   (let (buffer-read-only)
  70     (if (text-property-any (point-min) (point-max) 'invisible t)
  71         (remove-text-properties (point-min) (point-max)
  72                                 gnus-hidden-properties)
  73       ))
  74   (mime/viewer-mode nil nil nil gnus-original-article-buffer
  75                     gnus-article-buffer)
  76   )
  77
  78 (defun tm-gnus/summary-scroll-down ()
  79   "Scroll down one line current article."
  80   (interactive)
  81   (gnus-summary-scroll-up -1)
  82   )
  83
  84 (defun tm-gnus/summary-toggle-header (&optional arg)
  85   (interactive "P")
  86   (if tm-gnus/automatic-mime-preview
  87       (let ((mime-viewer/ignored-field-regexp
  88              (if (save-excursion
  89                    (set-buffer gnus-article-buffer)
  90                    (save-restriction
  91                      (narrow-to-region
  92                       (point-min)
  93                       (if (re-search-forward "^$" nil t)
  94                           (match-beginning 0)
  95                         (point-max)
  96                         ))
  97                      (some-element
  98                       (lambda (field)
  99                         (goto-char (point-min))
 100                         (and (re-search-forward
 101                               (concat "^" field ":") nil t)
 102                              (setq field
 103                                    (buffer-substring-no-properties
 104                                     (match-beginning 0) (match-end 0)))
 105                              (not
 106                               (string-match
 107                                mime-viewer/visible-field-regexp field))
 108                              )
 109                         )
 110                       mime-viewer/ignored-field-list)))
 111                  mime-viewer/ignored-field-regexp
 112                "^:$")))
 113         (gnus-summary-select-article t t)
 114         )
 115     (gnus-summary-toggle-header arg)
 116     ))
 117
 118 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
 119 (define-key gnus-summary-mode-map
 120   "\e\r" (function tm-gnus/summary-scroll-down))
 121 (define-key gnus-summary-mode-map
 122   "t" (function tm-gnus/summary-toggle-header))
 123
 124
 125 ;;; @ for tm-view
 126 ;;;
 127
 128 (defun mime-viewer/quitting-method-for-sgnus ()
 129   (if (not gnus-show-mime)
 130       (mime-viewer/kill-buffer))
 131   (delete-other-windows)
 132   (gnus-article-show-summary)
 133   (if (or (not gnus-show-mime)
 134           (null gnus-have-all-headers))
 135       (gnus-summary-select-article nil t)
 136     ))
 137
 138 (call-after-loaded
 139  'tm-view
 140  (lambda ()
 141    (set-alist 'mime-viewer/quitting-method-alist
 142               'gnus-original-article-mode
 143               (function mime-viewer/quitting-method-for-sgnus))
 144    ))
 145
 146
 147 ;;; @ for tm-partial
 148 ;;;
 149
 150 (defun tm-gnus/partial-preview-function ()
 151   (tm-gnus/view-message (gnus-summary-article-number))
 152   )
 153
 154 (call-after-loaded
 155  'tm-partial
 156  (lambda ()
 157    (set-atype 'mime/content-decoding-condition
 158               '((type . "message/partial")
 159                 (method . mime-article/grab-message/partials)
 160                 (major-mode . gnus-original-article-mode)
 161                 (summary-buffer-exp . gnus-summary-buffer)
 162                 ))
 163    (set-alist 'tm-partial/preview-article-method-alist
 164               'gnus-original-article-mode
 165               'tm-gnus/partial-preview-function)
 166    ))
 167
 168
 169 ;;; @ article filter
 170 ;;;
 171
 172 (defun tm-gnus/article-reset-variable ()
 173   (setq tm-gnus/automatic-mime-preview nil)
 174   )
 175
 176 (add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable)
 177
 178 (defun tm-gnus/preview-article ()
 179   (make-local-variable 'tm:mother-button-dispatcher)
 180   (setq tm:mother-button-dispatcher
 181         (function gnus-article-push-button))
 182   (mime/viewer-mode nil nil nil gnus-original-article-buffer
 183                     gnus-article-buffer)
 184   (setq tm-gnus/automatic-mime-preview t)
 185   (run-hooks 'tm-gnus/article-prepare-hook)
 186   )
 187
 188 (setq gnus-show-mime-method (function tm-gnus/preview-article))
 189
 190 (defun tm-gnus/article-decode-encoded-word ()
 191   (mime/decode-message-header)
 192   (run-hooks 'tm-gnus/article-prepare-hook)
 193   )
 194
 195 (setq gnus-decode-encoded-word-method
 196       (function tm-gnus/article-decode-encoded-word))
 197
 198 (or (fboundp 'tm::gnus-article-hide-headers-if-wanted)
 199     (fset 'tm::gnus-article-hide-headers-if-wanted
 200           (symbol-function 'gnus-article-hide-headers-if-wanted))
 201     )
 202
 203 (defun gnus-article-hide-headers-if-wanted ()
 204   (or tm-gnus/automatic-mime-preview
 205       (tm::gnus-article-hide-headers-if-wanted)
 206       ))
 207
 208
 209 ;;; @ for BBDB
 210 ;;;
 211
 212 (defun tm-gnus/bbdb-setup ()
 213   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 214       (progn
 215         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 216         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 217         )))
 218
 219 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 220
 221 (tm-gnus/bbdb-setup)
 222
 223
 224 ;;; @ end
 225 ;;;
 226
 227 (provide 'tm-sgnus)