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.3 1995/10/17 16:52:54 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 ;;; @ summary filter
 110 ;;;
 111
 112 (defun tm-gnus/decode-summary-from-and-subjects ()
 113   (mapcar (lambda (header)
 114             (let ((from (mail-header-from header))
 115                   (subj (mail-header-subject header))
 116                   )
 117               (mail-header-set-from
 118                header
 119                (if from
 120                    (mime-eword/decode-string from)
 121                  ""))
 122               (mail-header-set-subject
 123                header
 124                (if subj
 125                    (mime-eword/decode-string subj)
 126                  ""))
 127               ))
 128           gnus-newsgroup-headers)
 129   )
 130
 131 (add-hook 'gnus-select-group-hook
 132           (function tm-gnus/decode-summary-from-and-subjects))
 133
 134
 135 ;;; @ article filter
 136 ;;;
 137
 138 (setq gnus-show-mime-method (function mime/decode-message-header))
 139
 140
 141 ;;; @ automatic MIME preview support
 142 ;;;
 143
 144 (defun tm-gnus/summary-toggle-header (&optional arg)
 145   (interactive "P")
 146   (if tm-gnus/decode-all
 147       (let ((mime-viewer/ignored-field-list
 148              (if (save-window-excursion
 149                    (switch-to-buffer tm-gnus/preview-buffer)
 150                    (some-element
 151                     (lambda (field)
 152                       (rfc822/get-field-body field)
 153                       )
 154                     mime-viewer/ignored-field-list))
 155                  mime-viewer/ignored-field-list)))
 156         (gnus-summary-select-article t t)
 157         )
 158     (gnus-summary-toggle-header arg)
 159     ))
 160
 161 (defun tm-gnus/set-mime-method (mode)
 162   (if mode
 163       (progn
 164         (setq gnus-show-mime nil)
 165         (setq gnus-article-display-hook
 166               (list (function (lambda ()
 167                                 (mime/viewer-mode)
 168                                 (gnus-set-mode-line 'article)
 169                                 ))))
 170         (set-alist 'gnus-window-to-buffer 'article tm-gnus/preview-buffer)
 171         (setq gnus-article-buffer tm-gnus/preview-buffer)
 172         )
 173     (setq gnus-show-mime t)
 174     (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 175     (set-alist 'gnus-window-to-buffer 'article gnus-clean-article-buffer)
 176     (setq gnus-article-buffer gnus-clean-article-buffer)
 177     ))
 178
 179 (defun tm-gnus/toggle-mime (arg)
 180   "Toggle MIME processing mode.
 181 With arg, turn MIME processing on if arg is positive."
 182   (interactive "P")
 183   (setq tm-gnus/decode-all
 184         (if (null arg)
 185             (not tm-gnus/decode-all)
 186           arg))
 187   (gnus-set-global-variables)
 188   (tm-gnus/set-mime-method tm-gnus/decode-all)
 189   (gnus-summary-select-article gnus-show-all-headers 'force)
 190   )
 191
 192 (if tm-gnus/automatic-MIME-preview-support
 193     (progn
 194       (define-key gnus-summary-mode-map
 195         "t" (function tm-gnus/summary-toggle-header))
 196       (define-key gnus-summary-mode-map "\et" (function tm-gnus/toggle-mime))
 197
 198       (tm-gnus/set-mime-method tm-gnus/decode-all)
 199
 200       (add-hook 'gnus-exit-gnus-hook
 201                 (lambda ()
 202                   (let ((buf (get-buffer tm-gnus/preview-buffer)))
 203                     (if buf
 204                         (kill-buffer buf)
 205                       ))))
 206       )
 207   (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 208   (setq gnus-show-mime t)
 209   )
 210
 211
 212 ;;; @ for tm-comp
 213 ;;;
 214
 215 (call-after-loaded
 216  'tm-comp
 217  (function
 218   (lambda ()
 219     (set-alist 'mime/message-sender-alist
 220                'news-reply-mode
 221                (function gnus-inews-news))
 222     )))
 223
 224
 225 ;;; @ for mime.el
 226 ;;;
 227
 228 ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 229 ;;;
 230 ;;; Please use following setting:
 231 ;;;     (setq gnus-mail-forward-method
 232 ;;;           (function gnus-mail-forward-using-mhe-mime))
 233
 234 (defun gnus-mail-forward-using-mhe-mime (&optional buffer)
 235   "Forward the current message to another user using mh-e with mime-mode."
 236   ;; First of all, prepare mhe mail buffer.
 237   (let* ((to (read-string "To: "))
 238          (cc (read-string "Cc: "))
 239          (buffer (or buffer gnus-clean-article-buffer))
 240          (config (current-window-configuration));; need to add this - erik
 241          (subject (gnus-forward-make-subject buffer)))
 242     (setq mh-show-buffer buffer)
 243     (mh-find-path)
 244     (mh-send-sub to (or cc "") (or subject "(None)") config);; Erik Selberg 1/23/94
 245     (let ((draft (current-buffer))
 246           (gnus-mail-buffer (current-buffer))
 247           mail-buf)
 248       (gnus-configure-windows 'reply-yank)
 249       (setq mail-buf (eval (cdr (assq 'mail gnus-window-to-buffer))))
 250       (pop-to-buffer mail-buf);; always in the display, so won't have window probs
 251       (switch-to-buffer draft)
 252       )
 253     (save-excursion
 254       (goto-char (point-max))
 255       (insert (concat (mime-make-tag "message" "rfc822" nil "7bit") "\n"))
 256       (insert-buffer buffer)
 257       (setq mh-sent-from-folder buffer)
 258       (setq mh-sent-from-msg 1)
 259       (setq mh-previous-window-config config)
 260       (run-hooks 'gnus-mail-hook)
 261       )))
 262
 263
 264 ;;; @ end
 265 ;;;
 266
 267 (provide 'tm-gnus5)