gnus/tm-gnus5.el

   1 ;;;
   2 ;;; tm-gnus5.el --- tm-gnus module for Gnus 5.*
   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 'tl-822)
  17 (require 'gnus)
  18 (require 'tm-view)
  19
  20
  21 ;;; @ version
  22 ;;;
  23
  24 (defconst tm-gnus/RCS-ID
  25   "$Id: tm-gnus5.el,v 7.9 1995/11/15 10:41:02 morioka Exp $")
  26
  27 (defconst tm-gnus/version
  28   (concat (get-version-string tm-gnus/RCS-ID) " for GNUS 5.0.x"))
  29
  30
  31 ;;; @ variables
  32 ;;;
  33
  34 (defvar tm-gnus/original-article-buffer " *Original Article*")
  35
  36 (defvar tm-gnus/automatic-mime-preview t
  37   "*If non-nil, show MIME processed article.
  38 This variable is set to `gnus-show-mime'.")
  39
  40 (setq gnus-show-mime tm-gnus/automatic-mime-preview)
  41
  42
  43 ;;; @ command functions
  44 ;;;
  45
  46 (defun tm-gnus/view-message (arg)
  47   "MIME decode and play this message."
  48   (interactive "P")
  49   (if (save-excursion
  50         (set-buffer gnus-article-buffer)
  51         (eq major-mode 'mime/viewer-mode)
  52         )
  53       (pop-to-buffer gnus-article-buffer t)
  54     (let ((gnus-break-pages nil))
  55       (gnus-summary-select-article t t)
  56       )
  57     (pop-to-buffer gnus-article-buffer t)
  58     (let (buffer-read-only)
  59       (remove-text-properties (point-min) (point-max) '(face nil))
  60       (if (get-buffer tm-gnus/original-article-buffer)
  61             (kill-buffer tm-gnus/original-article-buffer)
  62           )
  63       (rename-buffer tm-gnus/original-article-buffer)
  64       (mime/viewer-mode nil nil nil
  65                         tm-gnus/original-article-buffer
  66                         gnus-article-buffer)
  67       ))
  68   )
  69
  70 (defun tm-gnus/summary-scroll-down ()
  71   "Scroll down one line current article."
  72   (interactive)
  73   (gnus-summary-scroll-up -1)
  74   )
  75
  76 (defun tm-gnus/summary-toggle-header (&optional arg)
  77   (interactive "P")
  78   (if (and gnus-show-mime
  79            (or (not gnus-strict-mime)
  80                (save-excursion
  81                  (set-buffer gnus-article-buffer)
  82                  (gnus-fetch-field "Mime-Version")
  83                  )))
  84       (let ((mime-viewer/ignored-field-regexp
  85              (if (save-excursion
  86                    (set-buffer gnus-article-buffer)
  87                    (some-element
  88                     (lambda (field)
  89                       (rfc822/get-field-body field)
  90                       )
  91                     mime-viewer/ignored-field-list))
  92                  mime-viewer/ignored-field-regexp
  93                "^:$")))
  94         (gnus-summary-select-article t t)
  95         )
  96     (gnus-summary-toggle-header arg)
  97     ))
  98
  99 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
 100 (define-key gnus-summary-mode-map "t" (function tm-gnus/summary-toggle-header))
 101 (define-key gnus-summary-mode-map
 102   "\e\r" (function tm-gnus/summary-scroll-down))
 103
 104
 105 ;;; @ for tm-view
 106 ;;;
 107
 108 (defun mime-viewer/quitting-method-for-gnus5 ()
 109   (mime-viewer/kill-buffer)
 110   (delete-other-windows)
 111   (gnus-article-show-summary)
 112   (gnus-summary-display-article (gnus-summary-article-number))
 113   )
 114
 115 (call-after-loaded
 116  'tm-view
 117  (lambda ()
 118    (set-alist 'mime-viewer/quitting-method-alist
 119               'gnus-article-mode
 120               (function mime-viewer/quitting-method-for-gnus5))
 121    ))
 122
 123
 124 ;;; @ for tm-partial
 125 ;;;
 126
 127 (call-after-loaded
 128  'tm-partial
 129  (function
 130   (lambda ()
 131     (set-atype 'mime/content-decoding-condition
 132                '((type . "message/partial")
 133                  (method . mime-article/grab-message/partials)
 134                  (major-mode . gnus-article-mode)
 135                  (summary-buffer-exp . gnus-summary-buffer)
 136                  ))
 137
 138     (set-alist 'tm-partial/preview-article-method-alist
 139                'gnus-article-mode
 140                (function
 141                 (lambda ()
 142                   (tm-gnus/view-message (gnus-summary-article-number))
 143                   )))
 144     )))
 145
 146
 147 ;;; @ summary filter
 148 ;;;
 149
 150 (cond ((not (boundp 'nnheader-encoded-words-decoding))
 151        (defun tm-gnus/decode-summary-from-and-subjects ()
 152          (mapcar (lambda (header)
 153                    (let ((from (mail-header-from header))
 154                          (subj (mail-header-subject header))
 155                          )
 156                      (mail-header-set-from
 157                       header
 158                       (if from
 159                           (mime-eword/decode-string from)
 160                         ""))
 161                      (mail-header-set-subject
 162                       header
 163                       (if subj
 164                           (mime-eword/decode-string subj)
 165                         ""))
 166                      ))
 167                  gnus-newsgroup-headers)
 168          )
 169        (add-hook 'gnus-select-group-hook
 170                  (function tm-gnus/decode-summary-from-and-subjects))
 171        ))
 172
 173
 174 ;;; @ article filter
 175 ;;;
 176
 177 (defun tm-gnus/preview-article ()
 178   (if (get-buffer tm-gnus/original-article-buffer)
 179       (kill-buffer tm-gnus/original-article-buffer)
 180     )
 181   (rename-buffer tm-gnus/original-article-buffer)
 182   (gnus-article-mode)
 183   (set-buffer (get-buffer-create gnus-article-buffer))
 184   (make-local-variable 'tm:mother-button-dispatcher)
 185   (setq tm:mother-button-dispatcher
 186         (function gnus-article-push-button))
 187   (mime/viewer-mode
 188    nil nil nil tm-gnus/original-article-buffer gnus-article-buffer)
 189   (run-hooks 'tm-gnus/article-prepare-hook)
 190   )
 191
 192 (or (fboundp 'tm::gnus-article-setup-buffer)
 193     (fset 'tm::gnus-article-setup-buffer
 194           (symbol-function 'gnus-article-setup-buffer)
 195           ))
 196
 197 (defun gnus-article-setup-buffer ()
 198   "Initialize article mode buffer."
 199   ;; Returns the article buffer.
 200   (if (get-buffer gnus-article-buffer)
 201       (save-excursion
 202         (set-buffer gnus-article-buffer)
 203         (buffer-disable-undo (current-buffer))
 204         (setq buffer-read-only t)
 205         (gnus-add-current-to-buffer-list)
 206         (or (eq major-mode 'gnus-article-mode)
 207             (eq major-mode 'mime/viewer-mode)
 208             (gnus-article-mode))
 209         (current-buffer))
 210     (save-excursion
 211       (set-buffer (get-buffer-create gnus-article-buffer))
 212       (gnus-add-current-to-buffer-list)
 213       (gnus-article-mode)
 214       (current-buffer)
 215       )))
 216
 217 (setq gnus-show-mime-method (function tm-gnus/preview-article))
 218
 219 (or (fboundp 'tm::gnus-article-hide-headers-if-wanted)
 220     (fset 'tm::gnus-article-hide-headers-if-wanted
 221           (symbol-function 'gnus-article-hide-headers-if-wanted))
 222     )
 223
 224 (defun gnus-article-hide-headers-if-wanted ()
 225   (or (and gnus-show-mime
 226            (or (not gnus-strict-mime)
 227                (gnus-fetch-field "Mime-Version")
 228                ))
 229       (tm::gnus-article-hide-headers-if-wanted)
 230       ))
 231
 232
 233 ;;; @ for mh-e
 234 ;;;
 235
 236 (call-after-loaded
 237  'tm-mh-e
 238  (function
 239   (lambda ()
 240
 241 ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 242 ;;;
 243 ;; Please use following setting:
 244 ;;
 245 ;;      (autoload 'gnus-mail-forward-using-mhe-mime "tm-mh-e"
 246 ;;                "Forward using mh-e with tm-edit." t)
 247 ;;      (setq gnus-mail-forward-method
 248 ;;            (function gnus-mail-forward-using-mhe-mime))
 249 ;;
 250 (defun gnus-mail-forward-using-mhe-mime (&optional buffer)
 251   "Forward the current message to another user using mh-e with mime-mode."
 252   ;; First of all, prepare mhe mail buffer.
 253   (require 'mh-comp)
 254   (require 'tm-edit)
 255   (let* ((to (read-string "To: "))
 256          (cc (read-string "Cc: "))
 257          (buffer (save-excursion
 258                    (set-buffer gnus-article-buffer)
 259                    (if (eq major-mode 'mime/viewer-mode)
 260                        mime::preview/article-buffer
 261                      (current-buffer)
 262                      )))
 263          (config (current-window-configuration)) ; need to add this - erik
 264          (subject (gnus-forward-make-subject buffer)))
 265     (setq mh-show-buffer buffer)
 266     (mh-find-path)
 267     (mh-send-sub to (or cc "")
 268                  (or subject "(None)") config) ; Erik Selberg 1/23/94
 269     (let ((draft (current-buffer))
 270           (gnus-mail-buffer (current-buffer))
 271           mail-buf)
 272       (gnus-configure-windows 'reply-yank)
 273       (setq mail-buf (eval (cdr (assq 'mail gnus-window-to-buffer))))
 274       (pop-to-buffer mail-buf) ; always in the display, so won't have window probs
 275       (switch-to-buffer draft)
 276       )
 277     (save-excursion
 278       (goto-char (point-max))
 279       (insert (concat (mime-make-tag "message" "rfc822" nil "7bit") "\n"))
 280       (insert-buffer buffer)
 281       (setq mh-sent-from-folder buffer)
 282       (setq mh-sent-from-msg 1)
 283       (setq mh-previous-window-config config)
 284       (run-hooks 'gnus-mail-hook)
 285       )))
 286
 287 )))
 288
 289
 290 ;;; @ for BBDB
 291 ;;;
 292
 293 (defun tm-gnus/bbdb-setup ()
 294   (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook)
 295       (progn
 296         (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record)
 297         (add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record)
 298         )))
 299
 300 (add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t)
 301
 302 (tm-gnus/bbdb-setup)
 303
 304
 305 ;;; @ end
 306 ;;;
 307
 308 (provide 'tm-gnus5)