gnus/tm-dgnus.el

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