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.19 1995/09/02 05:18:08 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
 109           (function
 110            (lambda ()
 111              (let (buffer-read-only)
 112                (mime/decode-message-header)
 113                ))))
 114
 115
 116 ;;; @ automatic MIME preview support
 117 ;;;
 118
 119 (defun tm-gnus/summary-toggle-header (&optional arg)
 120   (interactive "P")
 121   (if tm-gnus/decode-all
 122       (let ((mime-viewer/ignored-field-list
 123              (if (save-window-excursion
 124                    (switch-to-buffer tm-gnus/preview-buffer)
 125                    (some-element
 126                     (function
 127                      (lambda (field)
 128                        (message/get-field-body field)
 129                        ))
 130                     mime-viewer/ignored-field-list))
 131                  mime-viewer/ignored-field-list)))
 132         (gnus-summary-select-article t t)
 133         )
 134     (gnus-summary-toggle-header arg)
 135     ))
 136
 137 (defun tm-gnus/set-mime-method (mode)
 138   (if mode
 139       (progn
 140         (setq gnus-show-mime nil)
 141         (setq gnus-article-display-hook
 142               (list (function (lambda ()
 143                                 (mime/viewer-mode)
 144                                 (gnus-set-mode-line 'article)
 145                                 ))))
 146         (set-alist 'gnus-window-to-buffer 'article tm-gnus/preview-buffer)
 147         (setq gnus-article-buffer tm-gnus/preview-buffer)
 148         )
 149     (setq gnus-show-mime t)
 150     (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 151     (set-alist 'gnus-window-to-buffer 'article gnus-clean-article-buffer)
 152     (setq gnus-article-buffer gnus-clean-article-buffer)
 153     ))
 154
 155 (defun tm-gnus/toggle-mime (arg)
 156   "Toggle MIME processing mode.
 157 With arg, turn MIME processing on if arg is positive."
 158   (interactive "P")
 159   (setq tm-gnus/decode-all
 160         (if (null arg)
 161             (not tm-gnus/decode-all)
 162           arg))
 163   (gnus-set-global-variables)
 164   (tm-gnus/set-mime-method tm-gnus/decode-all)
 165   (gnus-summary-select-article gnus-show-all-headers 'force)
 166   )
 167
 168 (if tm-gnus/automatic-MIME-preview-support
 169     (progn
 170       (define-key gnus-summary-mode-map
 171         "t" (function tm-gnus/summary-toggle-header))
 172       (define-key gnus-summary-mode-map "\et" (function tm-gnus/toggle-mime))
 173
 174       (tm-gnus/set-mime-method tm-gnus/decode-all)
 175
 176       (add-hook 'gnus-exit-gnus-hook
 177                 (function
 178                  (lambda ()
 179                    (let ((buf (get-buffer tm-gnus/preview-buffer)))
 180                      (if buf
 181                          (kill-buffer buf)
 182                        )))))
 183       )
 184   (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 185   (setq gnus-show-mime t)
 186   )
 187
 188
 189 ;;; @ for tm-comp
 190 ;;;
 191
 192 (call-after-loaded
 193  'tm-comp
 194  (function
 195   (lambda ()
 196     (set-alist 'mime/message-sender-alist
 197                'news-reply-mode
 198                (function gnus-inews-news))
 199     )))
 200
 201
 202 ;;; @ end
 203 ;;;
 204
 205 (provide 'tm-gnus5)