Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-17 18:37:33 +00:00
Code Issues Projects Releases Packages Wiki Activity

Version 3.15 from Umeda.

Browse source
This commit is contained in:
Richard M. Stallman 1993-05-16 22:58:52 +00:00
parent c49cbce2eb
commit b027f415cd
7 changed files with 3053 additions and 1810 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3809
lisp/gnus.el
View file

File diff suppressed because it is too large Load diff

108
lisp/gnusmail.el
View file

@ -1,6 +1,6 @@
;;; gnusmail.el --- mail reply commands for GNUS newsreader
;; Copyright (C) 1990 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
@ -46,34 +46,48 @@
(autoload 'mh-find-path "mh-e")
(autoload 'mh-yank-cur-msg "mh-e")
;;; Mail reply commands of GNUS Subject Mode
;;; Mail reply commands of GNUS Summary Mode
(defun gnus-Subject-mail-reply (yank)
(defun gnus-summary-reply (yank)
"Reply mail to news author.
If prefix arg YANK is non-nil, original article is yanked automatically.
Customize the variable `gnus-mail-reply-method' to use another mailer."
If prefix argument YANK is non-nil, original article is yanked automatically.
Customize the variable gnus-mail-reply-method to use another mailer."
(interactive "P")
(gnus-Subject-select-article)
(switch-to-buffer gnus-Article-buffer)
;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
;; Stripping headers should be specified with mail-yank-ignored-headers.
(gnus-summary-select-article t t)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-Article-buffer)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-reply-method yank))
(defun gnus-Subject-mail-reply-with-original ()
"Reply mail to news author with original article."
(defun gnus-summary-reply-with-original ()
"Reply mail to news author with original article.
Customize the variable gnus-mail-reply-method to use another mailer."
(interactive)
(gnus-Subject-mail-reply t))
(gnus-summary-reply t))
(defun gnus-Subject-mail-other-window ()
"Compose mail in other window.
Customize the variable `gnus-mail-other-window-method' to use another mailer."
(defun gnus-summary-mail-forward ()
"Forward the current message to another user.
Customize the variable gnus-mail-forward-method to use another mailer."
(interactive)
(gnus-Subject-select-article)
(switch-to-buffer gnus-Article-buffer)
(gnus-summary-select-article)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-Article-buffer)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-forward-method))
(defun gnus-summary-mail-other-window ()
"Compose mail in other window.
Customize the variable gnus-mail-other-window-method to use another mailer."
(interactive)
(gnus-summary-select-article)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-other-window-method))
@ -91,6 +105,31 @@ Optional argument YANK means yank original article."
(goto-char last)
)))
(defun gnus-mail-forward-using-mail ()
"Forward the current message to another user using mail."
;; This is almost a carbon copy of rmail-forward in rmail.el.
(let ((forward-buffer (current-buffer))
(subject
(concat "[" gnus-newsgroup-name "] "
;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
(or (gnus-fetch-field "Subject") ""))))
;; If only one window, use it for the mail buffer.
;; Otherwise, use another window for the mail buffer
;; so that the Rmail buffer remains visible
;; and sending the mail will get back to it.
(if (if (one-window-p t)
(mail nil nil subject)
(mail-other-window nil nil subject))
(save-excursion
(goto-char (point-max))
(insert "------- Start of forwarded message -------\n")
(insert-buffer forward-buffer)
(goto-char (point-max))
(insert "------- End of forwarded message -------\n")
;; You have a chance to arrange the message.
(run-hooks 'gnus-mail-forward-hook)
))))
(defun gnus-mail-other-window-using-mail ()
"Compose mail other window using mail."
(news-mail-other-window)
@ -107,11 +146,11 @@ Optional argument YANK means yank original article."
(defun gnus-mail-reply-using-mhe (&optional yank)
"Compose reply mail using mh-e.
Optional argument YANK means yank original article.
The command \\[mh-yank-cur-msg] yanks the original message into current buffer."
The command \\[mh-yank-cur-msg] yank the original message into current buffer."
;; First of all, prepare mhe mail buffer.
(let (from cc subject date to reply-to (buffer (current-buffer)))
(save-restriction
(gnus-Article-show-all-headers) ;I don't think this is really needed.
(gnus-article-show-all-headers) ;I don't think this is really needed.
(setq from (gnus-fetch-field "from")
subject (let ((subject (gnus-fetch-field "subject")))
(if (and subject
@ -140,12 +179,39 @@ The command \\[mh-yank-cur-msg] yanks the original message into current buffer."
(goto-char last)
)))
;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh
;; <itojun@ingram.mt.cs.keio.ac.jp>
(defun gnus-mail-forward-using-mhe ()
"Forward the current message to another user using mh-e."
;; First of all, prepare mhe mail buffer.
(let ((to (read-string "To: "))
(cc (read-string "Cc: "))
(buffer (current-buffer))
subject)
;;(gnus-article-show-all-headers)
(setq subject
(concat "[" gnus-newsgroup-name "] "
;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
(or (gnus-fetch-field "subject") "")))
(setq mh-show-buffer buffer)
(mh-find-path)
(mh-send to (or cc "") subject)
(save-excursion
(goto-char (point-max))
(insert "\n------- Forwarded Message\n\n")
(insert-buffer buffer)
(goto-char (point-max))
(insert "\n------- End of Forwarded Message\n")
(setq mh-sent-from-folder buffer)
(setq mh-sent-from-msg 1))))
(defun gnus-mail-other-window-using-mhe ()
"Compose mail other window using MH-E Mail."
"Compose mail other window using mh-e."
(let ((to (read-string "To: "))
(cc (read-string "Cc: "))
(subject (read-string "Subject: " (gnus-fetch-field "subject"))))
(gnus-Article-show-all-headers) ;I don't think this is really needed.
(gnus-article-show-all-headers) ;I don't think this is really needed.
(setq mh-show-buffer (current-buffer))
(mh-find-path)
(mh-send-other-window to cc subject)

216
lisp/gnusmisc.el
View file

@ -1,6 +1,6 @@
;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader
;; Copyright (C) 1989, 1990 Free Software Foundation, Inc.
;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
@ -32,48 +32,58 @@
;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath).
;; I'd like to thank him very much.
(defvar gnus-Browse-killed-mode-hook nil
(defvar gnus-browse-killed-mode-hook nil
"*A hook for GNUS Browse-Killed Mode.")
(defvar gnus-Browse-killed-buffer "*Killed Newsgroup*")
(defvar gnus-Browse-killed-mode-map nil)
(defvar gnus-browse-killed-buffer "*Killed Newsgroup*")
(defvar gnus-browse-killed-mode-map nil)
(defvar gnus-winconf-browse-killed nil)
(put 'gnus-Browse-killed-mode 'mode-class 'special)
(autoload 'timezone-make-date-arpa-standard "timezone")
(put 'gnus-browse-killed-mode 'mode-class 'special)
;;;
;;; GNUS Browse-Killed Mode
;;;
;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath).
;; I'd like to thank him very much.
;; Make the buffer to be managed by GNUS.
(or (memq gnus-Browse-killed-buffer gnus-buffer-list)
(or (memq gnus-browse-killed-buffer gnus-buffer-list)
(setq gnus-buffer-list
(cons gnus-Browse-killed-buffer gnus-buffer-list)))
(cons gnus-browse-killed-buffer gnus-buffer-list)))
(if gnus-Browse-killed-mode-map
(if gnus-browse-killed-mode-map
nil
(setq gnus-Browse-killed-mode-map (make-keymap))
(suppress-keymap gnus-Browse-killed-mode-map t)
(define-key gnus-Browse-killed-mode-map " " 'gnus-Group-next-group)
(define-key gnus-Browse-killed-mode-map "\177" 'gnus-Group-prev-group)
(define-key gnus-Browse-killed-mode-map "\C-n" 'gnus-Group-next-group)
(define-key gnus-Browse-killed-mode-map "\C-p" 'gnus-Group-prev-group)
(define-key gnus-Browse-killed-mode-map "n" 'gnus-Group-next-group)
(define-key gnus-Browse-killed-mode-map "p" 'gnus-Group-prev-group)
(define-key gnus-Browse-killed-mode-map "y" 'gnus-Browse-killed-yank)
(define-key gnus-Browse-killed-mode-map "\C-y" 'gnus-Browse-killed-yank)
(define-key gnus-Browse-killed-mode-map "l" 'gnus-Browse-killed-groups)
(define-key gnus-Browse-killed-mode-map "q" 'gnus-Browse-killed-exit)
(define-key gnus-Browse-killed-mode-map "\C-c\C-c" 'gnus-Browse-killed-exit)
(define-key gnus-Browse-killed-mode-map "\C-c\C-i" 'gnus-Info-find-node))
(setq gnus-browse-killed-mode-map (make-keymap))
(suppress-keymap gnus-browse-killed-mode-map t)
(define-key gnus-browse-killed-mode-map " " 'gnus-group-next-group)
(define-key gnus-browse-killed-mode-map "\177" 'gnus-group-prev-group)
(define-key gnus-browse-killed-mode-map "\C-n" 'gnus-group-next-group)
(define-key gnus-browse-killed-mode-map "\C-p" 'gnus-group-prev-group)
(define-key gnus-browse-killed-mode-map "n" 'gnus-group-next-group)
(define-key gnus-browse-killed-mode-map "p" 'gnus-group-prev-group)
(define-key gnus-browse-killed-mode-map "y" 'gnus-browse-killed-yank)
(define-key gnus-browse-killed-mode-map "\C-y" 'gnus-browse-killed-yank)
(define-key gnus-browse-killed-mode-map "l" 'gnus-list-killed-groups)
(define-key gnus-browse-killed-mode-map "q" 'gnus-browse-killed-exit)
(define-key gnus-browse-killed-mode-map "\C-c\C-c" 'gnus-browse-killed-exit)
(define-key gnus-browse-killed-mode-map "\C-c\C-i" 'gnus-info-find-node))
(defun gnus-Browse-killed-mode ()
(defun gnus-browse-killed-mode ()
"Major mode for browsing the killed newsgroups.
All normal editing commands are turned off.
Instead, these commands are available:
\\{gnus-Browse-killed-mode-map}
\\{gnus-browse-killed-mode-map}
The killed newsgroups are saved in the quick startup file \".newsrc.el\"
unless disabled inthe options line of the startup file \".newsrc\".
The killed newsgroups are saved in the quick startup file (.newsrc.el)
unless it against the options line in the startup file (.newsrc).
Entry to this mode calls `gnus-Browse-killed-mode-hook' with no arguments
Entry to this mode calls gnus-browse-killed-mode-hook with no arguments,
if that value is non-nil."
(interactive)
(kill-all-local-variables)
@ -86,65 +96,66 @@ if that value is non-nil."
(t
(setq mode-line-format
"--- GNUS: Killed Newsgroups %[(%m)%]----%3p-%-")))
(setq major-mode 'gnus-Browse-killed-mode)
(setq major-mode 'gnus-browse-killed-mode)
(setq mode-name "Browse-Killed")
(setq mode-line-buffer-identification "GNUS: Killed Newsgroups")
(use-local-map gnus-Browse-killed-mode-map)
(use-local-map gnus-browse-killed-mode-map)
(buffer-flush-undo (current-buffer))
(setq buffer-read-only t) ;Disable modification
(run-hooks 'gnus-Browse-killed-mode-hook))
(run-hooks 'gnus-browse-killed-mode-hook))
(defun gnus-Browse-killed-groups ()
"Browse the killed newsgroups.
\\<gnus-Browse-killed-mode-map>\\[gnus-Browse-killed-yank] yanks the newsgroup on the current line into the Newsgroups buffer."
(defun gnus-list-killed-groups ()
"List the killed newsgroups.
The keys y and C-y yank the newsgroup on the current line into the
Newsgroups buffer."
(interactive)
(or gnus-killed-assoc
(error "No killed newsgroups"))
;; Save current window configuration if this is first invocation..
(or (get-buffer-window gnus-Browse-killed-buffer)
(or (get-buffer-window gnus-browse-killed-buffer)
(setq gnus-winconf-browse-killed
(current-window-configuration)))
;; Prepare browsing buffer.
(pop-to-buffer (get-buffer-create gnus-Browse-killed-buffer))
(gnus-Browse-killed-mode)
(pop-to-buffer (get-buffer-create gnus-browse-killed-buffer))
(gnus-browse-killed-mode)
(let ((buffer-read-only nil)
(killed-assoc gnus-killed-assoc))
(erase-buffer)
(while killed-assoc
(insert (gnus-Group-prepare-line (car killed-assoc)))
(insert (gnus-group-prepare-line (car killed-assoc)))
(setq killed-assoc (cdr killed-assoc)))
(goto-char (point-min))
))
(defun gnus-Browse-killed-yank ()
(defun gnus-browse-killed-yank ()
"Yank current newsgroup to Newsgroup buffer."
(interactive)
(let ((group (gnus-Group-group-name)))
(let ((group (gnus-group-group-name)))
(if group
(let* ((buffer-read-only nil)
(killed (assoc group gnus-killed-assoc)))
(pop-to-buffer gnus-Group-buffer) ;Needed to adjust point.
(killed (gnus-gethash group gnus-killed-hashtb)))
(pop-to-buffer gnus-group-buffer) ;Needed to adjust point.
(if killed
(gnus-Group-insert-group killed))
(pop-to-buffer gnus-Browse-killed-buffer)
(gnus-group-insert-group killed))
(pop-to-buffer gnus-browse-killed-buffer)
(beginning-of-line)
(delete-region (point)
(progn (forward-line 1) (point)))
)))
(gnus-Browse-killed-check-buffer))
(gnus-browse-killed-check-buffer))
(defun gnus-Browse-killed-check-buffer ()
(defun gnus-browse-killed-check-buffer ()
"Exit if the buffer is empty by deleting the window and killing the buffer."
(and (null gnus-killed-assoc)
(get-buffer gnus-Browse-killed-buffer)
(gnus-Browse-killed-exit)))
(get-buffer gnus-browse-killed-buffer)
(gnus-browse-killed-exit)))
(defun gnus-Browse-killed-exit ()
(defun gnus-browse-killed-exit ()
"Exit this mode by deleting the window and killing the buffer."
(interactive)
(and (get-buffer-window gnus-Browse-killed-buffer)
(delete-window (get-buffer-window gnus-Browse-killed-buffer)))
(kill-buffer gnus-Browse-killed-buffer)
(and (get-buffer-window gnus-browse-killed-buffer)
(delete-window (get-buffer-window gnus-browse-killed-buffer)))
(kill-buffer gnus-browse-killed-buffer)
;; Restore previous window configuration if available.
(and gnus-winconf-browse-killed
(set-window-configuration gnus-winconf-browse-killed))
@ -155,14 +166,53 @@ if that value is non-nil."
;;; kill/yank newsgroup commands of GNUS Group Mode
;;;
(defun gnus-Group-kill-group (n)
(defun gnus-group-transpose-groups (arg)
"Exchange current newsgroup and previous newsgroup.
With argument ARG, takes previous newsgroup and moves it past ARG newsgroup."
(interactive "p")
;; BUG: last newsgroup and the last but one cannot be transposed
;; since gnus-group-search-forward does not move forward beyond the
;; last. If we instead use forward-line, no problem, but I don't
;; want to use it for later extension.
(while (> arg 0)
(gnus-group-search-forward t t)
(gnus-group-kill-group 1)
(gnus-group-search-forward nil t)
(gnus-group-yank-group)
(gnus-group-search-forward nil t)
(setq arg (1- arg))
))
(defun gnus-group-kill-region (begin end)
"Kill newsgroups in current region (excluding current point).
The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
(interactive "r")
(let ((lines
;; Exclude a line where current point is on.
(1-
;; Count lines.
(save-excursion
(count-lines
(progn
(goto-char begin)
(beginning-of-line)
(point))
(progn
(goto-char end)
(end-of-line)
(point)))))))
(goto-char begin)
(beginning-of-line) ;Important when LINES < 1
(gnus-group-kill-group lines)))
(defun gnus-group-kill-group (n)
"Kill newsgroup on current line, repeated prefix argument N times.
The killed newsgroups can be yanked by using \\[gnus-Group-yank-group]."
The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
(interactive "p")
(let ((buffer-read-only nil)
(group nil))
(while (> n 0)
(setq group (gnus-Group-group-name))
(setq group (gnus-group-group-name))
(or group
(signal 'end-of-buffer nil))
(beginning-of-line)
@ -171,50 +221,74 @@ The killed newsgroups can be yanked by using \\[gnus-Group-yank-group]."
(gnus-kill-newsgroup group)
(setq n (1- n))
;; Add to killed newsgroups in the buffer if exists.
(if (get-buffer gnus-Browse-killed-buffer)
(if (get-buffer gnus-browse-killed-buffer)
(save-excursion
(set-buffer gnus-Browse-killed-buffer)
(set-buffer gnus-browse-killed-buffer)
(let ((buffer-read-only nil))
(goto-char (point-min))
(insert (gnus-Group-prepare-line (car gnus-killed-assoc)))
(insert (gnus-group-prepare-line (car gnus-killed-assoc)))
)))
)
(search-forward ":" nil t)
))
(defun gnus-Group-yank-group ()
"Yank the last newsgroup killed with \\[gnus-Group-kill-group],
(defun gnus-group-yank-group ()
"Yank the last newsgroup killed with \\[gnus-group-kill-group],
inserting it before the newsgroup on the line containging point."
(interactive)
(gnus-Group-insert-group (car gnus-killed-assoc))
(gnus-group-insert-group (car gnus-killed-assoc))
;; Remove killed newsgroups from the buffer if exists.
(if (get-buffer gnus-Browse-killed-buffer)
(if (get-buffer gnus-browse-killed-buffer)
(save-excursion
(set-buffer gnus-Browse-killed-buffer)
(set-buffer gnus-browse-killed-buffer)
(let ((buffer-read-only nil))
(goto-char (point-min))
(delete-region (point-min)
(progn (forward-line 1) (point)))
)))
(gnus-Browse-killed-check-buffer))
(gnus-browse-killed-check-buffer))
(defun gnus-Group-insert-group (info)
"Insert newsgroup at current line using `gnus-newsrc-assoc' INFO."
(defun gnus-group-insert-group (info)
"Insert newsgroup at current line using gnus-newsrc-assoc INFO."
(if (null gnus-killed-assoc)
(error "No killed newsgroups"))
(if (not gnus-have-all-newsgroups)
(error
(substitute-command-keys
"Not all newsgroups are displayed. Type \\[gnus-Group-list-all-groups] to display all newsgroups.")))
;; Huuum. It this right?
;;(if (not gnus-have-all-newsgroups)
;; (error
;; (substitute-command-keys
;; "Not all newsgroups are displayed. Type \\[gnus-group-list-all-groups] to display all newsgroups.")))
(let ((buffer-read-only nil)
(group (gnus-Group-group-name)))
(group (gnus-group-group-name)))
(gnus-insert-newsgroup info group)
(beginning-of-line)
(insert (gnus-Group-prepare-line info))
(insert (gnus-group-prepare-line info))
(forward-line -1)
(search-forward ":" nil t)
))
;;; Rewrite Date: field in GMT to local
(defun gnus-gmt-to-local ()
"Rewrite Date: field described in GMT to local in current buffer.
The variable gnus-local-timezone is used for local time zone.
Intended to be used with gnus-article-prepare-hook."
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(narrow-to-region (point-min)
(progn (search-forward "\n\n" nil 'move) (point)))
(goto-char (point-min))
(if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t)
(let ((buffer-read-only nil)
(date (buffer-substring (match-beginning 1) (match-end 1))))
(delete-region (match-beginning 1) (match-end 1))
(insert
(timezone-make-date-arpa-standard date nil gnus-local-timezone))
))
)))
(provide 'gnusmisc)
;;; gnusmisc.el ends here

425
lisp/gnuspost.el
View file

@ -32,10 +32,11 @@
(defvar gnus-winconf-post-news nil)
(autoload 'news-reply-mode "rnewspost")
(autoload 'timezone-make-date-arpa-standard "timezone")
;;; Post news commands of GNUS Group Mode and Subject Mode
;;; Post news commands of GNUS Group Mode and Summary Mode
(defun gnus-Group-post-news ()
(defun gnus-group-post-news ()
"Post an article."
(interactive)
;; Save window configuration.
@ -46,21 +47,21 @@
(not (zerop (buffer-size))))
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Subject buffer nor Article buffer later.
(if (get-buffer gnus-Subject-buffer)
(bury-buffer gnus-Subject-buffer))
(if (get-buffer gnus-Article-buffer)
(bury-buffer gnus-Article-buffer)))
;; We don't want to return to Summary buffer nor Article buffer later.
(if (get-buffer gnus-summary-buffer)
(bury-buffer gnus-summary-buffer))
(if (get-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer)))
(defun gnus-Subject-post-news ()
(defun gnus-summary-post-news ()
"Post an article."
(interactive)
(gnus-Subject-select-article t nil)
(gnus-summary-select-article t nil)
;; Save window configuration.
(setq gnus-winconf-post-news (current-window-configuration))
(unwind-protect
(progn
(switch-to-buffer gnus-Article-buffer)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(gnus-post-news))
@ -69,26 +70,26 @@
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Article buffer later.
(bury-buffer gnus-Article-buffer))
(bury-buffer gnus-article-buffer))
(defun gnus-Subject-post-reply (yank)
(defun gnus-summary-followup (yank)
"Post a reply article.
If prefix argument YANK is non-nil, original article is yanked automatically."
(interactive "P")
(gnus-Subject-select-article t nil)
(gnus-summary-select-article t nil)
;; Check Followup-To: poster.
(set-buffer gnus-Article-buffer)
(set-buffer gnus-article-buffer)
(if (and gnus-use-followup-to
(string-equal "poster" (gnus-fetch-field "followup-to"))
(or (not (eq gnus-use-followup-to t))
(not (y-or-n-p "Do you want to ignore `Followup-To: poster'? "))))
;; Mail to the poster. GNUS is now RFC1036 compliant.
(gnus-Subject-mail-reply yank)
(gnus-summary-reply yank)
;; Save window configuration.
(setq gnus-winconf-post-news (current-window-configuration))
(unwind-protect
(progn
(switch-to-buffer gnus-Article-buffer)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(gnus-news-reply yank))
@ -97,27 +98,29 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Article buffer later.
(bury-buffer gnus-Article-buffer)))
(bury-buffer gnus-article-buffer)))
(defun gnus-Subject-post-reply-with-original ()
(defun gnus-summary-followup-with-original ()
"Post a reply article with original article."
(interactive)
(gnus-Subject-post-reply t))
(gnus-summary-followup t))
(defun gnus-Subject-cancel-article ()
(defun gnus-summary-cancel-article ()
"Cancel an article you posted."
(interactive)
(gnus-Subject-select-article t nil)
(gnus-eval-in-buffer-window gnus-Article-buffer
(gnus-summary-select-article t nil)
(gnus-eval-in-buffer-window gnus-article-buffer
(gnus-cancel-news)))
;;; Post a News using NNTP
;;;###autoload
(defalias 'sendnews 'gnus-post-news)
(fset 'sendnews 'gnus-post-news)
;;;###autoload
(defalias 'postnews 'gnus-post-news)
(fset 'postnews 'gnus-post-news)
;;;###autoload
(defun gnus-post-news ()
"Begin editing a new USENET news article to be posted.
@ -127,16 +130,24 @@ Type \\[describe-mode] once editing the article to get a list of commands."
(y-or-n-p "Are you sure you want to post to all of USENET? "))
(let ((artbuf (current-buffer))
(newsgroups ;Default newsgroup.
(if (eq major-mode 'gnus-Article-mode) gnus-newsgroup-name))
(if (eq major-mode 'gnus-article-mode) gnus-newsgroup-name))
(subject nil)
(distribution nil))
;; Get default distribution.
(distribution (car gnus-local-distributions)))
;; Connect to NNTP server if not connected yet, and get
;; several information.
(if (not (gnus-server-opened))
(progn
(gnus-start-news-server t) ;Confirm server.
(gnus-setup-news)))
;; Get current article information.
(save-restriction
(and (not (zerop (buffer-size)))
;;(equal major-mode 'news-mode)
(equal major-mode 'gnus-Article-mode)
(equal major-mode 'gnus-article-mode)
(progn
;;(news-show-all-headers)
(gnus-Article-show-all-headers)
(gnus-article-show-all-headers)
(narrow-to-region (point-min)
(progn (goto-char (point-min))
(search-forward "\n\n")
@ -165,20 +176,25 @@ Type \\[describe-mode] once editing the article to get a list of commands."
;; (setq newsgroups (read-string "Newsgroups: " "general"))
(or newsgroups ;Use the default newsgroup.
(setq newsgroups
(completing-read "Newsgroup: " gnus-newsrc-assoc
(completing-read "Newsgroup: "
gnus-newsrc-assoc
nil 'require-match
newsgroups ;Default newsgroup.
)))
(setq subject (read-string "Subject: "))
;; Choose a distribution from gnus-distribution-list.
;; completing-read should not be used with
;; 'require-match functionality in order to allow use
;; of unknow distribution.
(setq distribution
(substring newsgroups 0 (string-match "\\." newsgroups)))
(if (string-equal distribution newsgroups)
;; Newsgroup may be general or control. In this
;; case, use default distribution.
(setq distribution gnus-default-distribution))
(setq distribution
(read-string "Distribution: " distribution))
;; An empty string is ok to ignore gnus-default-distribution.
(if (consp gnus-distribution-list)
(completing-read "Distribution: "
gnus-distribution-list
nil nil ;Never 'require-match
distribution ;Default distribution.
)
(read-string "Distribution: ")))
;; Empty string is okay.
;;(if (string-equal distribution "")
;; (setq distribution nil))
))
@ -189,7 +205,7 @@ Type \\[describe-mode] once editing the article to get a list of commands."
;; Insert Distribution: field.
;; Suggested by ichikawa@flab.fujitsu.junet.
(mail-position-on-field "Distribution")
(insert (or distribution gnus-default-distribution ""))
(insert (or distribution ""))
;; Handle author copy using FCC field.
(if gnus-author-copy
(progn
@ -217,10 +233,10 @@ original message into it."
(save-restriction
(and (not (zerop (buffer-size)))
;;(equal major-mode 'news-mode)
(equal major-mode 'gnus-Article-mode)
(equal major-mode 'gnus-article-mode)
(progn
;; (news-show-all-headers)
(gnus-Article-show-all-headers)
(gnus-article-show-all-headers)
(narrow-to-region (point-min)
(progn (goto-char (point-min))
(search-forward "\n\n")
@ -291,11 +307,18 @@ original message into it."
(progn
(mail-position-on-field "FCC")
(insert gnus-author-copy)))
;; Insert To: FROM field, which is expected to mail the
;; message to the author of the article too.
(if (and gnus-auto-mail-to-author from)
(progn
(goto-char (point-min))
(insert "To: " from "\n")))
(goto-char (point-max)))
;; Yank original article automatically.
(if yank
(let ((last (point)))
(goto-char (point-max))
;;(goto-char (point-max))
;; Insert at current point.
(news-reply-yank-original nil)
(goto-char last)))
)
@ -307,30 +330,37 @@ original message into it."
(let* ((case-fold-search nil)
(server-running (gnus-server-opened)))
(save-excursion
;; It is possible to post a news without reading news using
;; `gnus' before.
;; Connect to default NNTP server if necessary.
;; Suggested by yuki@flab.fujitsu.junet.
(gnus-start-news-server) ;Use default server.
;; NNTP server must be opened before current buffer is modified.
(widen)
(goto-char (point-min))
(run-hooks 'news-inews-hook)
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n"))
(replace-match "\n\n")
(goto-char (point-max))
;; require a newline at the end for inews to append .signature to
(or (= (preceding-char) ?\n)
(insert ?\n))
;; Mail the message too if To: or Cc: exists.
(if (save-restriction
(narrow-to-region
(point-min)
(progn
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n"))
(point)))
(or (mail-fetch-field "to" nil t)
(mail-fetch-field "cc" nil t)))
(if gnus-mail-send-method
(progn
(message "Sending via mail...")
(funcall gnus-mail-send-method)
(message "Sending via mail... done"))
(ding)
(message "No mailer defined. To: and/or Cc: fields ignored.")
(sit-for 1)))
;; Send to NNTP server.
(message "Posting to USENET...")
;; Post to NNTP server.
(if (gnus-inews-article)
(message "Posting to USENET... done")
;; We cannot signal an error.
(ding) (message "Article rejected: %s" (gnus-status-message)))
(goto-char (point-min)) ;restore internal header separator
(search-forward "\n\n")
(replace-match (concat "\n" mail-header-separator "\n"))
(set-buffer-modified-p nil))
;; If NNTP server is opened by gnus-inews-news, close it by myself.
(or server-running
@ -353,9 +383,9 @@ original message into it."
(save-excursion
;; Get header info. from original article.
(save-restriction
(gnus-Article-show-all-headers)
(gnus-article-show-all-headers)
(goto-char (point-min))
(search-forward "\n\n")
(search-forward "\n\n" nil 'move)
(narrow-to-region (point-min) (point))
(setq from (mail-fetch-field "from"))
(setq newsgroups (mail-fetch-field "newsgroups"))
@ -368,30 +398,27 @@ original message into it."
(downcase (mail-strip-quoted-names from))
(downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
(progn
(ding) (message "This article is not yours"))
(ding) (message "This article is not yours."))
;; Make control article.
(set-buffer (get-buffer-create " *GNUS-posting*"))
(set-buffer (get-buffer-create " *GNUS-canceling*"))
(buffer-flush-undo (current-buffer))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
"Subject: cancel " message-id "\n"
"Control: cancel " message-id "\n"
;; We should not use the value of
;; `gnus-default-distribution' as default value,
;; We should not use the first value of
;; `gnus-distribution-list' as default value,
;; because distribution must be as same as original
;; article.
"Distribution: " (or distribution "") "\n"
mail-header-separator "\n"
)
;; Prepare article headers.
(gnus-inews-insert-headers)
(goto-char (point-max))
;; Insert empty line.
(insert "\n")
;; Send the control article to NNTP server.
(message "Canceling your article...")
(if (gnus-request-post)
(if (gnus-inews-article)
(message "Canceling your article... done")
(ding) (message "Failed to cancel your article"))
;; Kill the article buffer.
(kill-buffer (current-buffer))
)))
))
@ -400,55 +427,35 @@ original message into it."
;;; Lowlevel inews interface
(defun gnus-inews-article ()
"NNTP inews interface."
(let ((signature
(if gnus-signature-file
(expand-file-name gnus-signature-file nil)))
(distribution nil)
(artbuf (current-buffer))
"Post an article in current buffer using NNTP protocol."
(let ((artbuf (current-buffer))
(tmpbuf (get-buffer-create " *GNUS-posting*")))
(save-excursion
(set-buffer tmpbuf)
(buffer-flush-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring artbuf)
;; Get distribution.
;; Remove the header separator.
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n"))
(replace-match "\n\n")
(goto-char (point-max))
;; require a newline at the end for inews to append .signature to
(or (= (preceding-char) ?\n)
(insert ?\n))
;; This hook may insert a signature.
(run-hooks 'gnus-prepare-article-hook)
;; Prepare article headers. All message body such as signature
;; must be inserted before Lines: field is prepared.
(save-restriction
(goto-char (point-min))
(search-forward "\n\n")
(narrow-to-region (point-min) (point))
(setq distribution (mail-fetch-field "distribution")))
(widen)
(if signature
(progn
;; Change signature file by distribution.
;; Suggested by hyoko@flab.fujitsu.junet.
(if (file-exists-p (concat signature "-" distribution))
(setq signature (concat signature "-" distribution)))
;; Insert signature.
(if (file-exists-p signature)
(progn
(goto-char (point-max))
(insert "--\n")
(insert-file-contents signature)))
))
;; Prepare article headers.
(save-restriction
(goto-char (point-min))
(search-forward "\n\n")
(narrow-to-region (point-min) (point))
(gnus-inews-insert-headers)
;; Save author copy of posted article. The article must be
;; copied before being posted because `gnus-request-post'
;; modifies the buffer.
(let ((case-fold-search t))
;; Find and handle any FCC fields.
(goto-char (point-min))
(if (re-search-forward "^FCC:" nil t)
(gnus-inews-do-fcc))))
(widen)
;; Run final inews hooks.
(run-hooks 'gnus-Inews-article-hook)
(gnus-inews-insert-headers))
;; Run final inews hooks. This hook may do FCC.
;; The article must be saved before being posted because
;; `gnus-request-post' modifies the buffer.
(run-hooks 'gnus-inews-article-hook)
;; Post an article to NNTP server.
;; Return NIL if post failed.
(prog1
@ -456,21 +463,115 @@ original message into it."
(kill-buffer (current-buffer)))
)))
(defun gnus-inews-insert-headers ()
"Prepare article headers.
Fields already prepared in the buffer are not modified.
Fields in gnus-required-headers will be generated."
(save-excursion
(let ((date (gnus-inews-date))
(message-id (gnus-inews-message-id))
(organization (gnus-inews-organization)))
(goto-char (point-min))
(or (mail-fetch-field "path")
(and (memq 'Path gnus-required-headers)
(insert "Path: " (gnus-inews-path) "\n")))
(or (mail-fetch-field "from")
(and (memq 'From gnus-required-headers)
(insert "From: " (gnus-inews-user-name) "\n")))
;; If there is no subject, make Subject: field.
(or (mail-fetch-field "subject")
(and (memq 'Subject gnus-required-headers)
(insert "Subject: \n")))
;; If there is no newsgroups, make Newsgroups: field.
(or (mail-fetch-field "newsgroups")
(and (memq 'Newsgroups gnus-required-headers)
(insert "Newsgroups: \n")))
(or (mail-fetch-field "message-id")
(and message-id
(memq 'Message-ID gnus-required-headers)
(insert "Message-ID: " message-id "\n")))
(or (mail-fetch-field "date")
(and date
(memq 'Date gnus-required-headers)
(insert "Date: " date "\n")))
;; Optional fields in RFC977 and RFC1036
(or (mail-fetch-field "organization")
(and organization
(memq 'Organization gnus-required-headers)
(let ((begin (point))
(fill-column 79)
(fill-prefix "\t"))
(insert "Organization: " organization "\n")
(fill-region-as-paragraph begin (point)))))
(or (mail-fetch-field "distribution")
(and (memq 'Distribution gnus-required-headers)
(insert "Distribution: \n")))
(or (mail-fetch-field "lines")
(and (memq 'Lines gnus-required-headers)
(insert "Lines: " (gnus-inews-lines) "\n")))
)))
;; Utility functions.
(defun gnus-inews-insert-signature ()
"Insert signature file in current article buffer.
If there is a file named .signature-DISTRIBUTION, it is used instead
of usual .signature when the distribution of the article is
DISTRIBUTION. Set the variable to nil to prevent appending the
signature file automatically.
Signature file is specified by the variable gnus-signature-file."
(save-excursion
(save-restriction
;; Change signature file by distribution.
;; Suggested by hyoko@flab.fujitsu.co.jp.
(let ((signature
(if gnus-signature-file
(expand-file-name gnus-signature-file nil)))
(distribution nil))
(goto-char (point-min))
(search-forward "\n\n")
(narrow-to-region (point-min) (point))
(setq distribution (mail-fetch-field "distribution"))
(widen)
(if signature
(progn
(if (file-exists-p (concat signature "-" distribution))
(setq signature (concat signature "-" distribution)))
;; Insert signature.
(if (file-exists-p signature)
(progn
(goto-char (point-max))
(insert "--\n")
(insert-file-contents signature)))
))))))
(defun gnus-inews-do-fcc ()
"Process FCC: fields."
"Process FCC: fields in current article buffer.
Unless the first character of the field is `|', the article is saved
to the specified file using the function specified by the variable
gnus-author-copy-saver. The default function rmail-output saves in
Unix mailbox format.
If the first character is `|', the contents of the article is send to
a program specified by the rest of the value."
(let ((fcc-list nil)
(fcc-file nil)
(case-fold-search t)) ;Should ignore case.
(save-excursion
(save-restriction
(goto-char (point-min))
(search-forward "\n\n")
(narrow-to-region (point-min) (point))
(goto-char (point-min))
(while (re-search-forward "^FCC:[ \t]*" nil t)
(setq fcc-list (cons (buffer-substring (point)
(progn
(end-of-line)
(skip-chars-backward " \t")
(point)))
fcc-list))
(setq fcc-list
(cons (buffer-substring
(point)
(progn
(end-of-line)
(skip-chars-backward " \t")
(point)))
fcc-list))
(delete-region (match-beginning 0)
(progn (forward-line 1) (point))))
;; Process FCC operations.
@ -495,36 +596,6 @@ original message into it."
))
))
(defun gnus-inews-insert-headers ()
"Prepare article headers.
Path:, From:, Subject: and Distribution: are generated.
Message-ID:, Date: and Organization: are optional."
(save-excursion
(let ((date (gnus-inews-date))
(message-id (gnus-inews-message-id))
(organization (gnus-inews-organization)))
;; Insert from the top of headers.
(goto-char (point-min))
(insert "Path: " (gnus-inews-path) "\n")
(insert "From: " (gnus-inews-user-name) "\n")
;; If there is no subject, make Subject: field.
(or (mail-fetch-field "subject")
(insert "Subject: \n"))
;; Insert random headers.
(if message-id
(insert "Message-ID: " message-id "\n"))
(if date
(insert "Date: " date "\n"))
(if organization
(let ((begin (point))
(fill-column 79)
(fill-prefix "\t"))
(insert "Organization: " organization "\n")
(fill-region-as-paragraph begin (point))))
(or (mail-fetch-field "distribution")
(insert "Distribution: \n"))
)))
(defun gnus-inews-path ()
"Return uucp path."
(let ((login-name (gnus-inews-login-name)))
@ -551,15 +622,15 @@ Message-ID:, Date: and Organization: are optional."
(defun gnus-inews-login-name ()
"Return user login name.
Got from the variable `gnus-user-login-name', the environment variables
USER and LOGNAME, and the function `user-login-name'."
Got from the variable gnus-user-login-name, the environment variables
USER and LOGNAME, and the function user-login-name."
(or gnus-user-login-name
(getenv "USER") (getenv "LOGNAME") (user-login-name)))
(defun gnus-inews-full-name ()
"Return user full name.
Got from the variable `gnus-user-full-name', the environment variable
NAME, and the function `user-full-name'."
Got from the variable gnus-user-full-name, the environment variable
NAME, and the function user-full-name."
(or gnus-user-full-name
(getenv "NAME") (user-full-name)))
@ -569,9 +640,14 @@ If optional argument GENERICFROM is a string, use it as the domain
name; if it is non-nil, strip of local host name from the domain name.
If the function `system-name' returns full internet name and the
domain is undefined, the domain name is got from it."
;; Note: compatibility hack. This will be removed in the next version.
(and (null gnus-local-domain)
(boundp 'gnus-your-domain)
(setq gnus-local-domain gnus-your-domain))
;; End of compatibility hack.
(let ((domain (or (if (stringp genericfrom) genericfrom)
(getenv "DOMAINNAME")
gnus-your-domain
gnus-local-domain
;; Function `system-name' may return full internet name.
;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
(if (string-match "\\." (system-name))
@ -582,8 +658,8 @@ domain is undefined, the domain name is got from it."
(system-name))))
(if (string-equal "." (substring domain 0 1))
(setq domain (substring domain 1)))
(if (null gnus-your-domain)
(setq gnus-your-domain domain))
(if (null gnus-local-domain)
(setq gnus-local-domain domain))
;; Support GENERICFROM as same as standard Bnews system.
;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
(cond ((null genericfrom)
@ -616,7 +692,27 @@ domain is undefined, the domain name is got from it."
))
(defun gnus-inews-date ()
"Bnews date format string of today. Time zone is ignored."
"Date string of today.
If the variable gnus-local-timezone is non-nil, valid date will be
generated in terms of RFC822. Otherwise, buggy date in which time
zone is ignored will be generated. If you are using with Cnews, you
must use valid date."
(cond (gnus-local-timezone
;; Gnus can generate valid date.
(gnus-inews-valid-date))
(t
;; No timezone info.
(gnus-inews-buggy-date))
))
(defun gnus-inews-valid-date ()
"Date string of today represented in GMT.
Local timezone is specified by the variable gnus-local-timezone."
(timezone-make-date-arpa-standard
(current-time-string) gnus-local-timezone "GMT"))
(defun gnus-inews-buggy-date ()
"Buggy date string of today. Time zone is ignored, but fast."
;; Insert buggy date (time zone is ignored), but I don't worry about
;; it since inews will rewrite it.
(let ((date (current-time-string)))
@ -635,17 +731,22 @@ domain is undefined, the domain name is got from it."
(defun gnus-inews-organization ()
"Return user's organization.
The ORGANIZATION environment variable is used if defined.
If not, the variable `gnus-your-organization' is used instead.
If not, the variable gnus-local-organization is used instead.
If the value begins with a slash, it is taken as the name of a file
containing the organization."
;; The organization must be got in this order since the ORGANIZATION
;; environment variable is intended for user specific while
;; gnus-your-organization is for machine or organization specific.
(let ((organization (or (getenv "ORGANIZATION")
gnus-your-organization
(expand-file-name "~/.organization" nil))))
(if (equal organization "")
(setq organization nil))
;; gnus-local-organization is for machine or organization specific.
;; Note: compatibility hack. This will be removed in the next version.
(and (null gnus-local-organization)
(boundp 'gnus-your-organization)
(setq gnus-local-organization gnus-your-organization))
;; End of compatibility hack.
(let* ((private-file (expand-file-name "~/.organization" nil))
(organization (or (getenv "ORGANIZATION")
gnus-local-organization
private-file)))
(and (stringp organization)
(string-equal (substring organization 0 1) "/")
;; Get it from the user and system file.
@ -672,9 +773,19 @@ containing the organization."
(prog1 (buffer-string)
(kill-buffer tmpbuf))
)))
((string-equal organization private-file) nil) ;No such file
(t organization))
))
(defun gnus-inews-lines ()
"Count the number of lines and return numeric string."
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
(int-to-string (count-lines (point) (point-max))))))
(provide 'gnuspost)
;;; gnuspost.el ends here

129
lisp/mhspool.el
View file

@ -1,6 +1,6 @@
;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Maintainer: FSF
@ -39,13 +39,22 @@
(require 'nntp)
(defvar mhspool-list-folders-method
(function mhspool-list-folders-using-sh)
"*Function to list files in folders.
The function should accept a directory as its argument, and fill the
current buffer with file and directory names. The output format must
be the same as that of 'ls -R1'. Two functions
mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
provided now. I suppose the later is faster.")
(defvar mhspool-list-directory-switches '("-R")
"*Switches for `nntp-request-list' to pass to `ls' for gettting file lists.
"*Switches for mhspool-list-folders-using-ls to pass to `ls' for gettting file lists.
One entry should appear on one line. You may need to add `-1' option.")
(defconst mhspool-version "MHSPOOL 1.5"
(defconst mhspool-version "MHSPOOL 1.8"
"Version numbers of this version of MHSPOOL.")
(defvar mhspool-spool-directory "~/Mail"
@ -62,9 +71,10 @@ One entry should appear on one line. You may need to add `-1' option.")
"Return list of article headers specified by SEQUENCE of article id.
The format of list is
`([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
If there is no References: field, In-Reply-To: field is used instead.
Reader macros for the vector are defined as `nntp-header-FIELD'.
Writer macros for the vector are defined as `nntp-set-header-FIELD'.
News group must be selected before calling me."
Newsgroup must be selected before calling this."
(save-excursion
(set-buffer nntp-server-buffer)
;;(erase-buffer)
@ -136,7 +146,12 @@ News group must be selected before calling me."
(buffer-substring
(point)
(save-excursion (end-of-line) (point)))))
(setq lines 0))
;; Count lines since there is no lines field in most cases.
(setq lines
(save-restriction
(goto-char (point-max))
(widen)
(count-lines (point) (point-max)))))
;; Extract Xref:
(goto-char (point-min))
(if (search-forward "\nXref: " nil t)
@ -154,22 +169,25 @@ News group must be selected before calling me."
(point)
(save-excursion (end-of-line) (point))))
(setq references nil))
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers))
;; Collect valid article only.
(and article
message-id
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers)))
))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(zerop (% count 20))
(message "MHSPOOL: %d%% of headers received."
(message "MHSPOOL: Receiving headers... %d%%"
(/ (* count 100) number)))
)
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(message "MHSPOOL: 100%% of headers received."))
(message "MHSPOOL: Receiving headers... done"))
(nreverse headers)
)))
@ -194,20 +212,20 @@ If optional argument SERVICE is non-nil, open by the service name."
(expand-file-name "~/" nil))))
(setq host (system-name)))
(setq mhspool-spool-directory nil))
(setq nntp-status-message-string "")
(setq nntp-status-string "")
(cond ((and (stringp host)
(stringp mhspool-spool-directory)
(file-directory-p mhspool-spool-directory)
(string-equal host (system-name)))
(setq status (mhspool-open-server-internal host service)))
((string-equal host (system-name))
(setq nntp-status-message-string
(setq nntp-status-string
(format "No such directory: %s. Goodbye."
mhspool-spool-directory)))
((null host)
(setq nntp-status-message-string "NNTP server is not specified."))
(setq nntp-status-string "NNTP server is not specified."))
(t
(setq nntp-status-message-string
(setq nntp-status-string
(format "MHSPOOL: cannot talk to %s." host)))
)
status
@ -227,7 +245,7 @@ If the stream is opened, return T, otherwise return NIL."
(defun mhspool-status-message ()
"Return server status response as string."
nntp-status-message-string
nntp-status-string
)
(defun mhspool-request-article (id)
@ -266,7 +284,9 @@ If the stream is opened, return T, otherwise return NIL."
(defun mhspool-request-stat (id)
"Select article by message ID (or number)."
(error "MHSPOOL: STAT is not implemented."))
(setq nntp-status-string "MHSPOOL: STAT is not implemented.")
nil
)
(defun mhspool-request-group (group)
"Select news GROUP."
@ -285,21 +305,22 @@ If the stream is opened, return T, otherwise return NIL."
))
(defun mhspool-request-list ()
"List valid newsgoups."
"List active newsgoups."
(save-excursion
(let* ((newsgroup nil)
(articles nil)
(directory (file-name-as-directory
(expand-file-name mhspool-spool-directory nil)))
(folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
(buffer (get-buffer-create " *GNUS file listing*")))
(buffer (get-buffer-create " *MHSPOOL File List*")))
(set-buffer nntp-server-buffer)
(erase-buffer)
(set-buffer buffer)
(erase-buffer)
(apply 'call-process
"ls" nil t nil
(append mhspool-list-directory-switches (list directory)))
;; (apply 'call-process
;; "ls" nil t nil
;; (append mhspool-list-directory-switches (list directory)))
(funcall mhspool-list-folders-method directory)
(goto-char (point-min))
(while (re-search-forward folder-regexp nil t)
(setq newsgroup
@ -328,17 +349,34 @@ If the stream is opened, return T, otherwise return NIL."
(buffer-size)
)))
(defun mhspool-request-list-newsgroups ()
"List newsgoups (defined in NNTP2)."
(setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.")
nil
)
(defun mhspool-request-list-distributions ()
"List distributions (defined in NNTP2)."
(setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
nil
)
(defun mhspool-request-last ()
"Set current article pointer to the previous article in the current newsgroup."
(error "MHSPOOL: LAST is not implemented."))
"Set current article pointer to the previous article
in the current news group."
(setq nntp-status-string "MHSPOOL: LAST is not implemented.")
nil
)
(defun mhspool-request-next ()
"Advance current article pointer."
(error "MHSPOOL: NEXT is not implemented."))
(setq nntp-status-string "MHSPOOL: NEXT is not implemented.")
nil
)
(defun mhspool-request-post ()
"Post a new news in current buffer."
(setq nntp-status-message-string "MHSPOOL: what do you mean post?")
(setq nntp-status-string "MHSPOOL: POST: what do you mean?")
nil
)
@ -408,6 +446,45 @@ If the stream is opened, return T, otherwise return NIL."
string
))
;; Methods for listing files in folders.
(defun mhspool-list-folders-using-ls (directory)
"List files in folders under DIRECTORY using 'ls'."
(apply 'call-process
"ls" nil t nil
(append mhspool-list-directory-switches (list directory))))
;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
(defun mhspool-list-folders-using-sh (directory)
"List files in folders under DIRECTORY using '/bin/sh'."
(let ((buffer (current-buffer))
(script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
(save-excursion
(save-restriction
(set-buffer script)
(erase-buffer)
;; /bin/sh script which does 'ls -R'.
(insert
"PS2=
ffind() {
cd $1; echo $1:
ls -1
echo
for j in `echo *[a-zA-Z]*`
do
if [ -d $1/$j ]; then
ffind $1/$j
fi
done
}
cd " directory "; ffind `pwd`; exit 0\n")
(call-process-region (point-min) (point-max) "sh" nil buffer nil)
))
(kill-buffer script)
))
(provide 'mhspool)
;;; mhspool.el ends here

75
lisp/nnspool.el
View file

@ -1,6 +1,6 @@
;;; nnspool.el --- spool access using NNTP for GNU Emacs
;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
@ -37,12 +37,18 @@
(defvar nnspool-active-file "/usr/lib/news/active"
"*Local news active file.")
(defvar nnspool-newsgroups-file "/usr/lib/news/newsgroups"
"*Local news newsgroups file.")
(defvar nnspool-distributions-file "/usr/lib/news/distributions"
"*Local news distributions file.")
(defvar nnspool-history-file "/usr/lib/news/history"
"*Local news history file.")
(defconst nnspool-version "NNSPOOL 1.10"
(defconst nnspool-version "NNSPOOL 1.12"
"Version numbers of this version of NNSPOOL.")
(defvar nnspool-current-directory nil
@ -56,9 +62,10 @@
"Return list of article headers specified by SEQUENCE of article id.
The format of list is
`([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
If there is no References: field, In-Reply-To: field is used instead.
Reader macros for the vector are defined as `nntp-header-FIELD'.
Writer macros for the vector are defined as `nntp-set-header-FIELD'.
News group must be selected before calling me."
Newsgroup must be selected before calling this."
(save-excursion
(set-buffer nntp-server-buffer)
;;(erase-buffer)
@ -139,28 +146,33 @@ News group must be selected before calling me."
(save-excursion (end-of-line) (point))))
(setq xref nil))
;; Extract References:
;; If no References: field, use In-Reply-To: field instead.
(goto-char (point-min))
(if (search-forward "\nReferences: " nil t)
(if (or (search-forward "\nReferences: " nil t)
(search-forward "\nIn-Reply-To: " nil t))
(setq references (buffer-substring
(point)
(save-excursion (end-of-line) (point))))
(setq references nil))
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers))
;; Collect valid article only.
(and article
message-id
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers)))
))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(zerop (% count 20))
(message "NNSPOOL: %d%% of headers received."
(message "NNSPOOL: Receiving headers... %d%%"
(/ (* count 100) number)))
)
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(message "NNSPOOL: 100%% of headers received."))
(message "NNSPOOL: Receiving headers... done"))
(nreverse headers)
)))
@ -175,18 +187,18 @@ If HOST is nil, use value of environment variable `NNTPSERVER'.
If optional argument SERVICE is non-nil, open by the service name."
(let ((host (or host (getenv "NNTPSERVER")))
(status nil))
(setq nntp-status-message-string "")
(setq nntp-status-string "")
(cond ((and (file-directory-p nnspool-spool-directory)
(file-exists-p nnspool-active-file)
(string-equal host (system-name)))
(setq status (nnspool-open-server-internal host service)))
((string-equal host (system-name))
(setq nntp-status-message-string
(setq nntp-status-string
(format "%s has no news spool. Goodbye." host)))
((null host)
(setq nntp-status-message-string "NNTP server is not specified."))
(setq nntp-status-string "NNTP server is not specified."))
(t
(setq nntp-status-message-string
(setq nntp-status-string
(format "NNSPOOL: cannot talk to %s." host)))
)
status
@ -206,7 +218,7 @@ If the stream is opened, return T, otherwise return NIL."
(defun nnspool-status-message ()
"Return server status response as string."
nntp-status-message-string
nntp-status-string
)
(defun nnspool-request-article (id)
@ -247,7 +259,9 @@ If the stream is opened, return T, otherwise return NIL."
(defun nnspool-request-stat (id)
"Select article by message ID (or number)."
(error "NNSPOOL: STAT is not implemented."))
(setq nntp-status-string "NNSPOOL: STAT is not implemented.")
nil
)
(defun nnspool-request-group (group)
"Select news GROUP."
@ -258,17 +272,32 @@ If the stream is opened, return T, otherwise return NIL."
))
(defun nnspool-request-list ()
"List valid newsgoups."
"List active newsgoups."
(save-excursion
(nnspool-find-file nnspool-active-file)))
(defun nnspool-request-list-newsgroups ()
"List newsgroups (defined in NNTP2)."
(save-excursion
(nnspool-find-file nnspool-newsgroups-file)))
(defun nnspool-request-list-distributions ()
"List distributions (defined in NNTP2)."
(save-excursion
(nnspool-find-file nnspool-distributions-file)))
(defun nnspool-request-last ()
"Set current article pointer to the previous article in the current news group."
(error "NNSPOOL: LAST is not implemented."))
"Set current article pointer to the previous article
in the current news group."
(setq nntp-status-string "NNSPOOL: LAST is not implemented.")
nil
)
(defun nnspool-request-next ()
"Advance current article pointer."
(error "NNSPOOL: NEXT is not implemented."))
(setq nntp-status-string "NNSPOOL: NEXT is not implemented.")
nil
)
(defun nnspool-request-post ()
"Post a new news in current buffer."
@ -276,7 +305,7 @@ If the stream is opened, return T, otherwise return NIL."
;; We have to work in the server buffer because of NEmacs hack.
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
(set-buffer nntp-server-buffer)
(apply 'call-process-region
(apply (function call-process-region)
(point-min) (point-max)
nnspool-inews-program 'delete t nil nnspool-inews-switches)
(prog1
@ -289,7 +318,7 @@ If the stream is opened, return T, otherwise return NIL."
(string-match "spooled" (buffer-string)))
;; Make status message by unfolding lines.
(subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
(setq nntp-status-message-string (buffer-string))
(setq nntp-status-string (buffer-string))
(erase-buffer))
))
@ -327,7 +356,7 @@ If the stream is opened, return T, otherwise return NIL."
(setq nntp-server-process nil))
(defun nnspool-find-article-by-message-id (id)
"Return full pathname of an article identified by message-ID."
"Return full pathname of an artilce identified by message-ID."
(save-excursion
(let ((buffer (get-file-buffer nnspool-history-file)))
(if buffer

101
lisp/nntp.el
View file

@ -1,6 +1,6 @@
;;; nntp.el --- NNTP (RFC977) Interface for GNU Emacs
;; Copyright (C) 1987, 1988, 1989, 1990, 1992 Free Software Foundation, Inc.
;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
@ -55,14 +55,20 @@ code, the correct kanji code of the buffer associated with the NNTP
server must be specified as follows:
(setq nntp-server-hook
'(lambda ()
(function
(lambda ()
;; Server's Kanji code is EUC (NEmacs hack).
(make-local-variable 'kanji-fileio-code)
(setq kanji-fileio-code 0)))
(setq kanji-fileio-code 0))))
If you'd like to change something depending on the server in this
hook, use the variable `nntp-server-name'.")
(defvar nntp-large-newsgroup 50
"*The number of the articles which indicates a large newsgroup.
If the number of the articles is greater than the value, verbose
messages will be shown to indicate the current status.")
(defvar nntp-buggy-select (memq system-type '(usg-unix-v fujitsu-uts))
"*T if your select routine is buggy.
If the select routine signals error or fall into infinite loop while
@ -75,13 +81,12 @@ doesn't work properly.")
If Emacs hangs up while retrieving headers, set the variable to a
lower value.")
(defvar nntp-large-newsgroup 50
"*The number of the articles which indicates a large newsgroup.
If the number of the articles is greater than the value, verbose
messages will be shown to indicate the current status.")
(defvar nntp-debug-read 10000
"*Display '...' every 10Kbytes of a message being received if it is non-nil.
If it is a number, dots are displayed per the number.")
(defconst nntp-version "NNTP 3.10"
(defconst nntp-version "NNTP 3.12"
"Version numbers of this version of NNTP.")
(defvar nntp-server-name nil
@ -95,7 +100,7 @@ messages will be shown to indicate the current status.")
You'd better not use this variable in NNTP front-end program but
instead use `nntp-server-buffer'.")
(defvar nntp-status-message-string nil
(defvar nntp-status-string nil
"Save the server response message.
You'd better not use this variable in NNTP front-end program but
instead call function `nntp-status-message' to get status message.")
@ -163,7 +168,7 @@ instead call function `nntp-status-message' to get status message.")
(` (aset (, header) 6 (, id))))
(defmacro nntp-header-references (header)
"Return references in HEADER."
"Return references (or in-reply-to) in HEADER."
(` (aref (, header) 7)))
(defmacro nntp-set-header-references (header ref)
@ -174,9 +179,10 @@ instead call function `nntp-status-message' to get status message.")
"Return list of article headers specified by SEQUENCE of article id.
The format of list is
`([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
If there is no References: field, In-Reply-To: field is used instead.
Reader macros for the vector are defined as `nntp-header-FIELD'.
Writer macros for the vector are defined as `nntp-set-header-FIELD'.
News group must be selected before calling me."
Newsgroup must be selected before calling this."
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
@ -216,7 +222,7 @@ News group must be selected before calling me."
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(zerop (% received 20))
(message "NNTP: %d%% of headers received."
(message "NNTP: Receiving headers... %d%%"
(/ (* received 100) number)))
(nntp-accept-response))
))
@ -231,7 +237,7 @@ News group must be selected before calling me."
(nntp-accept-response)))
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(message "NNTP: 100%% of headers received."))
(message "NNTP: Receiving headers... done"))
;; Now all of replies are received.
(setq received number)
;; First, fold continuation lines.
@ -263,7 +269,7 @@ News group must be selected before calling me."
;; Thanks go to mly@AI.MIT.EDU (Richard Mlynarik)
(while (and (not (eobp))
(not (memq (following-char) '(?2 ?3))))
(if (looking-at "\\(From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\):[ \t]+\\([^ \t\n]+.*\\)\r$")
(if (looking-at "\\(From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\|In-Reply-To\\):[ \t]+\\([^ \t\n]+.*\\)\r$")
(let ((s (buffer-substring
(match-beginning 2) (match-end 2)))
(c (char-after (match-beginning 0))))
@ -280,6 +286,11 @@ News group must be selected before calling me."
(setq xref s))
((char-equal c ?R) ;References:
(setq references s))
;; In-Reply-To: should be used only when
;; there is no References: field.
((and (char-equal c ?I) ;In-Reply-To:
(null references))
(setq references s))
)))
(forward-line 1))
;; Finished to parse one header.
@ -287,10 +298,13 @@ News group must be selected before calling me."
(setq subject "(None)"))
(if (null from)
(setq from "(Unknown User)"))
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers))
;; Collect valid article only.
(and article
message-id
(setq headers
(cons (vector article subject from
xref lines date
message-id references) headers)))
)
(t (forward-line 1))
)
@ -318,7 +332,7 @@ If HOST is nil, use value of environment variable `NNTPSERVER'.
If optional argument SERVICE is non-nil, open by the service name."
(let ((host (or host (getenv "NNTPSERVER")))
(status nil))
(setq nntp-status-message-string "")
(setq nntp-status-string "")
(cond ((and host (nntp-open-server-internal host service))
(setq status (nntp-wait-for-response "^[23].*\r$"))
;; Do check unexpected close of connection.
@ -331,7 +345,7 @@ If optional argument SERVICE is non-nil, open by the service name."
(nntp-close-server-internal)
))
((null host)
(setq nntp-status-message-string "NNTP server is not specified."))
(setq nntp-status-string "NNTP server is not specified."))
)
status
))
@ -362,11 +376,11 @@ If the stream is opened, return T, otherwise return NIL."
(defun nntp-status-message ()
"Return server status response as string."
(if (and nntp-status-message-string
(if (and nntp-status-string
;; NNN MESSAGE
(string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$"
nntp-status-message-string))
(substring nntp-status-message-string (match-beginning 1) (match-end 1))
nntp-status-string))
(substring nntp-status-string (match-beginning 1) (match-end 1))
;; Empty message if nothing.
""
))
@ -405,14 +419,29 @@ If the stream is opened, return T, otherwise return NIL."
(nntp-send-command "^[23].*$" "GROUP" group))
(defun nntp-request-list ()
"List valid newsgoups."
"List active newsgroups."
(prog1
(nntp-send-command "^\\.\r$" "LIST")
(nntp-decode-text)
))
(defun nntp-request-list-newsgroups ()
"List newsgroups (defined in NNTP2)."
(prog1
(nntp-send-command "^\\.\r$" "LIST NEWSGROUPS")
(nntp-decode-text)
))
(defun nntp-request-list-distributions ()
"List distributions (defined in NNTP2)."
(prog1
(nntp-send-command "^\\.\r$" "LIST DISTRIBUTIONS")
(nntp-decode-text)
))
(defun nntp-request-last ()
"Set current article pointer to the previous article in the current news group."
"Set current article pointer to the previous article
in the current news group."
(nntp-send-command "^[23].*\r$" "LAST"))
(defun nntp-request-next ()
@ -514,7 +543,10 @@ If the stream is opened, return T, otherwise return NIL."
"Wait for server response which matches REGEXP."
(save-excursion
(let ((status t)
(wait t))
(wait t)
(dotnum 0) ;Number of "." being displayed.
(dotsize ;How often "." displayed.
(if (numberp nntp-debug-read) nntp-debug-read 10000)))
(set-buffer nntp-server-buffer)
;; Wait for status response (RFC977).
;; 1xx - Informative message.
@ -536,7 +568,7 @@ If the stream is opened, return T, otherwise return NIL."
))
;; Save status message.
(end-of-line)
(setq nntp-status-message-string
(setq nntp-status-string
(buffer-substring (point-min) (point)))
(if status
(progn
@ -549,10 +581,19 @@ If the stream is opened, return T, otherwise return NIL."
;; (save-excursion (end-of-line) (point))))
(if (looking-at regexp)
(setq wait nil)
(message "NNTP: Reading...")
(if nntp-debug-read
(let ((newnum (/ (buffer-size) dotsize)))
(if (not (= dotnum newnum))
(progn
(setq dotnum newnum)
(message "NNTP: Reading %s"
(make-string dotnum ?.))))))
(nntp-accept-response)
(message "")
;;(if nntp-debug-read (message ""))
))
;; Remove "...".
(if (and nntp-debug-read (> dotnum 0))
(message ""))
;; Successfully received server response.
t
))
@ -572,7 +613,7 @@ If the stream is opened, return T, otherwise return NIL."
(setq cmd (concat cmd " " (car strings)))
(setq strings (cdr strings)))
;; Command line must be terminated by a CR-LF.
(process-send-string nntp-server-process (concat cmd "\n"))
(process-send-string nntp-server-process (concat cmd "\r\n"))
))
(defun nntp-send-region-to-server (begin end)