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