cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/contrib/mew-gnus.el

   1 ;; mew-gnus.el
   2 ;;
   3 ;; Temporary solution to link Mew to Gnus.
   4 ;; This code will be obsolated because Mew supports USENET news soon.
   5 ;;
   6 ;; To use mew-gnus.el, put the following codes in your .emacs.
   7 ;;
   8 ;;   (add-hook
   9 ;;    'gnus-group-mode-hook
  10 ;;    (function
  11 ;;     (lambda ()
  12 ;;       (require 'mew-gnus)
  13 ;;       (define-key gnus-group-mode-map "a" 'mew-gnus-post-news))))
  14 ;;
  15 ;;   (add-hook
  16 ;;    'gnus-summary-mode-hook
  17 ;;    (function
  18 ;;     (lambda ()
  19 ;;       (define-key gnus-summary-mode-map "a" 'mew-gnus-post-news)
  20 ;;       (define-key gnus-summary-mode-map "r" 'mew-gnus-reply)
  21 ;;       (define-key gnus-summary-mode-map "R" 'mew-gnus-reply-with-citation)
  22 ;;       (define-key gnus-summary-mode-map "f" 'mew-gnus-mail-forward))))
  23 ;;
  24 ;;   (setq gnus-default-article-saver 'gnus-summary-save-in-mew)
  25 ;;
  26
  27 (eval-when-compile
  28   (require 'gnus)
  29   (if (not (or (string-match "^GNUS [34]" gnus-version)
  30                (string-match "^Gnus v5.0" gnus-version)
  31                (string-match "^5.[0-3]" gnus-version-number)))
  32       (require 'gnus-sum)))
  33
  34 (require 'mew)
  35
  36 (defvar mew-prog-imstore "imstore")
  37 (defvar mew-prog-imstore-arg "--dst=%s")
  38 ;(defvar mew-prog-imstore "/usr/local/lib/mh/rcvstore")
  39 ;(defvar mew-prog-imstore-arg "%s")
  40
  41 (defvar mew-gnus-save-fixed-folder nil
  42   "*If specified, always use it as a candidate to save article.")
  43
  44 (defvar mew-gnus-save-preserve-dot t
  45   "*If nil, use hierarchical directory to save article.")
  46
  47 (defvar mew-gnus-save-news-folder nil
  48   "*If non-nil, use news folder as a default candicate to save an article.")
  49
  50 (defun mew-gnus-newsgroup-name ()
  51   (if mew-gnus-save-preserve-dot
  52       gnus-newsgroup-name
  53     (gnus-newsgroup-directory-form gnus-newsgroup-name)))
  54
  55 (defun gnus-summary-save-in-mew (&optional folder)
  56   "Save this article to Mail or News folder (using `imstore').
  57 Optional argument FOLDER specifies folder name."
  58   (interactive)
  59   (mew-gnus-init)
  60   (let ((gnus-show-mime nil)
  61         (gnus-article-display-hook nil))
  62     (gnus-summary-select-article t t))  ;; force to display all headers
  63   (gnus-eval-in-buffer-window gnus-article-buffer
  64     (save-restriction
  65       (widen)
  66       (or mew-folder-alist
  67           (setq mew-folder-list (mew-folder-make-list nil)
  68                 mew-folder-alist (mew-folder-make-alist mew-folder-list)))
  69       (let ((folder
  70              (or folder
  71                  (mew-input-folder
  72                   (or mew-gnus-save-fixed-folder
  73                       (car (mew-refile-guess-by-alist))
  74                       (concat (if mew-gnus-save-news-folder "=" "+")
  75                               (mew-gnus-newsgroup-name))))))
  76             (errbuf (get-buffer-create " *GNUS imstore*")))
  77         (if (not (memq (aref folder 0) '(?+ ?=)))
  78             (message (format
  79                       "First letter of '%s' must be '+' or '='."
  80                       folder))
  81           (if (mew-folder-check folder)
  82               (unwind-protect
  83                   (mew-piolet
  84                    mew-cs-infile mew-cs-outfile
  85                    (call-process-region (point-min) (point-max)
  86                                         mew-prog-imstore nil errbuf nil
  87                                         (format mew-prog-imstore-arg folder)))
  88                 (set-buffer errbuf)
  89                 (if (zerop (buffer-size))
  90                     (message "Article saved in folder: %s" folder)
  91                   (message "%s" (buffer-string)))
  92                 (kill-buffer errbuf))))))))
  93
  94 (defun mew-gnus-init ()
  95   "Initialize mew if mew does not invoked yet."
  96   (if mew-mail-path
  97       nil
  98     (mew-init)
  99     (if (get-buffer mew-buffer-hello)
 100         (kill-buffer mew-buffer-hello))))
 101
 102 (defun mew-gnus-post-news ()
 103   "Post a news using mew."
 104   (interactive)
 105   (mew-gnus-init)
 106   (let ((file (mew-folder-new-message mew-draft-folder)))
 107     (mew-summary-prepare-draft
 108      (mew-current-set 'window (current-window-configuration))
 109      (delete-other-windows)
 110      (switch-to-buffer (find-file-noselect file))
 111      (mew-draft-rename file)
 112      (mew-draft-header nil nil 'no nil "")
 113      (goto-char (point-min))
 114      (search-forward "Newsgroups: ")
 115      (mew-draft-mode)
 116      (run-hooks 'mew-draft-mode-newdraft-hook))))
 117
 118 (defun mew-gnus-reply (&optional yank)
 119   "Reply or followup to GNUS article using mew.
 120 Optional argument YANK means yank original article."
 121   (interactive)
 122   (mew-gnus-init)
 123   (let ((file (mew-folder-new-message mew-draft-folder))
 124         from cc subject to reply-to newsgroups in-reply-to references
 125         distribution)
 126     (mew-summary-prepare-draft
 127      (mew-current-set 'window (current-window-configuration))
 128      (delete-other-windows)
 129      (gnus-summary-display-article (gnus-summary-article-number) t) ;;redisplay
 130      (pop-to-buffer gnus-article-buffer)
 131      (goto-char (point-max))
 132      (push-mark (point) t t)
 133      (goto-char (point-min))
 134      (search-forward "\n\n" nil t)
 135      (let ((split-window-keep-point t))
 136        (split-window-vertically))
 137
 138      (setq from (mew-addrstr-parse-address-list (gnus-fetch-field "From"))
 139            subject (let ((subject (gnus-fetch-field "Subject")))
 140                      (if (and subject
 141                               (not (string-match "^[Rr][Ee]:.+$" subject)))
 142                          (concat "Re: " subject) subject))
 143            reply-to (gnus-fetch-field "Reply-to")
 144            to (or reply-to from)
 145            cc (gnus-fetch-field "Cc")
 146            newsgroups (or (gnus-fetch-field "Followup-To")
 147                           (gnus-fetch-field "Newsgroups"))
 148            distribution (gnus-fetch-field "Distribution"))
 149
 150      ;; see comments at mew-summary-reply() function
 151      (let ((old-message-id  (gnus-fetch-field "Message-Id"))
 152            (old-in-reply-to (gnus-fetch-field "In-Reply-To"))
 153            (old-references  (gnus-fetch-field "References"))
 154            (regex "<[^>]+>")
 155            (start 0) tmp-ref skip)
 156        (if (and old-message-id (string-match regex old-message-id))
 157            (setq old-message-id (mew-match 0 old-message-id))
 158          (setq old-message-id nil))
 159        (if (and old-in-reply-to (string-match regex old-in-reply-to))
 160            (setq old-in-reply-to (mew-match 0 old-in-reply-to))
 161          (setq old-in-reply-to nil))
 162        (if (null old-message-id)
 163            () ;; we don't care even if old-references exist.
 164          (setq in-reply-to old-message-id)
 165          (if (null old-references)
 166              (setq tmp-ref (if old-in-reply-to
 167                                (list old-in-reply-to old-message-id)
 168                              (list old-message-id)))
 169            (while (string-match "<[^>]+>" old-references start)
 170              (setq start (match-end 0))
 171              (setq tmp-ref (cons (mew-match 0 old-references) tmp-ref)))
 172            (if (and old-in-reply-to (not (member old-in-reply-to tmp-ref)))
 173                (setq tmp-ref (cons old-in-reply-to tmp-ref)))
 174            (setq tmp-ref (nreverse (cons old-message-id tmp-ref))))
 175          (if (integerp mew-references-max-count)
 176              (setq skip (- (length tmp-ref) mew-references-max-count)))
 177          (if (and (numberp skip) (> skip 0))
 178              (setq tmp-ref (nthcdr skip tmp-ref)))
 179          (setq references (mew-join "\n\t" tmp-ref))))
 180      (switch-to-buffer-other-window (find-file-noselect file))
 181      (mew-draft-rename file)
 182      (mew-draft-header subject nil to cc newsgroups in-reply-to references)
 183      (if (stringp distribution)
 184          (save-excursion
 185            (goto-char (point-min))
 186            (search-forward "Newsgroups:")
 187            (forward-line 1)
 188            (insert (concat "Distribution: " distribution "\n"))))
 189      (if (eq mew-summary-reply-position 'body)
 190          (progn
 191            (goto-char (mew-header-end))
 192            (forward-line)))
 193      (make-variable-buffer-local 'mew-message-citation-buffer)
 194      (setq mew-message-citation-buffer gnus-article-buffer)
 195      (undo-boundary)
 196      (mew-draft-mode)
 197      (run-hooks 'mew-draft-mode-newdraft-hook)
 198      (if yank
 199          (progn
 200            (goto-char (point-max))
 201            (mew-draft-cite))))))
 202
 203 (defun mew-gnus-reply-with-citation ()
 204   "Reply or followup to GNUS article using mew.
 205 Original article is yanked automatically."
 206   (interactive)
 207   (mew-gnus-reply t))
 208
 209 (defun mew-gnus-mail-forward (&optional buffer)
 210   "Forward the current message to another user using mew."
 211   (interactive)
 212   (mew-gnus-init)
 213   (mew-current-set 'window (current-window-configuration))
 214   (gnus-summary-display-article (gnus-summary-article-number)) ;; redisplay
 215   (pop-to-buffer gnus-article-buffer)
 216   (let* ((subject (concat "[" gnus-newsgroup-name "] "
 217                           (or (gnus-fetch-field "subject") "")))
 218          (draft (mew-folder-new-message mew-draft-folder))
 219          (dirname (file-name-nondirectory draft)))
 220     (mew-summary-prepare-draft
 221      (mew-gnus-buffer-copy draft
 222                            (or (and (boundp 'gnus-original-article-buffer)
 223                                     gnus-original-article-buffer)
 224                                gnus-article-buffer))
 225      (let ((split-window-keep-point t))
 226        (split-window-vertically))
 227      (switch-to-buffer-other-window (find-file-noselect draft))
 228      (mew-draft-rename draft)
 229      (mew-draft-header subject 'nl)
 230      (mew-draft-mode)
 231      (run-hooks 'mew-draft-mode-newdraft-hook)
 232      (setq mew-encode-syntax (mew-encode-syntax-initial-multi dirname 1))
 233      (save-excursion
 234        (mew-draft-prepare-attachments t)))))
 235
 236 (defun mew-gnus-buffer-copy (draft buffer)
 237   (let* ((mimefolder (mew-draft-to-mime draft))
 238          (mimedir (mew-expand-folder mimefolder)))
 239     (if (null (file-directory-p mimedir))
 240         (mew-make-directory mimedir)
 241       (if (null (mew-directory-empty-p mimedir))
 242           (if (y-or-n-p (format "%s is not empty. Delete it? " mimefolder))
 243               (progn
 244                 (mew-delete-directory-recursively mimedir)
 245                 (mew-make-directory mimedir)))))
 246     (save-excursion
 247       (set-buffer buffer)
 248       (write-region (point-min) (point-max)
 249                     (mew-folder-new-message mimefolder)))))
 250
 251 (provide 'mew-gnus)
 252 ;;; mew-gnus.el ends here