gnus/tm-gnus4.el

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