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.9 1995/07/03 07:50:58 morioka Exp $")
  14
  15 (defconst tm-gnus/version
  16   (concat (get-version-string tm-gnus/RCS-ID) " (ding)"))
  17
  18
  19 ;;; @ autoload
  20 ;;;
  21
  22 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  23 (autoload 'mime/decode-message-header
  24   "tiny-mime" "Decode MIME encoded-word." t)
  25 (autoload 'mime/decode-string "tiny-mime" "Decode MIME encoded-word." t)
  26
  27
  28 ;;; @ variables
  29 ;;;
  30
  31 (defvar tm-gnus/original-article-display-hook gnus-article-display-hook)
  32
  33 (defvar tm-gnus/decode-all t)
  34
  35 (defvar tm-gnus/preview-buffer (concat "*Preview-" gnus-article-buffer "*"))
  36
  37
  38 ;;; @ command functions
  39 ;;;
  40
  41 (defun tm-gnus/view-message (arg)
  42   "MIME decode and play this message."
  43   (interactive "P")
  44   (let ((gnus-break-pages nil))
  45     (gnus-summary-select-article t t)
  46     )
  47   (pop-to-buffer gnus-article-buffer t)
  48   (let (buffer-read-only)
  49     (if (text-property-any (point-min) (point-max) 'invisible t)
  50         (remove-text-properties (point-min) (point-max)
  51                                 gnus-hidden-properties)
  52       ))
  53   (mime/viewer-mode)
  54   )
  55
  56 (defun tm-gnus/summary-scroll-down ()
  57   "Scroll down one line current article."
  58   (interactive)
  59   (gnus-summary-scroll-up -1)
  60   )
  61
  62 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
  63 (define-key gnus-summary-mode-map
  64   "\e\r" (function tm-gnus/summary-scroll-down))
  65 (define-key gnus-summary-mode-map "\et" (function tm-gnus/toggle-mime))
  66
  67 (defmacro gnus-get-article-buffer ()
  68   (` (cdr (assq 'article gnus-window-to-buffer))))
  69
  70 ;; Set article window start at LINE, where LINE is the number of lines
  71 ;; from the head of the article.
  72 (defun gnus-article-set-window-start (&optional line)
  73   (let ((article-buffer (gnus-get-article-buffer)))
  74     (set-window-start
  75      (get-buffer-window article-buffer)
  76      (save-excursion
  77        (set-buffer article-buffer)
  78        (goto-char (point-min))
  79        (if (not line)
  80            (point-min)
  81          (gnus-message 6 "Moved to bookmark")
  82          (search-forward "\n\n" nil t)
  83          (forward-line line)
  84          (point))))))
  85
  86 (defun gnus-summary-next-page (lines)
  87   "Show next page of selected article.
  88 If end of article, select next article.
  89 Argument LINES specifies lines to be scrolled up."
  90   (interactive "P")
  91   (let ((article (gnus-summary-article-number))
  92         (endp nil))
  93     (if (or (null gnus-current-article)
  94             (/= article gnus-current-article))
  95         ;; Selected subject is different from current article's.
  96         (gnus-summary-display-article article)
  97       (gnus-configure-windows 'article)
  98       (pop-to-buffer gnus-summary-buffer)
  99       (gnus-eval-in-buffer-window
 100        (gnus-get-article-buffer)
 101        (setq endp (gnus-article-next-page lines)))
 102       (cond ((and endp lines)
 103              (message "End of message"))
 104             ((and endp (null lines))
 105              (gnus-summary-next-unread-article)))
 106       )))
 107
 108 (defun gnus-summary-prev-page (lines)
 109   "Show previous page of selected article.
 110 Argument LINES specifies lines to be scrolled down."
 111   (interactive "P")
 112   (gnus-set-global-variables)
 113   (let ((article (gnus-summary-article-number)))
 114     (gnus-configure-windows 'article)
 115     (if (or (null gnus-current-article)
 116             (null gnus-article-current)
 117             (/= article (cdr gnus-article-current))
 118             (not (equal (car gnus-article-current) gnus-newsgroup-name)))
 119         ;; Selected subject is different from current article's.
 120         (gnus-summary-display-article article)
 121       (gnus-summary-recenter)
 122       (gnus-eval-in-buffer-window
 123        (gnus-get-article-buffer)
 124        (gnus-article-prev-page lines))))
 125   (gnus-summary-position-cursor))
 126
 127 (defun gnus-summary-scroll-up (lines)
 128   "Scroll up (or down) one line current article.
 129 Argument LINES specifies lines to be scrolled up (or down if negative)."
 130   (interactive "p")
 131   (gnus-set-global-variables)
 132   (gnus-configure-windows 'article)
 133   (or (gnus-summary-select-article nil nil 'pseudo)
 134       (gnus-eval-in-buffer-window
 135        (gnus-get-article-buffer)
 136        (cond ((> lines 0)
 137               (if (gnus-article-next-page lines)
 138                   (gnus-message 3 "End of message")))
 139              ((< lines 0)
 140               (gnus-article-prev-page (- lines))))))
 141   (gnus-summary-recenter)
 142   (gnus-summary-position-cursor))
 143
 144 (defun gnus-summary-toggle-header (arg)
 145   "Show the headers if they are hidden, or hide them if they are shown.
 146 If ARG is a positive number, show the entire header.
 147 If ARG is a negative number, hide the unwanted header lines."
 148   (interactive "P")
 149   (gnus-set-global-variables)
 150   (save-excursion
 151     (set-buffer (gnus-get-article-buffer))
 152     (let ((buffer-read-only nil))
 153       (if (numberp arg)
 154           (if (> arg 0) (remove-text-properties (point-min) (point-max)
 155                                                 gnus-hidden-properties)
 156             (if (< arg 0) (run-hooks 'gnus-article-display-hook)))
 157         (if (text-property-any (point-min) (point-max) 'invisible t)
 158             (if tm-gnus/decode-all
 159                 (let (mime-viewer/ignored-field-list)
 160                   (run-hooks 'gnus-article-display-hook)
 161                   )
 162               (remove-text-properties (point-min) (point-max)
 163                                       gnus-hidden-properties)
 164               )
 165           (let (gnus-have-all-headers)
 166             (run-hooks 'gnus-article-display-hook)
 167             ))
 168         )
 169       (pop-to-buffer gnus-summary-buffer)
 170       (set-window-point (get-buffer-window (current-buffer)) (point-min)))))
 171
 172
 173 ;;; @ summary filter
 174 ;;;
 175
 176 (defun tm-gnus/decode-summary-from-and-subjects ()
 177   (mapcar (function
 178            (lambda (header)
 179              (header-set-from
 180               header
 181               (mime/decode-string (or (header-from header) ""))
 182               )
 183              (header-set-subject
 184               header
 185               (mime/decode-string (or (header-subject header) ""))
 186               )
 187              ))
 188           gnus-newsgroup-headers)
 189   )
 190
 191 (add-hook 'gnus-select-group-hook
 192           (function tm-gnus/decode-summary-from-and-subjects))
 193
 194
 195 ;;; @ article filter
 196 ;;;
 197
 198 (setq gnus-show-mime-method
 199           (function
 200            (lambda ()
 201              (let (buffer-read-only)
 202                (mime/decode-message-header)
 203                ))))
 204
 205 (defun tm-gnus/set-mime-method (mode)
 206   (if mode
 207       (progn
 208         (setq gnus-show-mime nil)
 209         (setq gnus-article-display-hook
 210               (list (function (lambda ()
 211                                 (mime/viewer-mode)
 212                                 (gnus-set-mode-line 'article)
 213                                 (set-buffer-modified-p nil)
 214                                 (pop-to-buffer mime::preview/article-buffer)
 215                                 ))))
 216         (set-alist 'gnus-window-to-buffer 'article tm-gnus/preview-buffer)
 217         )
 218     (setq gnus-show-mime t)
 219     (setq gnus-article-display-hook tm-gnus/original-article-display-hook)
 220     (set-alist 'gnus-window-to-buffer 'article gnus-article-buffer)
 221     ))
 222
 223 (tm-gnus/set-mime-method tm-gnus/decode-all)
 224
 225 (defun tm-gnus/toggle-mime (arg)
 226   "Toggle MIME processing mode.
 227 With arg, turn MIME processing on if arg is positive."
 228   (interactive "P")
 229   (setq tm-gnus/decode-all
 230         (if (null arg)
 231             (not tm-gnus/decode-all)
 232           arg))
 233   (gnus-set-global-variables)
 234   (tm-gnus/set-mime-method tm-gnus/decode-all)
 235   (gnus-summary-select-article gnus-show-all-headers 'force)
 236   )
 237
 238
 239 ;;; @ etc
 240 ;;;
 241
 242 (add-hook 'gnus-exit-gnus-hook
 243           (function
 244            (lambda ()
 245              (let ((buf (get-buffer tm-gnus/preview-buffer)))
 246                (if buf
 247                    (kill-buffer buf)
 248                  )))))
 249
 250
 251 ;;; @ end
 252 ;;;
 253
 254 (provide 'tm-dgnus)