mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2026-09-10 07:46:51 -04:00
Initial revision
This commit is contained in:
root
parent
2af3a0e39b
commit
053282974a
405
lisp/mhspool.el
Normal file
405
lisp/mhspool.el
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
;;; MH folder access using NNTP for GNU Emacs
|
||||
;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD.
|
||||
;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA
|
||||
;; $Header: mhspool.el,v 1.5 90/03/23 13:25:23 umerin Locked $
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
(provide 'mhspool)
|
||||
(require 'nntp)
|
||||
|
||||
;; This package enables you to read mail or articles in MH folders, or
|
||||
;; articles saved by GNUS. In any case, the file names of mail or
|
||||
;; articles must consist of only numeric letters.
|
||||
|
||||
;; Before using this package, you have to create a server specific
|
||||
;; startup file according to the directory which you want to read. For
|
||||
;; example, if you want to read mail under the directory named
|
||||
;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
|
||||
;; no way to specify hierarchical directory now.) In this case, the
|
||||
;; name of the NNTP server passed to GNUS must be `:Mail'.
|
||||
|
||||
(defvar mhspool-list-directory-switches '("-R")
|
||||
"*Switches for nntp-request-list 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"
|
||||
"Version numbers of this version of MHSPOOL.")
|
||||
|
||||
(defvar mhspool-spool-directory "~/Mail"
|
||||
"Private mail directory.")
|
||||
|
||||
(defvar mhspool-current-directory nil
|
||||
"Current news group directory.")
|
||||
|
||||
;;;
|
||||
;;; Replacement of Extended Command for retrieving many headers.
|
||||
;;;
|
||||
|
||||
(defun mhspool-retrieve-headers (sequence)
|
||||
"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] ...)'.
|
||||
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."
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
;;(erase-buffer)
|
||||
(let ((file nil)
|
||||
(number (length sequence))
|
||||
(count 0)
|
||||
(headers nil) ;Result list.
|
||||
(article 0)
|
||||
(subject nil)
|
||||
(message-id nil)
|
||||
(from nil)
|
||||
(xref nil)
|
||||
(lines 0)
|
||||
(date nil)
|
||||
(references nil))
|
||||
(while sequence
|
||||
;;(nntp-send-strings-to-server "HEAD" (car sequence))
|
||||
(setq article (car sequence))
|
||||
(setq file
|
||||
(concat mhspool-current-directory (prin1-to-string article)))
|
||||
(if (and (file-exists-p file)
|
||||
(not (file-directory-p file)))
|
||||
(progn
|
||||
(erase-buffer)
|
||||
(insert-file-contents file)
|
||||
;; Make message body invisible.
|
||||
(goto-char (point-min))
|
||||
(search-forward "\n\n" nil 'move)
|
||||
(narrow-to-region (point-min) (point))
|
||||
;; Fold continuation lines.
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
|
||||
(replace-match " " t t))
|
||||
;; Make it possible to search for `\nFIELD'.
|
||||
(goto-char (point-min))
|
||||
(insert "\n")
|
||||
;; Extract From:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nFrom: " nil t)
|
||||
(setq from (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq from "(Unknown User)"))
|
||||
;; Extract Subject:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nSubject: " nil t)
|
||||
(setq subject (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq subject "(None)"))
|
||||
;; Extract Message-ID:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nMessage-ID: " nil t)
|
||||
(setq message-id (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq message-id nil))
|
||||
;; Extract Date:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nDate: " nil t)
|
||||
(setq date (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq date nil))
|
||||
;; Extract Lines:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nLines: " nil t)
|
||||
(setq lines (string-to-int
|
||||
(buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point)))))
|
||||
(setq lines 0))
|
||||
;; Extract Xref:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nXref: " nil t)
|
||||
(setq xref (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq xref nil))
|
||||
;; Extract References:
|
||||
;; If no References: field, use In-Reply-To: field instead.
|
||||
;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
|
||||
(goto-char (point-min))
|
||||
(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))
|
||||
))
|
||||
(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."
|
||||
(/ (* count 100) number)))
|
||||
)
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(message "MHSPOOL: 100%% of headers received."))
|
||||
(nreverse headers)
|
||||
)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Replacement of NNTP Raw Interface.
|
||||
;;;
|
||||
|
||||
(defun mhspool-open-server (host &optional service)
|
||||
"Open news server on HOST.
|
||||
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))
|
||||
;; Get directory name from HOST name.
|
||||
(if (string-match ":\\(.+\\)$" host)
|
||||
(progn
|
||||
(setq mhspool-spool-directory
|
||||
(file-name-as-directory
|
||||
(expand-file-name
|
||||
(substring host (match-beginning 1) (match-end 1))
|
||||
(expand-file-name "~/" nil))))
|
||||
(setq host (system-name)))
|
||||
(setq mhspool-spool-directory nil))
|
||||
(setq nntp-status-message-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
|
||||
(format "No such directory: %s. Goodbye."
|
||||
mhspool-spool-directory)))
|
||||
((null host)
|
||||
(setq nntp-status-message-string "NNTP server is not specified."))
|
||||
(t
|
||||
(setq nntp-status-message-string
|
||||
(format "MHSPOOL: cannot talk to %s." host)))
|
||||
)
|
||||
status
|
||||
))
|
||||
|
||||
(defun mhspool-close-server ()
|
||||
"Close news server."
|
||||
(mhspool-close-server-internal))
|
||||
|
||||
(fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
|
||||
|
||||
(defun mhspool-server-opened ()
|
||||
"Return server process status, T or NIL.
|
||||
If the stream is opened, return T, otherwise return NIL."
|
||||
(and nntp-server-buffer
|
||||
(get-buffer nntp-server-buffer)))
|
||||
|
||||
(defun mhspool-status-message ()
|
||||
"Return server status response as string."
|
||||
nntp-status-message-string
|
||||
)
|
||||
|
||||
(defun mhspool-request-article (id)
|
||||
"Select article by message ID (or number)."
|
||||
(let ((file (concat mhspool-current-directory (prin1-to-string id))))
|
||||
(if (and (stringp file)
|
||||
(file-exists-p file)
|
||||
(not (file-directory-p file)))
|
||||
(save-excursion
|
||||
(mhspool-find-file file)))
|
||||
))
|
||||
|
||||
(defun mhspool-request-body (id)
|
||||
"Select article body by message ID (or number)."
|
||||
(if (mhspool-request-article id)
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\n\n" nil t)
|
||||
(delete-region (point-min) (point)))
|
||||
t
|
||||
)
|
||||
))
|
||||
|
||||
(defun mhspool-request-head (id)
|
||||
"Select article head by message ID (or number)."
|
||||
(if (mhspool-request-article id)
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\n\n" nil t)
|
||||
(delete-region (1- (point)) (point-max)))
|
||||
t
|
||||
)
|
||||
))
|
||||
|
||||
(defun mhspool-request-stat (id)
|
||||
"Select article by message ID (or number)."
|
||||
(error "MHSPOOL: STAT is not implemented."))
|
||||
|
||||
(defun mhspool-request-group (group)
|
||||
"Select news GROUP."
|
||||
(cond ((file-directory-p
|
||||
(mhspool-article-pathname group))
|
||||
;; Mail/NEWS.GROUP/N
|
||||
(setq mhspool-current-directory
|
||||
(mhspool-article-pathname group)))
|
||||
((file-directory-p
|
||||
(mhspool-article-pathname
|
||||
(mhspool-replace-chars-in-string group ?. ?/)))
|
||||
;; Mail/NEWS/GROUP/N
|
||||
(setq mhspool-current-directory
|
||||
(mhspool-article-pathname
|
||||
(mhspool-replace-chars-in-string group ?. ?/))))
|
||||
))
|
||||
|
||||
(defun mhspool-request-list ()
|
||||
"List valid 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*")))
|
||||
(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)))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward folder-regexp nil t)
|
||||
(setq newsgroup
|
||||
(mhspool-replace-chars-in-string
|
||||
(buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
|
||||
(setq articles nil)
|
||||
(forward-line 1) ;(beginning-of-line)
|
||||
;; Thank nobu@flab.fujitsu.junet for his bug fixes.
|
||||
(while (and (not (eobp))
|
||||
(not (looking-at "^$")))
|
||||
(if (looking-at "^[0-9]+$")
|
||||
(setq articles
|
||||
(cons (string-to-int
|
||||
(buffer-substring
|
||||
(match-beginning 0) (match-end 0)))
|
||||
articles)))
|
||||
(forward-line 1))
|
||||
(if articles
|
||||
(princ (format "%s %d %d n\n" newsgroup
|
||||
(apply (function max) articles)
|
||||
(apply (function min) articles))
|
||||
nntp-server-buffer))
|
||||
)
|
||||
(kill-buffer buffer)
|
||||
(set-buffer nntp-server-buffer)
|
||||
(buffer-size)
|
||||
)))
|
||||
|
||||
(defun mhspool-request-last ()
|
||||
"Set current article pointer to the previous article
|
||||
in the current news group."
|
||||
(error "MHSPOOL: LAST is not implemented."))
|
||||
|
||||
(defun mhspool-request-next ()
|
||||
"Advance current article pointer."
|
||||
(error "MHSPOOL: NEXT is not implemented."))
|
||||
|
||||
(defun mhspool-request-post ()
|
||||
"Post a new news in current buffer."
|
||||
(setq nntp-status-message-string "MHSPOOL: what do you mean post?")
|
||||
nil
|
||||
)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Replacement of Low-Level Interface to NNTP Server.
|
||||
;;;
|
||||
|
||||
(defun mhspool-open-server-internal (host &optional service)
|
||||
"Open connection to news server on HOST by SERVICE (default is nntp)."
|
||||
(save-excursion
|
||||
(if (not (string-equal host (system-name)))
|
||||
(error "MHSPOOL: cannot talk to %s." host))
|
||||
;; Initialize communication buffer.
|
||||
(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
|
||||
(set-buffer nntp-server-buffer)
|
||||
(buffer-flush-undo (current-buffer))
|
||||
(erase-buffer)
|
||||
(kill-all-local-variables)
|
||||
(setq case-fold-search t) ;Should ignore case.
|
||||
(setq nntp-server-process nil)
|
||||
(setq nntp-server-name host)
|
||||
;; It is possible to change kanji-fileio-code in this hook.
|
||||
(run-hooks 'nntp-server-hook)
|
||||
t
|
||||
))
|
||||
|
||||
(defun mhspool-close-server-internal ()
|
||||
"Close connection to news server."
|
||||
(if nntp-server-buffer
|
||||
(kill-buffer nntp-server-buffer))
|
||||
(setq nntp-server-buffer nil)
|
||||
(setq nntp-server-process nil))
|
||||
|
||||
(defun mhspool-find-file (file)
|
||||
"Insert FILE in server buffer safely."
|
||||
(set-buffer nntp-server-buffer)
|
||||
(erase-buffer)
|
||||
(condition-case ()
|
||||
(progn
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
;; If there is no body, `^L' appears at end of file. Special
|
||||
;; hack for MH folder.
|
||||
(and (search-forward "\n\n" nil t)
|
||||
(string-equal (buffer-substring (point) (point-max)) "\^L")
|
||||
(delete-char 1))
|
||||
t
|
||||
)
|
||||
(file-error nil)
|
||||
))
|
||||
|
||||
(defun mhspool-article-pathname (group)
|
||||
"Make pathname for GROUP."
|
||||
(concat (file-name-as-directory mhspool-spool-directory) group "/"))
|
||||
|
||||
(defun mhspool-replace-chars-in-string (string from to)
|
||||
"Replace characters in STRING from FROM to TO."
|
||||
(let ((string (substring string 0)) ;Copy string.
|
||||
(len (length string))
|
||||
(idx 0))
|
||||
;; Replace all occurence of FROM with TO.
|
||||
(while (< idx len)
|
||||
(if (= (aref string idx) from)
|
||||
(aset string idx to))
|
||||
(setq idx (1+ idx)))
|
||||
string
|
||||
))
|
||||
375
lisp/nnspool.el
Normal file
375
lisp/nnspool.el
Normal file
|
|
@ -0,0 +1,375 @@
|
|||
;;; Spool access using NNTP for GNU Emacs
|
||||
;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD.
|
||||
;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA
|
||||
;; $Header: nnspool.el,v 1.10 90/03/23 13:25:25 umerin Locked $
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
(provide 'nnspool)
|
||||
(require 'nntp)
|
||||
|
||||
(defvar nnspool-inews-program news-inews-program
|
||||
"*Program to post news.")
|
||||
|
||||
(defvar nnspool-inews-switches '("-h")
|
||||
"*Switches for nnspool-request-post to pass to `inews' for posting news.")
|
||||
|
||||
(defvar nnspool-spool-directory news-path
|
||||
"*Local news spool directory.")
|
||||
|
||||
(defvar nnspool-active-file "/usr/lib/news/active"
|
||||
"*Local news active file.")
|
||||
|
||||
(defvar nnspool-history-file "/usr/lib/news/history"
|
||||
"*Local news history file.")
|
||||
|
||||
|
||||
|
||||
(defconst nnspool-version "NNSPOOL 1.10"
|
||||
"Version numbers of this version of NNSPOOL.")
|
||||
|
||||
(defvar nnspool-current-directory nil
|
||||
"Current news group directory.")
|
||||
|
||||
;;;
|
||||
;;; Replacement of Extended Command for retrieving many headers.
|
||||
;;;
|
||||
|
||||
(defun nnspool-retrieve-headers (sequence)
|
||||
"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] ...)'.
|
||||
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."
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
;;(erase-buffer)
|
||||
(let ((file nil)
|
||||
(number (length sequence))
|
||||
(count 0)
|
||||
(headers nil) ;Result list.
|
||||
(article 0)
|
||||
(subject nil)
|
||||
(message-id nil)
|
||||
(from nil)
|
||||
(xref nil)
|
||||
(lines 0)
|
||||
(date nil)
|
||||
(references nil))
|
||||
(while sequence
|
||||
;;(nntp-send-strings-to-server "HEAD" (car sequence))
|
||||
(setq article (car sequence))
|
||||
(setq file
|
||||
(concat nnspool-current-directory (prin1-to-string article)))
|
||||
(if (and (file-exists-p file)
|
||||
(not (file-directory-p file)))
|
||||
(progn
|
||||
(erase-buffer)
|
||||
(insert-file-contents file)
|
||||
;; Make message body invisible.
|
||||
(goto-char (point-min))
|
||||
(search-forward "\n\n" nil 'move)
|
||||
(narrow-to-region (point-min) (point))
|
||||
;; Fold continuation lines.
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
|
||||
(replace-match " " t t))
|
||||
;; Make it possible to search for `\nFIELD'.
|
||||
(goto-char (point-min))
|
||||
(insert "\n")
|
||||
;; Extract From:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nFrom: " nil t)
|
||||
(setq from (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq from "(Unknown User)"))
|
||||
;; Extract Subject:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nSubject: " nil t)
|
||||
(setq subject (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq subject "(None)"))
|
||||
;; Extract Message-ID:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nMessage-ID: " nil t)
|
||||
(setq message-id (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq message-id nil))
|
||||
;; Extract Date:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nDate: " nil t)
|
||||
(setq date (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq date nil))
|
||||
;; Extract Lines:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nLines: " nil t)
|
||||
(setq lines (string-to-int
|
||||
(buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point)))))
|
||||
(setq lines 0))
|
||||
;; Extract Xref:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nXref: " nil t)
|
||||
(setq xref (buffer-substring
|
||||
(point)
|
||||
(save-excursion (end-of-line) (point))))
|
||||
(setq xref nil))
|
||||
;; Extract References:
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\nReferences: " 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))
|
||||
))
|
||||
(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."
|
||||
(/ (* count 100) number)))
|
||||
)
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(message "NNSPOOL: 100%% of headers received."))
|
||||
(nreverse headers)
|
||||
)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Replacement of NNTP Raw Interface.
|
||||
;;;
|
||||
|
||||
(defun nnspool-open-server (host &optional service)
|
||||
"Open news server on HOST.
|
||||
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 "")
|
||||
(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
|
||||
(format "%s has no news spool. Goodbye." host)))
|
||||
((null host)
|
||||
(setq nntp-status-message-string "NNTP server is not specified."))
|
||||
(t
|
||||
(setq nntp-status-message-string
|
||||
(format "NNSPOOL: cannot talk to %s." host)))
|
||||
)
|
||||
status
|
||||
))
|
||||
|
||||
(defun nnspool-close-server ()
|
||||
"Close news server."
|
||||
(nnspool-close-server-internal))
|
||||
|
||||
(fset 'nnspool-request-quit (symbol-function 'nnspool-close-server))
|
||||
|
||||
(defun nnspool-server-opened ()
|
||||
"Return server process status, T or NIL.
|
||||
If the stream is opened, return T, otherwise return NIL."
|
||||
(and nntp-server-buffer
|
||||
(get-buffer nntp-server-buffer)))
|
||||
|
||||
(defun nnspool-status-message ()
|
||||
"Return server status response as string."
|
||||
nntp-status-message-string
|
||||
)
|
||||
|
||||
(defun nnspool-request-article (id)
|
||||
"Select article by message ID (or number)."
|
||||
(let ((file (if (stringp id)
|
||||
(nnspool-find-article-by-message-id id)
|
||||
(concat nnspool-current-directory (prin1-to-string id)))))
|
||||
(if (and (stringp file)
|
||||
(file-exists-p file)
|
||||
(not (file-directory-p file)))
|
||||
(save-excursion
|
||||
(nnspool-find-file file)))
|
||||
))
|
||||
|
||||
(defun nnspool-request-body (id)
|
||||
"Select article body by message ID (or number)."
|
||||
(if (nnspool-request-article id)
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\n\n" nil t)
|
||||
(delete-region (point-min) (point)))
|
||||
t
|
||||
)
|
||||
))
|
||||
|
||||
(defun nnspool-request-head (id)
|
||||
"Select article head by message ID (or number)."
|
||||
(if (nnspool-request-article id)
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
(goto-char (point-min))
|
||||
(if (search-forward "\n\n" nil t)
|
||||
(delete-region (1- (point)) (point-max)))
|
||||
t
|
||||
)
|
||||
))
|
||||
|
||||
(defun nnspool-request-stat (id)
|
||||
"Select article by message ID (or number)."
|
||||
(error "NNSPOOL: STAT is not implemented."))
|
||||
|
||||
(defun nnspool-request-group (group)
|
||||
"Select news GROUP."
|
||||
(let ((pathname (nnspool-article-pathname
|
||||
(nnspool-replace-chars-in-string group ?. ?/))))
|
||||
(if (file-directory-p pathname)
|
||||
(setq nnspool-current-directory pathname))
|
||||
))
|
||||
|
||||
(defun nnspool-request-list ()
|
||||
"List valid newsgoups."
|
||||
(save-excursion
|
||||
(nnspool-find-file nnspool-active-file)))
|
||||
|
||||
(defun nnspool-request-last ()
|
||||
"Set current article pointer to the previous article
|
||||
in the current news group."
|
||||
(error "NNSPOOL: LAST is not implemented."))
|
||||
|
||||
(defun nnspool-request-next ()
|
||||
"Advance current article pointer."
|
||||
(error "NNSPOOL: NEXT is not implemented."))
|
||||
|
||||
(defun nnspool-request-post ()
|
||||
"Post a new news in current buffer."
|
||||
(save-excursion
|
||||
;; 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
|
||||
(point-min) (point-max)
|
||||
nnspool-inews-program 'delete t nil nnspool-inews-switches)
|
||||
(prog1
|
||||
(or (zerop (buffer-size))
|
||||
;; If inews returns strings, it must be error message
|
||||
;; unless SPOOLNEWS is defined.
|
||||
;; This condition is very weak, but there is no good rule
|
||||
;; identifying errors when SPOOLNEWS is defined.
|
||||
;; Suggested by ohm@kaba.junet.
|
||||
(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))
|
||||
(erase-buffer))
|
||||
))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Replacement of Low-Level Interface to NNTP Server.
|
||||
;;;
|
||||
|
||||
(defun nnspool-open-server-internal (host &optional service)
|
||||
"Open connection to news server on HOST by SERVICE (default is nntp)."
|
||||
(save-excursion
|
||||
(if (not (string-equal host (system-name)))
|
||||
(error "NNSPOOL: cannot talk to %s." host))
|
||||
;; Initialize communication buffer.
|
||||
(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
|
||||
(set-buffer nntp-server-buffer)
|
||||
(buffer-flush-undo (current-buffer))
|
||||
(erase-buffer)
|
||||
(kill-all-local-variables)
|
||||
(setq case-fold-search t) ;Should ignore case.
|
||||
(setq nntp-server-process nil)
|
||||
(setq nntp-server-name host)
|
||||
;; It is possible to change kanji-fileio-code in this hook.
|
||||
(run-hooks 'nntp-server-hook)
|
||||
t
|
||||
))
|
||||
|
||||
(defun nnspool-close-server-internal ()
|
||||
"Close connection to news server."
|
||||
(if (get-file-buffer nnspool-history-file)
|
||||
(kill-buffer (get-file-buffer nnspool-history-file)))
|
||||
(if nntp-server-buffer
|
||||
(kill-buffer nntp-server-buffer))
|
||||
(setq nntp-server-buffer nil)
|
||||
(setq nntp-server-process nil))
|
||||
|
||||
(defun nnspool-find-article-by-message-id (id)
|
||||
"Return full pathname of an artilce identified by message-ID."
|
||||
(save-excursion
|
||||
(let ((buffer (get-file-buffer nnspool-history-file)))
|
||||
(if buffer
|
||||
(set-buffer buffer)
|
||||
;; Finding history file may take lots of time.
|
||||
(message "Reading history file...")
|
||||
(set-buffer (find-file-noselect nnspool-history-file))
|
||||
(message "Reading history file... done")))
|
||||
;; Search from end of the file. I think this is much faster than
|
||||
;; do from the beginning of the file.
|
||||
(goto-char (point-max))
|
||||
(if (re-search-backward
|
||||
(concat "^" (regexp-quote id)
|
||||
"[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t)
|
||||
(let ((group (buffer-substring (match-beginning 1) (match-end 1)))
|
||||
(number (buffer-substring (match-beginning 2) (match-end 2))))
|
||||
(concat (nnspool-article-pathname
|
||||
(nnspool-replace-chars-in-string group ?. ?/))
|
||||
number))
|
||||
)))
|
||||
|
||||
(defun nnspool-find-file (file)
|
||||
"Insert FILE in server buffer safely."
|
||||
(set-buffer nntp-server-buffer)
|
||||
(erase-buffer)
|
||||
(condition-case ()
|
||||
(progn (insert-file-contents file) t)
|
||||
(file-error nil)
|
||||
))
|
||||
|
||||
(defun nnspool-article-pathname (group)
|
||||
"Make pathname for GROUP."
|
||||
(concat (file-name-as-directory nnspool-spool-directory) group "/"))
|
||||
|
||||
(defun nnspool-replace-chars-in-string (string from to)
|
||||
"Replace characters in STRING from FROM to TO."
|
||||
(let ((string (substring string 0)) ;Copy string.
|
||||
(len (length string))
|
||||
(idx 0))
|
||||
;; Replace all occurence of FROM with TO.
|
||||
(while (< idx len)
|
||||
(if (= (aref string idx) from)
|
||||
(aset string idx to))
|
||||
(setq idx (1+ idx)))
|
||||
string
|
||||
))
|
||||
668
lisp/nntp.el
Normal file
668
lisp/nntp.el
Normal file
|
|
@ -0,0 +1,668 @@
|
|||
;;; NNTP (RFC977) Interface for GNU Emacs
|
||||
;; Copyright (C) 1987, 1988, 1989 Fujitsu Laboratories LTD.
|
||||
;; Copyright (C) 1987, 1988, 1989, 1990 Masanobu UMEDA
|
||||
;; $Header: nntp.el,v 3.10 90/03/23 13:25:27 umerin Locked $
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;; This implementation is tested on both 1.2a and 1.5 version of the
|
||||
;; NNTP package.
|
||||
|
||||
;; Troubleshooting of NNTP
|
||||
;;
|
||||
;; (1) Select routine may signal an error or fall into infinite loop
|
||||
;; while waiting for the server response. In this case, you'd better
|
||||
;; not use byte-compiled codes but original source. If you still have
|
||||
;; a problems with it, set the variable `nntp-buggy-select' to T.
|
||||
;;
|
||||
;; (2) Emacs may hang up while retrieving headers since too many
|
||||
;; requests have been sent to the NNTP server without reading their
|
||||
;; replies. In this case, reduce the number of the requests sent to
|
||||
;; the server at one time by setting the variable
|
||||
;; `nntp-maximum-request' to a lower value.
|
||||
;;
|
||||
;; (3) If the TCP/IP stream (open-network-stream) is not supported by
|
||||
;; emacs, compile and install `tcp.el' and `tcp.c' which is an
|
||||
;; emulation program of the stream. If you modified `tcp.c' for your
|
||||
;; system, please send me the diffs. I'll include some of them in the
|
||||
;; future releases.
|
||||
|
||||
(provide 'nntp)
|
||||
|
||||
(defvar nntp-server-hook nil
|
||||
"*Hooks for the NNTP server.
|
||||
If the kanji code of the NNTP server is different from the local kanji
|
||||
code, the correct kanji code of the buffer associated with the NNTP
|
||||
server must be specified as follows:
|
||||
|
||||
(setq nntp-server-hook
|
||||
'(lambda ()
|
||||
;; Server's Kanji code is EUC (NEmacs hack).
|
||||
(make-local-variable 'kanji-fileio-code)
|
||||
(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-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
|
||||
waiting for the server response, the variable must be set to t. In
|
||||
case of Fujitsu UTS, it is set to T since `accept-process-output'
|
||||
doesn't work properly.")
|
||||
|
||||
(defvar nntp-maximum-request 400
|
||||
"*The maximum number of the requests sent to the NNTP server at one time.
|
||||
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.")
|
||||
|
||||
|
||||
(defconst nntp-version "NNTP 3.10"
|
||||
"Version numbers of this version of NNTP.")
|
||||
|
||||
(defvar nntp-server-name nil
|
||||
"The name of the host running NNTP server.")
|
||||
|
||||
(defvar nntp-server-buffer nil
|
||||
"Buffer associated with NNTP server process.")
|
||||
|
||||
(defvar nntp-server-process nil
|
||||
"The NNTP server process.
|
||||
You'd better not use this variable in NNTP front-end program but
|
||||
instead use `nntp-server-buffer'.")
|
||||
|
||||
(defvar nntp-status-message-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.")
|
||||
|
||||
;;;
|
||||
;;; Extended Command for retrieving many headers.
|
||||
;;;
|
||||
;; Retrieving lots of headers by sending command asynchronously.
|
||||
;; Access functions to headers are defined as macro.
|
||||
|
||||
(defmacro nntp-header-number (header)
|
||||
"Return article number in HEADER."
|
||||
(` (aref (, header) 0)))
|
||||
|
||||
(defmacro nntp-set-header-number (header number)
|
||||
"Set article number of HEADER to NUMBER."
|
||||
(` (aset (, header) 0 (, number))))
|
||||
|
||||
(defmacro nntp-header-subject (header)
|
||||
"Return subject string in HEADER."
|
||||
(` (aref (, header) 1)))
|
||||
|
||||
(defmacro nntp-set-header-subject (header subject)
|
||||
"Set article subject of HEADER to SUBJECT."
|
||||
(` (aset (, header) 1 (, subject))))
|
||||
|
||||
(defmacro nntp-header-from (header)
|
||||
"Return author string in HEADER."
|
||||
(` (aref (, header) 2)))
|
||||
|
||||
(defmacro nntp-set-header-from (header from)
|
||||
"Set article author of HEADER to FROM."
|
||||
(` (aset (, header) 2 (, from))))
|
||||
|
||||
(defmacro nntp-header-xref (header)
|
||||
"Return xref string in HEADER."
|
||||
(` (aref (, header) 3)))
|
||||
|
||||
(defmacro nntp-set-header-xref (header xref)
|
||||
"Set article xref of HEADER to xref."
|
||||
(` (aset (, header) 3 (, xref))))
|
||||
|
||||
(defmacro nntp-header-lines (header)
|
||||
"Return lines in HEADER."
|
||||
(` (aref (, header) 4)))
|
||||
|
||||
(defmacro nntp-set-header-lines (header lines)
|
||||
"Set article lines of HEADER to LINES."
|
||||
(` (aset (, header) 4 (, lines))))
|
||||
|
||||
(defmacro nntp-header-date (header)
|
||||
"Return date in HEADER."
|
||||
(` (aref (, header) 5)))
|
||||
|
||||
(defmacro nntp-set-header-date (header date)
|
||||
"Set article date of HEADER to DATE."
|
||||
(` (aset (, header) 5 (, date))))
|
||||
|
||||
(defmacro nntp-header-id (header)
|
||||
"Return Id in HEADER."
|
||||
(` (aref (, header) 6)))
|
||||
|
||||
(defmacro nntp-set-header-id (header id)
|
||||
"Set article Id of HEADER to ID."
|
||||
(` (aset (, header) 6 (, id))))
|
||||
|
||||
(defmacro nntp-header-references (header)
|
||||
"Return references in HEADER."
|
||||
(` (aref (, header) 7)))
|
||||
|
||||
(defmacro nntp-set-header-references (header ref)
|
||||
"Set article references of HEADER to REF."
|
||||
(` (aset (, header) 7 (, ref))))
|
||||
|
||||
(defun nntp-retrieve-headers (sequence)
|
||||
"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] ...)'.
|
||||
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."
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
(erase-buffer)
|
||||
(let ((number (length sequence))
|
||||
(last-point (point-min))
|
||||
(received 0)
|
||||
(count 0)
|
||||
(headers nil) ;Result list.
|
||||
(article 0)
|
||||
(subject nil)
|
||||
(message-id)
|
||||
(from nil)
|
||||
(xref nil)
|
||||
(lines 0)
|
||||
(date nil)
|
||||
(references nil))
|
||||
;; Send HEAD command.
|
||||
(while sequence
|
||||
(nntp-send-strings-to-server "HEAD" (car sequence))
|
||||
(setq sequence (cdr sequence))
|
||||
(setq count (1+ count))
|
||||
;; Every 400 header requests we have to read stream in order
|
||||
;; to avoid deadlock.
|
||||
(if (or (null sequence) ;All requests have been sent.
|
||||
(zerop (% count nntp-maximum-request)))
|
||||
(progn
|
||||
(accept-process-output)
|
||||
(while (progn
|
||||
(goto-char last-point)
|
||||
;; Count replies.
|
||||
(while (re-search-forward "^[0-9]" nil t)
|
||||
(setq received (1+ received)))
|
||||
(setq last-point (point))
|
||||
(< received count))
|
||||
;; If number of headers is greater than 100, give
|
||||
;; informative messages.
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(zerop (% received 20))
|
||||
(message "NNTP: %d%% of headers received."
|
||||
(/ (* received 100) number)))
|
||||
(nntp-accept-response))
|
||||
))
|
||||
)
|
||||
;; Wait for text of last command.
|
||||
(goto-char (point-max))
|
||||
(re-search-backward "^[0-9]" nil t)
|
||||
(if (looking-at "^[23]")
|
||||
(while (progn
|
||||
(goto-char (- (point-max) 3))
|
||||
(not (looking-at "^\\.\r$")))
|
||||
(nntp-accept-response)))
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(message "NNTP: 100%% of headers received."))
|
||||
;; Now all of replies are received.
|
||||
(setq received number)
|
||||
;; First, fold continuation lines.
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
|
||||
(replace-match " " t t))
|
||||
;;(delete-non-matching-lines
|
||||
;; "^Subject:\\|^Xref:\\|^From:\\|^Lines:\\|^Date:\\|^References:\\|^[23]")
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(message "NNTP: Parsing headers..."))
|
||||
;; Then examines replies.
|
||||
(goto-char (point-min))
|
||||
(while (not (eobp))
|
||||
(cond ((looking-at "^[23][0-9][0-9][ \t]+\\([0-9]+\\)[ \t]+\\(<[^>]+>\\)")
|
||||
(setq article
|
||||
(string-to-int
|
||||
(buffer-substring (match-beginning 1) (match-end 1))))
|
||||
(setq message-id
|
||||
(buffer-substring (match-beginning 2) (match-end 2)))
|
||||
(forward-line 1)
|
||||
;; Set default value.
|
||||
(setq subject nil)
|
||||
(setq xref nil)
|
||||
(setq from nil)
|
||||
(setq lines 0)
|
||||
(setq date nil)
|
||||
(setq references nil)
|
||||
;; 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$")
|
||||
(let ((s (buffer-substring
|
||||
(match-beginning 2) (match-end 2)))
|
||||
(c (char-after (match-beginning 0))))
|
||||
;; We don't have to worry about letter case.
|
||||
(cond ((char-equal c ?F) ;From:
|
||||
(setq from s))
|
||||
((char-equal c ?S) ;Subject:
|
||||
(setq subject s))
|
||||
((char-equal c ?D) ;Date:
|
||||
(setq date s))
|
||||
((char-equal c ?L) ;Lines:
|
||||
(setq lines (string-to-int s)))
|
||||
((char-equal c ?X) ;Xref:
|
||||
(setq xref s))
|
||||
((char-equal c ?R) ;References:
|
||||
(setq references s))
|
||||
)))
|
||||
(forward-line 1))
|
||||
;; Finished to parse one header.
|
||||
(if (null subject)
|
||||
(setq subject "(None)"))
|
||||
(if (null from)
|
||||
(setq from "(Unknown User)"))
|
||||
(setq headers
|
||||
(cons (vector article subject from
|
||||
xref lines date
|
||||
message-id references) headers))
|
||||
)
|
||||
(t (forward-line 1))
|
||||
)
|
||||
(setq received (1- received))
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(zerop (% received 20))
|
||||
(message "NNTP: Parsing headers... %d%%"
|
||||
(/ (* received 100) number)))
|
||||
)
|
||||
(and (numberp nntp-large-newsgroup)
|
||||
(> number nntp-large-newsgroup)
|
||||
(message "NNTP: Parsing headers... done"))
|
||||
(nreverse headers)
|
||||
)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Raw Interface to Network News Transfer Protocol (RFC977).
|
||||
;;;
|
||||
|
||||
(defun nntp-open-server (host &optional service)
|
||||
"Open news server on HOST.
|
||||
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 "")
|
||||
(cond ((and host (nntp-open-server-internal host service))
|
||||
(setq status (nntp-wait-for-response "^[23].*\r$"))
|
||||
;; Do check unexpected close of connection.
|
||||
;; Suggested by feldmark@hanako.stars.flab.fujitsu.junet.
|
||||
(if status
|
||||
(set-process-sentinel nntp-server-process
|
||||
'nntp-default-sentinel)
|
||||
;; We have to close connection here, since function
|
||||
;; `nntp-server-opened' may return incorrect status.
|
||||
(nntp-close-server-internal)
|
||||
))
|
||||
((null host)
|
||||
(setq nntp-status-message-string "NNTP server is not specified."))
|
||||
)
|
||||
status
|
||||
))
|
||||
|
||||
(defun nntp-close-server ()
|
||||
"Close news server."
|
||||
(unwind-protect
|
||||
(progn
|
||||
;; Un-set default sentinel function before closing connection.
|
||||
(and nntp-server-process
|
||||
(eq 'nntp-default-sentinel
|
||||
(process-sentinel nntp-server-process))
|
||||
(set-process-sentinel nntp-server-process nil))
|
||||
;; We cannot send QUIT command unless the process is running.
|
||||
(if (nntp-server-opened)
|
||||
(nntp-send-command nil "QUIT"))
|
||||
)
|
||||
(nntp-close-server-internal)
|
||||
))
|
||||
|
||||
(fset 'nntp-request-quit (symbol-function 'nntp-close-server))
|
||||
|
||||
(defun nntp-server-opened ()
|
||||
"Return server process status, T or NIL.
|
||||
If the stream is opened, return T, otherwise return NIL."
|
||||
(and nntp-server-process
|
||||
(memq (process-status nntp-server-process) '(open run))))
|
||||
|
||||
(defun nntp-status-message ()
|
||||
"Return server status response as string."
|
||||
(if (and nntp-status-message-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))
|
||||
;; Empty message if nothing.
|
||||
""
|
||||
))
|
||||
|
||||
(defun nntp-request-article (id)
|
||||
"Select article by message ID (or number)."
|
||||
(prog1
|
||||
;; If NEmacs, end of message may look like: "\256\215" (".^M")
|
||||
(nntp-send-command "^\\.\r$" "ARTICLE" id)
|
||||
(nntp-decode-text)
|
||||
))
|
||||
|
||||
(defun nntp-request-body (id)
|
||||
"Select article body by message ID (or number)."
|
||||
(prog1
|
||||
;; If NEmacs, end of message may look like: "\256\215" (".^M")
|
||||
(nntp-send-command "^\\.\r$" "BODY" id)
|
||||
(nntp-decode-text)
|
||||
))
|
||||
|
||||
(defun nntp-request-head (id)
|
||||
"Select article head by message ID (or number)."
|
||||
(prog1
|
||||
(nntp-send-command "^\\.\r$" "HEAD" id)
|
||||
(nntp-decode-text)
|
||||
))
|
||||
|
||||
(defun nntp-request-stat (id)
|
||||
"Select article by message ID (or number)."
|
||||
(nntp-send-command "^[23].*\r$" "STAT" id))
|
||||
|
||||
(defun nntp-request-group (group)
|
||||
"Select news GROUP."
|
||||
;; 1.2a NNTP's group command is buggy. "^M" (\r) is not appended to
|
||||
;; end of the status message.
|
||||
(nntp-send-command "^[23].*$" "GROUP" group))
|
||||
|
||||
(defun nntp-request-list ()
|
||||
"List valid newsgoups."
|
||||
(prog1
|
||||
(nntp-send-command "^\\.\r$" "LIST")
|
||||
(nntp-decode-text)
|
||||
))
|
||||
|
||||
(defun nntp-request-last ()
|
||||
"Set current article pointer to the previous article
|
||||
in the current news group."
|
||||
(nntp-send-command "^[23].*\r$" "LAST"))
|
||||
|
||||
(defun nntp-request-next ()
|
||||
"Advance current article pointer."
|
||||
(nntp-send-command "^[23].*\r$" "NEXT"))
|
||||
|
||||
(defun nntp-request-post ()
|
||||
"Post a new news in current buffer."
|
||||
(if (nntp-send-command "^[23].*\r$" "POST")
|
||||
(progn
|
||||
(nntp-encode-text)
|
||||
(nntp-send-region-to-server (point-min) (point-max))
|
||||
;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
|
||||
;; appended to end of the status message.
|
||||
(nntp-wait-for-response "^[23].*$")
|
||||
)))
|
||||
|
||||
(defun nntp-default-sentinel (proc status)
|
||||
"Default sentinel function for NNTP server process."
|
||||
(if (and nntp-server-process
|
||||
(not (nntp-server-opened)))
|
||||
(error "NNTP: Connection closed.")
|
||||
))
|
||||
|
||||
;; Encoding and decoding of NNTP text.
|
||||
|
||||
(defun nntp-decode-text ()
|
||||
"Decode text transmitted by NNTP.
|
||||
0. Delete status line.
|
||||
1. Delete `^M' at end of line.
|
||||
2. Delete `.' at end of buffer (end of text mark).
|
||||
3. Delete `.' at beginning of line."
|
||||
(save-excursion
|
||||
(set-buffer nntp-server-buffer)
|
||||
;; Insert newline at end of buffer.
|
||||
(goto-char (point-max))
|
||||
(if (not (bolp))
|
||||
(insert "\n"))
|
||||
;; Delete status line.
|
||||
(goto-char (point-min))
|
||||
(delete-region (point) (progn (forward-line 1) (point)))
|
||||
;; Delete `^M' at end of line.
|
||||
;; (replace-regexp "\r$" "")
|
||||
(while (not (eobp))
|
||||
(end-of-line)
|
||||
(if (= (preceding-char) ?\r)
|
||||
(delete-char -1))
|
||||
(forward-line 1)
|
||||
)
|
||||
;; Delete `.' at end of buffer (end of text mark).
|
||||
(goto-char (point-max))
|
||||
(forward-line -1) ;(beginning-of-line)
|
||||
(if (looking-at "^\\.$")
|
||||
(delete-region (point) (progn (forward-line 1) (point))))
|
||||
;; Replace `..' at beginning of line with `.'.
|
||||
(goto-char (point-min))
|
||||
;; (replace-regexp "^\\.\\." ".")
|
||||
(while (search-forward "\n.." nil t)
|
||||
(delete-char -1))
|
||||
))
|
||||
|
||||
(defun nntp-encode-text ()
|
||||
"Encode text in current buffer for NNTP transmission.
|
||||
1. Insert `.' at beginning of line.
|
||||
2. Insert `.' at end of buffer (end of text mark)."
|
||||
(save-excursion
|
||||
;; Insert newline at end of buffer.
|
||||
(goto-char (point-max))
|
||||
(if (not (bolp))
|
||||
(insert "\n"))
|
||||
;; Replace `.' at beginning of line with `..'.
|
||||
(goto-char (point-min))
|
||||
;; (replace-regexp "^\\." "..")
|
||||
(while (search-forward "\n." nil t)
|
||||
(insert "."))
|
||||
;; Insert `.' at end of buffer (end of text mark).
|
||||
(goto-char (point-max))
|
||||
(insert ".\n")
|
||||
))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Synchronous Communication with NNTP Server.
|
||||
;;;
|
||||
|
||||
(defun nntp-send-command (response cmd &rest args)
|
||||
"Wait for server RESPONSE after sending CMD and optional ARGS to server."
|
||||
(save-excursion
|
||||
;; Clear communication buffer.
|
||||
(set-buffer nntp-server-buffer)
|
||||
(erase-buffer)
|
||||
(apply 'nntp-send-strings-to-server cmd args)
|
||||
(if response
|
||||
(nntp-wait-for-response response)
|
||||
t)
|
||||
))
|
||||
|
||||
(defun nntp-wait-for-response (regexp)
|
||||
"Wait for server response which matches REGEXP."
|
||||
(save-excursion
|
||||
(let ((status t)
|
||||
(wait t))
|
||||
(set-buffer nntp-server-buffer)
|
||||
;; Wait for status response (RFC977).
|
||||
;; 1xx - Informative message.
|
||||
;; 2xx - Command ok.
|
||||
;; 3xx - Command ok so far, send the rest of it.
|
||||
;; 4xx - Command was correct, but couldn't be performed for some
|
||||
;; reason.
|
||||
;; 5xx - Command unimplemented, or incorrect, or a serious
|
||||
;; program error occurred.
|
||||
(nntp-accept-response)
|
||||
(while wait
|
||||
(goto-char (point-min))
|
||||
(cond ((looking-at "[23]")
|
||||
(setq wait nil))
|
||||
((looking-at "[45]")
|
||||
(setq status nil)
|
||||
(setq wait nil))
|
||||
(t (nntp-accept-response))
|
||||
))
|
||||
;; Save status message.
|
||||
(end-of-line)
|
||||
(setq nntp-status-message-string
|
||||
(buffer-substring (point-min) (point)))
|
||||
(if status
|
||||
(progn
|
||||
(setq wait t)
|
||||
(while wait
|
||||
(goto-char (point-max))
|
||||
(forward-line -1) ;(beginning-of-line)
|
||||
;;(message (buffer-substring
|
||||
;; (point)
|
||||
;; (save-excursion (end-of-line) (point))))
|
||||
(if (looking-at regexp)
|
||||
(setq wait nil)
|
||||
(message "NNTP: Reading...")
|
||||
(nntp-accept-response)
|
||||
(message "")
|
||||
))
|
||||
;; Successfully received server response.
|
||||
t
|
||||
))
|
||||
)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Low-Level Interface to NNTP Server.
|
||||
;;;
|
||||
|
||||
(defun nntp-send-strings-to-server (&rest strings)
|
||||
"Send list of STRINGS to news server as command and its arguments."
|
||||
(let ((cmd (car strings))
|
||||
(strings (cdr strings)))
|
||||
;; Command and each argument must be separeted by one or more spaces.
|
||||
(while strings
|
||||
(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"))
|
||||
))
|
||||
|
||||
(defun nntp-send-region-to-server (begin end)
|
||||
"Send current buffer region (from BEGIN to END) to news server."
|
||||
(save-excursion
|
||||
;; We have to work in the buffer associated with NNTP server
|
||||
;; process because of NEmacs hack.
|
||||
(copy-to-buffer nntp-server-buffer begin end)
|
||||
(set-buffer nntp-server-buffer)
|
||||
(setq begin (point-min))
|
||||
(setq end (point-max))
|
||||
;; `process-send-region' does not work if text to be sent is very
|
||||
;; large. I don't know maximum size of text sent correctly.
|
||||
(let ((last nil)
|
||||
(size 100)) ;Size of text sent at once.
|
||||
(save-restriction
|
||||
(narrow-to-region begin end)
|
||||
(goto-char begin)
|
||||
(while (not (eobp))
|
||||
;;(setq last (min end (+ (point) size)))
|
||||
;; NEmacs gets confused if character at `last' is Kanji.
|
||||
(setq last (save-excursion
|
||||
(goto-char (min end (+ (point) size)))
|
||||
(or (eobp) (forward-char 1)) ;Adjust point
|
||||
(point)))
|
||||
(process-send-region nntp-server-process (point) last)
|
||||
;; I don't know whether the next codes solve the known
|
||||
;; problem of communication error of GNU Emacs.
|
||||
(accept-process-output)
|
||||
;;(sit-for 0)
|
||||
(goto-char last)
|
||||
)))
|
||||
;; We cannot erase buffer, because reply may be received.
|
||||
(delete-region begin end)
|
||||
))
|
||||
|
||||
(defun nntp-open-server-internal (host &optional service)
|
||||
"Open connection to news server on HOST by SERVICE (default is nntp)."
|
||||
(save-excursion
|
||||
;; Use TCP/IP stream emulation package if needed.
|
||||
(or (fboundp 'open-network-stream)
|
||||
(require 'tcp))
|
||||
;; Initialize communication buffer.
|
||||
(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
|
||||
(set-buffer nntp-server-buffer)
|
||||
(buffer-flush-undo (current-buffer))
|
||||
(erase-buffer)
|
||||
(kill-all-local-variables)
|
||||
(setq case-fold-search t) ;Should ignore case.
|
||||
(setq nntp-server-process
|
||||
(open-network-stream "nntpd" (current-buffer)
|
||||
host (or service "nntp")))
|
||||
(setq nntp-server-name host)
|
||||
;; It is possible to change kanji-fileio-code in this hook.
|
||||
(run-hooks 'nntp-server-hook)
|
||||
;; Return the server process.
|
||||
nntp-server-process
|
||||
))
|
||||
|
||||
(defun nntp-close-server-internal ()
|
||||
"Close connection to news server."
|
||||
(if nntp-server-process
|
||||
(delete-process nntp-server-process))
|
||||
(if nntp-server-buffer
|
||||
(kill-buffer nntp-server-buffer))
|
||||
(setq nntp-server-buffer nil)
|
||||
(setq nntp-server-process nil))
|
||||
|
||||
(defun nntp-accept-response ()
|
||||
"Read response of server.
|
||||
It is well-known that the communication speed will be much improved by
|
||||
defining this function as macro."
|
||||
;; To deal with server process exiting before
|
||||
;; accept-process-output is called.
|
||||
;; Suggested by Jason Venner <jason@violet.berkeley.edu>.
|
||||
;; This is a copy of `nntp-default-sentinel'.
|
||||
(or (memq (process-status nntp-server-process) '(open run))
|
||||
(error "NNTP: Connection closed."))
|
||||
(if nntp-buggy-select
|
||||
(progn
|
||||
;; We cannot use `accept-process-output'.
|
||||
;; Fujitsu UTS requires messages during sleep-for. I don't know why.
|
||||
(message "NNTP: Reading...")
|
||||
(sleep-for 1)
|
||||
(message ""))
|
||||
(condition-case errorcode
|
||||
(accept-process-output nntp-server-process)
|
||||
(error
|
||||
(cond ((string-equal "select error: Invalid argument" (nth 1 errorcode))
|
||||
;; Ignore select error.
|
||||
nil
|
||||
)
|
||||
(t
|
||||
(signal (car errorcode) (cdr errorcode))))
|
||||
))
|
||||
))
|
||||
Loading…
Reference in a new issue