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 ;;;         MURATA Masahiro <murata@sol.cs.ritsumei.ac.jp>
   9 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  10 ;;; Created: 1995/09/24
  11 ;;; Version: $Revision: 7.33 $
  12 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
  13 ;;;
  14 ;;; This file is part of tm (Tools for MIME).
  15 ;;;
  16 ;;; This program is free software; you can redistribute it and/or
  17 ;;; modify it under the terms of the GNU General Public License as
  18 ;;; published by the Free Software Foundation; either version 2, or
  19 ;;; (at your option) any later version.
  20 ;;;
  21 ;;; This program is distributed in the hope that it will be useful,
  22 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 ;;; General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with This program.  If not, write to the Free Software
  28 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  29 ;;;
  30 ;;; Code:
  31
  32 (require 'tl-str)
  33 (require 'tl-list)
  34 (require 'tl-misc)
  35 (require 'tm-view)
  36 (require 'gnus)
  37 (require 'tm-gd5)
  38
  39 (eval-when-compile (require 'cl))
  40
  41
  42 ;;; @ version
  43 ;;;
  44
  45 (defconst tm-gnus/RCS-ID
  46   "$Id: tm-sgnus.el,v 7.33 1996/01/09 12:06:29 morioka Exp $")
  47
  48 (defconst tm-gnus/version
  49   (concat (get-version-string tm-gnus/RCS-ID) " for September"))
  50
  51
  52 ;;; @ variables
  53 ;;;
  54
  55 (defvar tm-gnus/automatic-mime-preview t
  56   "*If non-nil, show MIME processed article.
  57 This variable is set to `gnus-show-mime'.")
  58
  59 (setq gnus-show-mime tm-gnus/automatic-mime-preview)
  60
  61
  62 ;;; @ command functions
  63 ;;;
  64
  65 (defun tm-gnus/view-message (arg)
  66   "MIME decode and play this message."
  67   (interactive "P")
  68   (let ((gnus-break-pages nil))
  69     (gnus-summary-select-article t t)
  70     )
  71   (pop-to-buffer gnus-original-article-buffer t)
  72   (let (buffer-read-only)
  73     (if (text-property-any (point-min) (point-max) 'invisible t)
  74         (remove-text-properties (point-min) (point-max)
  75                                 gnus-hidden-properties)
  76       ))
  77   (mime/viewer-mode nil nil nil gnus-original-article-buffer
  78                     gnus-article-buffer)
  79   )
  80
  81 (defun tm-gnus/summary-scroll-down ()
  82   "Scroll down one line current article."
  83   (interactive)
  84   (gnus-summary-scroll-up -1)
  85   )
  86
  87 (defun tm-gnus/summary-toggle-header (&optional arg)
  88   (interactive "P")
  89   (if tm-gnus/automatic-mime-preview
  90       (let* ((hidden
  91               (save-excursion
  92                 (set-buffer gnus-article-buffer)
  93                 (text-property-any
  94                  (goto-char (point-min)) (search-forward "\n\n")
  95                  'invisible t)
  96                 ))
  97              (mime-viewer/redisplay t)
  98              )
  99         (gnus-summary-select-article hidden t)
 100         )
 101     (gnus-summary-toggle-header arg))
 102   )
 103
 104 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
 105 (define-key gnus-summary-mode-map
 106   "\e\r" (function tm-gnus/summary-scroll-down))
 107 (define-key gnus-summary-mode-map
 108   "t" (function tm-gnus/summary-toggle-header))
 109
 110
 111 ;;; @ for tm-view
 112 ;;;
 113
 114 (defun mime-viewer/quitting-method-for-sgnus ()
 115   (if (not gnus-show-mime)
 116       (mime-viewer/kill-buffer))
 117   (delete-other-windows)
 118   (gnus-article-show-summary)
 119   (if (or (not gnus-show-mime)
 120           (null gnus-have-all-headers))
 121       (gnus-summary-select-article nil t)
 122     ))
 123
 124 (call-after-loaded
 125  'tm-view
 126  (lambda ()
 127    (set-alist 'mime-viewer/quitting-method-alist
 128               'gnus-original-article-mode
 129               (function mime-viewer/quitting-method-for-sgnus))
 130    (set-alist 'mime-viewer/show-summary-method
 131               'gnus-original-article-mode
 132               (function mime-viewer/quitting-method-for-sgnus))
 133    ))
 134
 135
 136 ;;; @ for tm-partial
 137 ;;;
 138
 139 (defun tm-gnus/partial-preview-function ()
 140   (tm-gnus/view-message (gnus-summary-article-number))
 141   )
 142
 143 (call-after-loaded
 144  'tm-partial
 145  (lambda ()
 146    (set-atype 'mime/content-decoding-condition
 147               '((type . "message/partial")
 148                 (method . mime-article/grab-message/partials)
 149                 (major-mode . gnus-original-article-mode)
 150                 (summary-buffer-exp . gnus-summary-buffer)
 151                 ))
 152    (set-alist 'tm-partial/preview-article-method-alist
 153               'gnus-original-article-mode
 154               'tm-gnus/partial-preview-function)
 155    ))
 156
 157
 158 ;;; @ article filter
 159 ;;;
 160
 161 (defun tm-gnus/article-reset-variable ()
 162   (setq tm-gnus/automatic-mime-preview nil)
 163   )
 164
 165 (add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable)
 166
 167 (defun tm-gnus/preview-article ()
 168   (make-local-variable 'tm:mother-button-dispatcher)
 169   (setq tm:mother-button-dispatcher
 170         (function gnus-article-push-button))
 171   (let ((mime-viewer/ignored-field-regexp "^:$"))
 172     (mime/viewer-mode nil nil nil gnus-original-article-buffer
 173                       gnus-article-buffer)
 174     )
 175   (setq tm-gnus/automatic-mime-preview t)
 176   (run-hooks 'tm-gnus/article-prepare-hook)
 177   )
 178
 179 (setq gnus-show-mime-method (function tm-gnus/preview-article))
 180
 181 (defun tm-gnus/article-decode-encoded-word ()
 182   (mime/decode-message-header)
 183   (run-hooks 'tm-gnus/article-prepare-hook)
 184   )
 185
 186 (setq gnus-decode-encoded-word-method
 187       (function tm-gnus/article-decode-encoded-word))
 188
 189
 190 ;;; @ for tm-edit
 191 ;;;
 192
 193 (defun tm-gnus/forward-insert-buffer (buffer)
 194   (save-excursion
 195     (save-restriction
 196       (if gnus-signature-before-forwarded-message
 197           (goto-char (point-max))
 198         (goto-char (point-min))
 199         (re-search-forward
 200          (concat "^" (regexp-quote mail-header-separator) "$"))
 201         (forward-line 1))
 202       ;; Narrow to the area we are to insert.
 203       (narrow-to-region (point) (point))
 204       ;; Insert the separators and the forwarded buffer.
 205       (mime-editor/insert-tag "message" "rfc822")
 206       (insert-buffer-substring buffer)
 207       ;; Delete any invisible text.
 208       (goto-char (point-min))
 209       (let (beg)
 210         (while (setq beg (next-single-property-change (point) 'invisible))
 211           (goto-char beg)
 212           (delete-region beg (or (next-single-property-change
 213                                   (point) 'invisible)
 214                                  (point-max))))))))
 215
 216 (call-after-loaded
 217  'mime-setup
 218  (lambda ()
 219    (cond ((string-match "XEmacs" emacs-version)
 220           (require 'gnus-msg)
 221           (fset 'gnus-forward-insert-buffer 'tm-gnus/forward-insert-buffer)
 222           )
 223          (t
 224           (eval-after-load
 225            "gnus-msg"
 226            '(fset 'gnus-forward-insert-buffer 'tm-gnus/forward-insert-buffer)
 227            )
 228           ))))
 229
 230
 231 ;;; @ for BBDB
 232 ;;;
 233
 234 (defun tm-gnus/bbdb-setup ()
 235   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 236       (progn
 237         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 238         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 239         )))
 240
 241 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 242
 243 (tm-gnus/bbdb-setup)
 244
 245
 246 ;;; @ end
 247 ;;;
 248
 249 (provide 'tm-sgnus)