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.21 1995/09/07 17:07:41 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 ;;; @ for tm-view
  84 ;;;
  85
  86 (defun mime-viewer/quitting-method-for-gnus5 ()
  87   (mime-viewer/kill-buffer)
  88   (delete-other-windows)
  89   (gnus-article-show-summary)
  90   (gnus-summary-display-article (gnus-summary-article-number))
  91   )
  92
  93 (call-after-loaded
  94  'tm-view
  95  (function
  96   (lambda ()
  97     (set-alist 'mime-viewer/quitting-method-alist
  98                'gnus-article-mode
  99                (function mime-viewer/quitting-method-for-gnus5))
 100     )))
 101
 102
 103 ;;; @ summary filter
 104 ;;;
 105
 106 (defun tm-gnus/decode-summary-from-and-subjects ()
 107   (mapcar (function
 108            (lambda (header)
 109              (mail-header-set-from
 110               header
 111               (mime/decode-string (or (mail-header-from header) ""))
 112               )
 113              (mail-header-set-subject
 114               header
 115               (mime/decode-string (or (mail-header-subject header) ""))
 116               )
 117              ))
 118           gnus-newsgroup-headers)
 119   )
 120
 121 (add-hook 'gnus-select-group-hook
 122           (function tm-gnus/decode-summary-from-and-subjects))
 123
 124
 125 ;;; @ article filter
 126 ;;;
 127
 128 (setq gnus-show-mime-method (function mime/decode-message-header))
 129
 130
 131 ;;; @ automatic MIME preview support
 132 ;;;
 133
 134 (defun tm-gnus/summary-toggle-header (&optional arg)
 135   (interactive "P")
 136   (if tm-gnus/decode-all
 137       (let ((mime-viewer/ignored-field-list
 138              (if (save-window-excursion
 139                    (switch-to-buffer tm-gnus/preview-buffer)
 140                    (some-element
 141                     (function
 142                      (lambda (field)
 143                        (message/get-field-body field)
 144                        ))
 145                     mime-viewer/ignored-field-list))
 146                  mime-viewer/ignored-field-list)))
 147         (gnus-summary-select-article t t)
 148         )
 149     (gnus-summary-toggle-header arg)
 150     ))
 151
 152 (defun tm-gnus/set-mime-method (mode)
 153   (if mode
 154       (progn
 155         (setq gnus-show-mime nil)
 156         (setq gnus-article-display-hook
 157               (list (function (lambda ()
 158                                 (mime/viewer-mode)
 159                                 (gnus-set-mode-line 'article)
 160                                 ))))
 161         (set-alist 'gnus-window-to-buffer 'article tm-gnus/preview-buffer)
 162         (setq gnus-article-buffer tm-gnus/preview-buffer)
 163         )
 164     (setq gnus-show-mime t)
 165     (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 166     (set-alist 'gnus-window-to-buffer 'article gnus-clean-article-buffer)
 167     (setq gnus-article-buffer gnus-clean-article-buffer)
 168     ))
 169
 170 (defun tm-gnus/toggle-mime (arg)
 171   "Toggle MIME processing mode.
 172 With arg, turn MIME processing on if arg is positive."
 173   (interactive "P")
 174   (setq tm-gnus/decode-all
 175         (if (null arg)
 176             (not tm-gnus/decode-all)
 177           arg))
 178   (gnus-set-global-variables)
 179   (tm-gnus/set-mime-method tm-gnus/decode-all)
 180   (gnus-summary-select-article gnus-show-all-headers 'force)
 181   )
 182
 183 (if tm-gnus/automatic-MIME-preview-support
 184     (progn
 185       (define-key gnus-summary-mode-map
 186         "t" (function tm-gnus/summary-toggle-header))
 187       (define-key gnus-summary-mode-map "\et" (function tm-gnus/toggle-mime))
 188
 189       (tm-gnus/set-mime-method tm-gnus/decode-all)
 190
 191       (add-hook 'gnus-exit-gnus-hook
 192                 (function
 193                  (lambda ()
 194                    (let ((buf (get-buffer tm-gnus/preview-buffer)))
 195                      (if buf
 196                          (kill-buffer buf)
 197                        )))))
 198       )
 199   (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 200   (setq gnus-show-mime t)
 201   )
 202
 203
 204 ;;; @ for tm-comp
 205 ;;;
 206
 207 (call-after-loaded
 208  'tm-comp
 209  (function
 210   (lambda ()
 211     (set-alist 'mime/message-sender-alist
 212                'news-reply-mode
 213                (function gnus-inews-news))
 214     )))
 215
 216
 217 ;;; @ end
 218 ;;;
 219
 220 (provide 'tm-gnus5)