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