gnus/tm-gnus5.el

   1 ;;;
   2 ;;; tm-gnus5.el --- tm-gnus module for GNUS 5.*
   3 ;;;
   4
   5 (require 'tl-str)
   6 (require 'tl-list)
   7 (require 'gnus)
   8
   9
  10 ;;; @ version
  11 ;;;
  12
  13 (defconst tm-gnus/RCS-ID
  14   "$Id: tm-gnus5.el,v 6.20 1995/09/04 10:53:07 morioka Exp $")
  15
  16 (defconst tm-gnus/version
  17   (concat (get-version-string tm-gnus/RCS-ID) " for GNUS 5"))
  18
  19 (defconst tm-gnus/automatic-MIME-preview-support
  20   (cond ((boundp 'gnus-clean-article-buffer)
  21          (defconst gnus-version (concat gnus-version " with tm patch"))
  22          t)
  23         (t
  24          (defvar gnus-clean-article-buffer gnus-article-buffer)
  25          nil)
  26         ))
  27
  28 (defvar tm-gnus/preview-buffer
  29   (if tm-gnus/automatic-MIME-preview-support
  30       (concat "*Preview-" gnus-clean-article-buffer "*"))
  31   )
  32
  33
  34 ;;; @ autoload
  35 ;;;
  36
  37 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  38 (autoload 'mime/decode-message-header
  39   "tiny-mime" "Decode MIME encoded-word." t)
  40 (autoload 'mime/decode-string "tiny-mime" "Decode MIME encoded-word." t)
  41
  42
  43 ;;; @ variables
  44 ;;;
  45
  46 (defvar tm-gnus/original-article-display-hook gnus-article-display-hook)
  47
  48 (defvar tm-gnus/decode-all tm-gnus/automatic-MIME-preview-support
  49   "If it is non-nil and
  50 tm-gnus/automatic-MIME-preview-support is non-nil,
  51 article is automatic MIME decoded.")
  52
  53
  54 ;;; @ command functions
  55 ;;;
  56
  57 (defun tm-gnus/view-message (arg)
  58   "MIME decode and play this message."
  59   (interactive "P")
  60   (let ((gnus-break-pages nil))
  61     (gnus-summary-select-article t t)
  62     )
  63   (pop-to-buffer gnus-clean-article-buffer t)
  64   (let (buffer-read-only)
  65     (if (text-property-any (point-min) (point-max) 'invisible t)
  66         (remove-text-properties (point-min) (point-max)
  67                                 gnus-hidden-properties)
  68       ))
  69   (mime/viewer-mode)
  70   )
  71
  72 (defun tm-gnus/summary-scroll-down ()
  73   "Scroll down one line current article."
  74   (interactive)
  75   (gnus-summary-scroll-up -1)
  76   )
  77
  78 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
  79 (define-key gnus-summary-mode-map
  80   "\e\r" (function tm-gnus/summary-scroll-down))
  81
  82
  83 ;;; @ summary filter
  84 ;;;
  85
  86 (defun tm-gnus/decode-summary-from-and-subjects ()
  87   (mapcar (function
  88            (lambda (header)
  89              (mail-header-set-from
  90               header
  91               (mime/decode-string (or (mail-header-from header) ""))
  92               )
  93              (mail-header-set-subject
  94               header
  95               (mime/decode-string (or (mail-header-subject header) ""))
  96               )
  97              ))
  98           gnus-newsgroup-headers)
  99   )
 100
 101 (add-hook 'gnus-select-group-hook
 102           (function tm-gnus/decode-summary-from-and-subjects))
 103
 104
 105 ;;; @ article filter
 106 ;;;
 107
 108 (setq gnus-show-mime-method (function mime/decode-message-header))
 109
 110
 111 ;;; @ automatic MIME preview support
 112 ;;;
 113
 114 (defun tm-gnus/summary-toggle-header (&optional arg)
 115   (interactive "P")
 116   (if tm-gnus/decode-all
 117       (let ((mime-viewer/ignored-field-list
 118              (if (save-window-excursion
 119                    (switch-to-buffer tm-gnus/preview-buffer)
 120                    (some-element
 121                     (function
 122                      (lambda (field)
 123                        (message/get-field-body field)
 124                        ))
 125                     mime-viewer/ignored-field-list))
 126                  mime-viewer/ignored-field-list)))
 127         (gnus-summary-select-article t t)
 128         )
 129     (gnus-summary-toggle-header arg)
 130     ))
 131
 132 (defun tm-gnus/set-mime-method (mode)
 133   (if mode
 134       (progn
 135         (setq gnus-show-mime nil)
 136         (setq gnus-article-display-hook
 137               (list (function (lambda ()
 138                                 (mime/viewer-mode)
 139                                 (gnus-set-mode-line 'article)
 140                                 ))))
 141         (set-alist 'gnus-window-to-buffer 'article tm-gnus/preview-buffer)
 142         (setq gnus-article-buffer tm-gnus/preview-buffer)
 143         )
 144     (setq gnus-show-mime t)
 145     (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 146     (set-alist 'gnus-window-to-buffer 'article gnus-clean-article-buffer)
 147     (setq gnus-article-buffer gnus-clean-article-buffer)
 148     ))
 149
 150 (defun tm-gnus/toggle-mime (arg)
 151   "Toggle MIME processing mode.
 152 With arg, turn MIME processing on if arg is positive."
 153   (interactive "P")
 154   (setq tm-gnus/decode-all
 155         (if (null arg)
 156             (not tm-gnus/decode-all)
 157           arg))
 158   (gnus-set-global-variables)
 159   (tm-gnus/set-mime-method tm-gnus/decode-all)
 160   (gnus-summary-select-article gnus-show-all-headers 'force)
 161   )
 162
 163 (if tm-gnus/automatic-MIME-preview-support
 164     (progn
 165       (define-key gnus-summary-mode-map
 166         "t" (function tm-gnus/summary-toggle-header))
 167       (define-key gnus-summary-mode-map "\et" (function tm-gnus/toggle-mime))
 168
 169       (tm-gnus/set-mime-method tm-gnus/decode-all)
 170
 171       (add-hook 'gnus-exit-gnus-hook
 172                 (function
 173                  (lambda ()
 174                    (let ((buf (get-buffer tm-gnus/preview-buffer)))
 175                      (if buf
 176                          (kill-buffer buf)
 177                        )))))
 178       )
 179   (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 180   (setq gnus-show-mime t)
 181   )
 182
 183
 184 ;;; @ for tm-comp
 185 ;;;
 186
 187 (call-after-loaded
 188  'tm-comp
 189  (function
 190   (lambda ()
 191     (set-alist 'mime/message-sender-alist
 192                'news-reply-mode
 193                (function gnus-inews-news))
 194     )))
 195
 196
 197 ;;; @ end
 198 ;;;
 199
 200 (provide 'tm-gnus5)