Path: utzoo!utgpu!water!watmath!clyde!att!osu-cis!tut.cis.ohio-state.edu!mailrus!ames!pasteur!ucbvax!decwrl!sun!pitstop!sundc!seismo!uunet!kddlab!ccut!titcca!fgw!flab!umerin
From: umerin@flab.flab.fujitsu.JUNET (Masanobu UMEDA)
Newsgroups: comp.emacs,fj.editor.emacs
Subject: GNUS 3.8: a NNTP-base news reader for GNU Emacs (4 of 4)
Message-ID: <4129@flab.flab.fujitsu.JUNET>
Date: 19 Sep 88 03:23:26 GMT
Reply-To: umerin@flab.flab.fujitsu.JUNET (Masanobu UMEDA)
Organization: Fujitsu Laboratories Ltd., Kawasaki, Japan
Lines: 595

---- Cut Here and unpack ----
#!/bin/sh
# this is part 4 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file nntp.el continued
#
CurArch=4
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
     exit 1; fi
( read Scheck
  if test "$Scheck" != $CurArch
  then echo "Please unpack part $Scheck next!"
       exit 1;
  else exit 0; fi
) < s2_seq_.tmp || exit 1
sed 's/^X//' << 'SHAR_EOF' >> nntp.el
Xinstead call function `nntp-status-message' to get status message.")
X
X;;;
X;;; Extended Command for retrieving many headers.
X;;;
X;; Retrieving lots of headers by sending command asynchronously.
X;; Access functions to headers are defined as macro.
X
X(defmacro nntp-header-number (header)
X  "Return article number in HEADER."
X  (` (aref (, header) 0)))
X
X(defmacro nntp-set-header-number (header number)
X  "Set article number of HEADER to NUMBER."
X  (` (aset (, header) 0 (, number))))
X
X(defmacro nntp-header-subject (header)
X  "Return subject string in HEADER."
X  (` (aref (, header) 1)))
X
X(defmacro nntp-set-header-subject (header subject)
X  "Set article subject of HEADER to SUBJECT."
X  (` (aset (, header) 1 (, subject))))
X
X(defmacro nntp-header-from (header)
X  "Return author string in HEADER."
X  (` (aref (, header) 2)))
X
X(defmacro nntp-set-header-from (header from)
X  "Set article author of HEADER to FROM."
X  (` (aset (, header) 2 (, from))))
X
X(defmacro nntp-header-xref (header)
X  "Return xref string in HEADER."
X  (` (aref (, header) 3)))
X
X(defmacro nntp-set-header-xref (header xref)
X  "Set article xref of HEADER to xref."
X  (` (aset (, header) 3 (, xref))))
X
X(defmacro nntp-header-lines (header)
X  "Return lines in HEADER."
X  (` (aref (, header) 4)))
X
X(defmacro nntp-set-header-lines (header lines)
X  "Set article lines of HEADER to LINES."
X  (` (aset (, header) 4 (, lines))))
X
X(defmacro nntp-header-date (header)
X  "Return date in HEADER."
X  (` (aref (, header) 5)))
X
X(defmacro nntp-set-header-date (header date)
X  "Set article date of HEADER to DATE."
X  (` (aset (, header) 5 (, date))))
X
X(defmacro nntp-header-id (header)
X  "Return date in HEADER."
X  (` (aref (, header) 6)))
X
X(defmacro nntp-set-header-id (header id)
X  "Set article ID of HEADER to ID."
X  (` (aset (, header) 6 (, id))))
X
X(defun nntp-retrieve-headers (sequence)
X  "Return list of article headers specified by SEQUENCE of article id.
XThe format of list is `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID] ...)'.
XReader macros for the vector are defined as `nntp-header-FIELD'.
XWriter macros for the vector are defined as `nntp-set-header-FIELD'.
XNews group must be selected before calling me."
X  (save-excursion
X    (set-buffer nntp-server-buffer)
X    (erase-buffer)
X    (let ((number (length sequence))
X	  (last-point (point-min))
X	  (received 0)
X	  (count 0)
X	  (headers nil)			;Result list.
X	  (article 0)
X	  (subject nil)
X	  (message-id)
X	  (from nil)
X	  (xref nil)
X	  (lines 0)
X	  (date nil))
X      ;; Send HEAD command.
X      (while sequence
X	(nntp-send-strings-to-server "HEAD" (car sequence))
X	(setq sequence (cdr sequence))
X	(setq count (1+ count))
X	;; Every 400 header requests we have to read stream in order
X	;;  to avoid deadlock.
X	(if (or (null sequence)		;All requests have been sent.
X		(zerop (% count nntp-maximum-request)))
X	    (progn
X	      (accept-process-output)
X	      (while (progn
X		       (goto-char last-point)
X		       ;; Count replies.
X		       (while (re-search-forward "^[0-9]" nil t)
X			 (setq received (1+ received)))
X		       (setq last-point (point))
X		       (< received count))
X		;; If number of headers is greater than 100, give
X		;;  informative messages.
X		(if (and (> number 100)
X			 (zerop (% received 20)))
X		    (message "NNTP: %d%% of headers received."
X			     (/ (* received 100) number)))
X		(nntp-accept-response))
X	      ))
X	)
X      ;; Wait for text of last command.
X      (goto-char (point-max))
X      (re-search-backward "^[0-9]")
X      (if (looking-at "^[23]")
X	  (while (progn
X		   (goto-char (- (point-max) 3))
X		   (not (looking-at "^\\.\r$")))
X	    (nntp-accept-response)
X	    ))
X      (if (> number 100)
X	  (message "NNTP: 100%% of headers received."))
X      ;; Now all of replies are received.
X      ;; First, delete unnecessary lines.
X      (goto-char (point-min))
X      (delete-non-matching-lines
X       "^Subject:\\|^Xref:\\|^From:\\|^Lines:\\|^Date:\\|^[23]")
X      (if (> number 100)
X	  (message "NNTP: Parsing headers..."))
X      ;; Then examines replies.
X      (while (not (eobp))
X	(cond ((looking-at "^[23].*[ \t]+\\([0-9]+\\)[ \t]+\\(<.+>\\)")
X	       (setq article
X		     (string-to-int
X		      (buffer-substring (match-beginning 1) (match-end 1))))
X	       (setq message-id
X		     (buffer-substring (match-beginning 2) (match-end 2)))
X	       (forward-line 1)
X	       ;; Set default value.
X	       (setq subject nil)
X	       (setq xref nil)
X	       (setq from nil)
X	       (setq lines 0)
X	       (setq date nil)
X	       ;; It is better to extract From:, Subject:, Date:,
X	       ;;  Lines: and Xref: field values in *THIS* order.
X	       ;; Forward-line each time after getting expected value
X	       ;;  in order to reduce count of string matching.
X	       (while (looking-at "^[^23]")
X		 (if (looking-at "^From:[ \t]\\(.*\\)\r$")
X		     (progn
X		       (setq from (buffer-substring (match-beginning 1)
X						    (match-end 1)))
X		       (forward-line 1)))
X		 (if (looking-at "^Subject:[ \t]\\(.*\\)\r$")
X		     (progn
X		       (setq subject (buffer-substring (match-beginning 1)
X						       (match-end 1)))
X		       (forward-line 1)))
X		 (if (looking-at "^Date:[ \t]\\(.*\\)\r$")
X		     (progn
X		       (setq date (buffer-substring (match-beginning 1)
X						    (match-end 1)))
X		       (forward-line 1)))
X		 (if (looking-at "^Lines:[ \t]\\(.*\\)\r$")
X		     (progn
X		       (setq lines (string-to-int
X				    (buffer-substring (match-beginning 1)
X						      (match-end 1))))
X		       (forward-line 1)))
X		 (if (looking-at "^Xref:[ \t]\\(.*\\)\r$")
X		     (progn
X		       (setq xref (buffer-substring (match-beginning 1)
X						    (match-end 1)))
X		       (forward-line 1)))
X		 )
X	       (if (null subject)
X		   (setq subject "(None)"))
X	       (if (null from)
X		   (setq from "Unknown User"))
X	       (setq headers
X		     (cons (vector article subject from
X				   xref lines date message-id)
X			   headers))
X	       )
X	      (t (forward-line 1))	;Skip invalid field (ex. Subject:abc)
X	      ))
X      (nreverse headers)
X      )))
X
X(defun nntp-find-header-by-number (headers number)
X  "Return a header which is a element of HEADERS and has NUMBER."
X  (let ((found nil))
X    (while (and headers (not found))
X      (if (eq number (nntp-header-number (car headers)))
X	  (setq found (car headers)))
X      (setq headers (cdr headers)))
X    found
X    ))
X
X(defun nntp-find-header-by-id (headers id)
X  "Return a header which is a element of HEADERS and has message-ID."
X  (let ((found nil))
X    (while (and headers (not found))
X      (if (string-equal id (nntp-header-id (car headers)))
X	  (setq found (car headers)))
X      (setq headers (cdr headers)))
X    found
X    ))
X
X
X;;;
X;;; Raw Interface to Network News Transfer Protocol (RFC977).
X;;;
X
X(defun nntp-open-server (host &optional service)
X  "Open news server on HOST.
XIf HOST is nil, use value of environment variable `NNTPSERVER'.
XIf optional argument SERVICE is non-nil, open by the service name."
X  (let ((host (or host
X		  (getenv "NNTPSERVER")
X		  (error "NNTP: no server host is specified."))))
X    (setq nntp-status-message-string "")
X    (if (nntp-open-server-internal host service)
X	(let ((status (nntp-wait-for-response "^[23].*\r$")))
X	  ;; Do check unexpected close of connection.
X	  ;; Suggested by feldmark@hanako.stars.flab.fujitsu.junet.
X	  (if status
X	      (set-process-sentinel nntp-server-process 'nntp-default-sentinel)
X	    ;; We have to close connection here, since function
X	    ;;  `nntp-server-opened' may return incorrect status.
X	    (nntp-close-server-internal))
X	  status
X	  ))
X    ))
X
X(defun nntp-close-server ()
X  "Close news server."
X  (unwind-protect
X      (progn
X	;; Un-set default sentinel function before closing connection.
X	(and nntp-server-process
X	     (eq 'nntp-default-sentinel
X		 (process-sentinel nntp-server-process))
X	     (set-process-sentinel nntp-server-process nil))
X	;; We cannot send QUIT command unless the process is running.
X	(if (nntp-server-opened)
X	    (nntp-send-command nil "QUIT"))
X	)
X    (nntp-close-server-internal)
X    ))
X
X(fset 'nntp-request-quit (symbol-function 'nntp-close-server))
X
X(defun nntp-server-opened ()
X  "Return server process status, T or NIL.
XIf the stream is opened, return T, otherwise return NIL."
X  (and nntp-server-process
X       (memq (process-status nntp-server-process) '(open run))))
X
X(defun nntp-status-message ()
X  "Return server status response as string."
X  (if (and nntp-status-message-string
X	   ;; NNN MESSAGE
X	   (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$"
X			 nntp-status-message-string))
X      (substring nntp-status-message-string (match-beginning 1) (match-end 1))
X    ;; Empty message if nothing.
X    ""
X    ))
X
X(defun nntp-request-article (id)
X  "Select article by message ID (or number)."
X  (prog1
X      (nntp-send-command "^\\.\r$" "ARTICLE" id)
X    (nntp-decode-text)
X    ))
X
X(defun nntp-request-body (id)
X  "Select article body by message ID (or number)."
X  (prog1
X      (nntp-send-command "^\\.\r$" "BODY" id)
X    (nntp-decode-text)
X    ))
X
X(defun nntp-request-head (id)
X  "Select article head by message ID (or number)."
X  (prog1
X      (nntp-send-command "^\\.\r$" "HEAD" id)
X    (nntp-decode-text)
X    ))
X
X(defun nntp-request-stat (id)
X  "Select article by message ID (or number)."
X  (nntp-send-command "^[23].*\r$" "STAT" id))
X
X(defun nntp-request-group (group)
X  "Select news GROUP."
X  ;; 1.2a NNTP's group command is buggy. "^M" (\r) is not appended to
X  ;;  end of the status message.
X  (nntp-send-command "^[23].*$" "GROUP" group))
X
X(defun nntp-request-list ()
X  "List valid newsgoups."
X  (prog1
X      (nntp-send-command "^\\.\r$" "LIST")
X    (nntp-decode-text)
X    ))
X
X(defun nntp-request-last ()
X  "Set current article pointer to the previous article
Xin the current news group."
X  (nntp-send-command "^[23].*\r$" "LAST"))
X
X(defun nntp-request-next ()
X  "Advance current article pointer."
X  (nntp-send-command "^[23].*\r$" "NEXT"))
X
X(defun nntp-request-post ()
X  "Post a new news in current buffer."
X  (if (nntp-send-command "^[23].*\r$" "POST")
X      (progn
X	(nntp-encode-text)
X	(nntp-send-region-to-server (point-min) (point-max))
X	;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
X	;;  appended to end of the status message.
X	(nntp-wait-for-response "^[23].*$")
X	)))
X
X(defun nntp-default-sentinel (proc status)
X  "Default sentinel function for NNTP server process."
X  (if (and nntp-server-process
X	   (not (nntp-server-opened)))
X      (error "NNTP: Connection closed.")
X    ))
X
X;; Encoding and decoding of NNTP text.
X
X(defun nntp-decode-text ()
X  "Decode text transmitted by NNTP.
X0. Delete status line.
X1. Delete `^M' at end of line.
X2. Delete `.' at end of buffer (end of text mark).
X3. Delete `.' at beginning of line."
X  (save-excursion
X    (set-buffer nntp-server-buffer)
X    ;; Insert newline at end of buffer.
X    (goto-char (point-max))
X    (if (not (bolp))
X	(insert "\n"))
X    ;; Delete status line.
X    (goto-char (point-min))
X    (kill-line 1)
X    ;; Delete `^M' at end of line.
X    ;; (replace-regexp "\r$" "")
X    (while (not (eobp))
X      (end-of-line)
X      (forward-char -1)
X      (if (looking-at "\r$")
X	  (delete-char 1))
X      (forward-line 1)
X      )
X    ;; Delete `.' at end of buffer (end of text mark).
X    (goto-char (point-max))
X    (forward-line -1)
X    (beginning-of-line)
X    (if (looking-at "^\\.$")
X	(kill-line 1))
X    ;; Replace `..' at beginning of line with `.'.
X    (goto-char (point-min))
X    ;; (replace-regexp "^\\.\\." ".")
X    (while (not (eobp))
X      (if (looking-at "^\\.\\.")
X	  (delete-char 1))
X      (forward-line 1)
X      (beginning-of-line))
X    ))
X
X(defun nntp-encode-text ()
X  "Encode text in current buffer for NNTP transmission.
X1. Insert `.' at beginning of line.
X2. Insert `.' at end of buffer (end of text mark)."
X  (save-excursion
X    ;; Insert newline at end of buffer.
X    (goto-char (point-max))
X    (if (not (bolp))
X	(insert "\n"))
X    ;; Replace `.' ad beginning of line with `..'.
X    (goto-char (point-min))
X    ;; (replace-regexp "^\\." "..")
X    (while (not (eobp))
X      (if (looking-at "^\\.")
X	  (insert "."))
X      (forward-line 1)
X      (beginning-of-line))
X    ;; Insert `.' at end of buffer (end of text mark).
X    (goto-char (point-max))
X    (insert ".\n")
X    ))
X
X
X;;;
X;;; Synchronous Communication with NNTP Server.
X;;;
X
X(defun nntp-send-command (response cmd &rest args)
X  "Wailt for server RESPONSE after sending CMD and optional ARGS to
Xnews server."
X  (save-excursion
X    ;; Clear communication buffer.
X    (set-buffer nntp-server-buffer)
X    (erase-buffer)
X    (apply 'nntp-send-strings-to-server cmd args)
X    (if response
X	(nntp-wait-for-response response)
X      t)
X    ))
X
X(defun nntp-wait-for-response (regexp)
X  "Wait for server response which matches REGEXP."
X  (save-excursion
X    (let ((status t)
X	  (wait t))
X      (set-buffer nntp-server-buffer)
X      ;; Wait for status response (RFC977).
X      ;; 1xx - Informative message.
X      ;; 2xx - Command ok.
X      ;; 3xx - Command ok so far, send the rest of it.
X      ;; 4xx - Command was correct, but couldn't be performed for some
X      ;;       reason.
X      ;; 5xx - Command unimplemented, or incorrect, or a serious
X      ;;       program error occurred.
X      (nntp-accept-response)
X      (while wait
X	(goto-char (point-min))
X	(cond ((looking-at "[23]")
X	       (setq wait nil))
X	      ((looking-at "[45]")
X	       (setq status nil)
X	       (setq wait nil))
X	      (t (nntp-accept-response))
X	      ))
X      ;; Save status message.
X      (end-of-line)
X      (setq nntp-status-message-string
X	    (buffer-substring (point-min) (point)))
X      (if status
X	  (progn
X	    (setq wait t)
X	    (while wait
X	      (goto-char (point-max))
X	      (forward-line -1)
X	      (beginning-of-line)
X	      ;;(message (buffer-substring
X	      ;;	 (point)
X	      ;;	 (save-excursion (end-of-line) (point))))
X	      (if (looking-at regexp)
X		  (setq wait nil)
X		(message "NNTP: Reading...")
X		(nntp-accept-response)
X		(message "")
X		))
X	    ;; Successfully received server response.
X	    t
X	    ))
X      )))
X
X
X;;;
X;;; Low-Level Interface to NNTP Server.
X;;; 
X
X(defun nntp-send-strings-to-server (&rest strings)
X  "Send list of STRINGS to news server as command and its arguments."
X  (let ((cmd (car strings))
X	(strings (cdr strings)))
X    ;; Command and each argument must be separeted by one or more spaces.
X    (while strings
X      (setq cmd (concat cmd " " (car strings)))
X      (setq strings (cdr strings)))
X    ;; Command line must be terminated by a CR-LF.
X    (process-send-string nntp-server-process (concat cmd "\n"))
X    ))
X
X(defun nntp-send-region-to-server (begin end)
X  "Send current buffer region (from BEGIN to END) to news server."
X  (save-excursion
X    ;; We have to work in the buffer associated with NNTP server
X    ;;  process because of NEmacs hack.
X    (copy-to-buffer nntp-server-buffer begin end)
X    (set-buffer nntp-server-buffer)
X    (setq begin (point-min))
X    (setq end (point-max))
X    ;; `process-send-region' does not work if text to be sent is very
X    ;;  large. I don't know maximum size of text sent correctly.
X    (let ((last nil)
X	  (size 100))			;Size of text sent at once.
X      (save-restriction
X	(narrow-to-region begin end)
X	(goto-char begin)
X	(while (not (eobp))
X	  ;;(setq last (min end (+ (point) size)))
X	  ;; NEmacs gets confused if character at `last' is Kanji.
X	  (setq last (save-excursion
X		       (goto-char (min end (+ (point) size)))
X		       (or (eobp) (forward-char 1)) ;Adjust point
X		       (point)))
X	  (process-send-region nntp-server-process (point) last)
X	  ;; I don't know whether the next codes solve the known
X	  ;;  problem of communication error of GNU Emacs.
X	  (accept-process-output)
X	  ;;(sit-for 0)
X	  (goto-char last)
X	  )))
X    ;; We cannot erase buffer, because reply may be received.
X    (delete-region begin end)
X    ))
X
X(defun nntp-open-server-internal (host &optional service)
X  "Open connection to news server on HOST by SERVICE (default is nntp)."
X  (save-excursion
X    ;; Use TCP/IP stream emulation package if needed.
X    (or (fboundp 'open-network-stream)
X	(require 'tcp))
X    ;; Initialize communication buffer.
X    (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
X    (set-buffer nntp-server-buffer)
X    (kill-all-local-variables)
X    (erase-buffer)
X    (setq nntp-server-process
X	  (open-network-stream "nntpd" (current-buffer)
X			       host (or service "nntp")))
X    ;; It is possible to change kanji-fileio-code in this hook.
X    (run-hooks 'nntp-server-hook)
X    ;; Return the server process.
X    nntp-server-process
X    ))
X
X(defun nntp-close-server-internal ()
X  "Close connection to news server."
X  (if nntp-server-process
X      (delete-process nntp-server-process))
X  (if nntp-server-buffer
X      (kill-buffer nntp-server-buffer))
X  (setq nntp-server-buffer nil)
X  (setq nntp-server-process nil))
X
X(defun nntp-accept-response ()
X  "Read response of server.
XIt is known that communication speed will be improved much by defining
Xthis function as macro."
X  (if nntp-buggy-select
X      (progn
X	;; We cannot use `accept-process-output'.
X	;; Fujitsu UTS requires messages during sleep-for. I don't know why.
X	(message "NNTP: Reading...")
X	(sleep-for 1)
X	(message ""))
X    ;; To deal with server process exiting before
X    ;;  accept-process-output is called.
X    ;; Suggested by Jason Venner .
X    (condition-case ()
X	(accept-process-output nntp-server-process)
X      (error nil))
X    ))
SHAR_EOF
chmod 0444 nntp.el || echo "restore of nntp.el fails"
set `wc -c nntp.el`;Sum=$1
if test "$Sum" != "20613"
then echo original size 20613, current size $Sum;fi
rm -f s2_seq_.tmp
echo "You have unpacked the last part"
exit 0
-- 
Masanobu UMEDA
umerin@flab.flab.Fujitsu.JUNET
umerin%flab.flab.Fujitsu.JUNET@uunet.uu.NET