gnus/tm-gnus4.el

   1 ;;;
   2 ;;; tm-gnus4.el --- tm-gnus module for GNUS 4.*
   3 ;;;
   4
   5 (require 'tl-str)
   6 (require 'tm-ognus)
   7
   8
   9 ;;; @ version
  10 ;;;
  11
  12 (defconst tm-gnus/RCS-ID
  13   "$Id: tm-gnus4.el,v 6.8 1995/09/05 01:10:25 morioka Exp $")
  14
  15 (defconst tm-gnus/version
  16   (concat (get-version-string tm-gnus/RCS-ID) " for GNUS 4"))
  17
  18
  19 ;;; @ for tm-view
  20 ;;;
  21
  22 (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  23
  24 (defun tm-gnus/view-message (arg)
  25   "MIME decode and play this message."
  26   (interactive "P")
  27   (let ((gnus-break-pages nil))
  28     (gnus-summary-select-article t t)
  29     )
  30   (pop-to-buffer gnus-article-buffer t)
  31   (mime/viewer-mode)
  32   )
  33
  34 (defun tm-gnus/summary-scroll-down ()
  35   "Scroll down one line current article."
  36   (interactive)
  37   (gnus-summary-scroll-up -1)
  38   )
  39
  40 (defun mime-viewer/quitting-method-for-gnus4 ()
  41   (mime-viewer/kill-buffer)
  42   (delete-other-windows)
  43   (gnus-article-show-summary)
  44   (if (null gnus-have-all-headers)
  45       (gnus-summary-select-article nil t)
  46     ))
  47
  48 (call-after-loaded
  49  'tm-view
  50  (function
  51   (lambda ()
  52     (set-alist 'mime-viewer/quitting-method-alist
  53                'gnus-article-mode
  54                (function mime-viewer/quitting-method-for-gnus4))
  55     )))
  56
  57
  58 ;;; @ Summary decoding
  59 ;;;
  60
  61 (add-hook 'gnus-select-group-hook (function tm-gnus/decode-summary-subjects))
  62
  63
  64 ;;; @ set up
  65 ;;;
  66
  67 (define-key gnus-summary-mode-map
  68   "\et" (function tm-gnus/toggle-decoding-mode))
  69 (define-key gnus-summary-mode-map "v" (function tm-gnus/view-message))
  70 (define-key gnus-summary-mode-map
  71   "\e\r" (function tm-gnus/summary-scroll-down))
  72
  73 (fset 'gnus-article-set-mode-line 'tm-gnus/article-set-mode-line)
  74 (add-hook 'gnus-article-mode-hook
  75           (function tm-gnus/add-decoding-mode-to-mode-line))
  76
  77 (defun tm-gnus/decode-encoded-word-if-you-need ()
  78   (if (and tm-gnus/decoding-mode (not gnus-have-all-headers))
  79       (mime/decode-message-header)
  80     ))
  81
  82 (add-hook 'gnus-article-prepare-hook
  83           (function tm-gnus/decode-encoded-word-if-you-need) t)
  84
  85
  86 ;;; @ for tm-comp
  87 ;;;
  88
  89 (defun tm-gnus4/message-before-send ()
  90   (let ((case-fold-search nil))
  91     (or (boundp 'mime/news-reply-mode-server-running)
  92         (make-variable-buffer-local 'mime/news-reply-mode-server-running))
  93     (setq mime/news-reply-mode-server-running (gnus-server-opened))
  94     (save-excursion
  95       (gnus-start-news-server)
  96       (widen)
  97       (goto-char (point-min))
  98       (run-hooks 'news-inews-hook)
  99       (save-restriction
 100         (narrow-to-region
 101          (point-min)
 102          (progn
 103            (goto-char (point-min))
 104            (search-forward (concat "\n" mail-header-separator "\n"))
 105            (point)))
 106
 107         (goto-char (point-min))
 108         (if (search-forward-regexp "^Newsgroups: +" nil t)
 109             (save-restriction
 110               (narrow-to-region
 111                (point)
 112                (if (re-search-forward "^[^ \t]" nil 'end)
 113                    (match-beginning 0)
 114                  (point-max)))
 115               (goto-char (point-min))
 116               (replace-regexp "\n[ \t]+" " ")
 117               (goto-char (point-min))
 118               (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")
 119               ))
 120         ))))
 121
 122 (defun tm-gnus4/message-sender ()
 123   (interactive)
 124   (widen)
 125   (goto-char (point-min))
 126   (save-restriction
 127     (narrow-to-region
 128      (point-min)
 129      (progn
 130        (goto-char (point-min))
 131        (search-forward (concat "\n" mail-header-separator "\n"))
 132        (point)))
 133     ;; Mail the message too if To: or Cc: exists.
 134     (if (or (mail-fetch-field "to" nil t)
 135             (mail-fetch-field "cc" nil t))
 136         (if gnus-mail-send-method
 137             (progn
 138               (message
 139                (format "Sending (%d/%d) via mail..." (+ i 1) total))
 140               (widen)
 141               (funcall gnus-mail-send-method)
 142               (message
 143                (format "Sending (%d/%d) via mail... done" (+ i 1) total))
 144               (ding)
 145               (message
 146                "No mailer defined.  To: and/or Cc: fields ignored.")
 147               (sit-for 1)))))
 148   (message
 149    (format "Posting %d/%d to USENET..." (+ i 1) total))
 150   (if (gnus-inews-article)
 151       (message
 152        (format "Posting %d/%d to USENET... done" (+ i 1) total))
 153     ;; We cannot signal an error.
 154     (ding)
 155     (message
 156      (format "Article %d/%d rejected: %s"
 157              (+ i 1) total (gnus-status-message)))
 158     (sit-for 3))
 159   )
 160
 161 (defun tm-gnus4/message-after-send ()
 162   (or mime/news-reply-mode-server-running
 163       (gnus-close-server))
 164   (and (fboundp 'bury-buffer) (bury-buffer))
 165   )
 166
 167 (call-after-loaded
 168  'tm-comp
 169  (function
 170   (lambda ()
 171     (set-alist 'mime/message-before-send-hook-alist
 172                'news-reply-mode
 173                (function tm-gnus4/message-before-send))
 174     (set-alist 'mime/message-sender-alist
 175                'news-reply-mode
 176                (function tm-gnus4/message-sender))
 177     (set-alist 'mime/message-after-send-hook-alist
 178                'news-reply-mode
 179                (function tm-gnus4/message-after-send))
 180     )))
 181
 182
 183 ;;; @ end
 184 ;;;
 185
 186 (provide 'tm-gnus4)