From: Masanobu UMEDA (umerin@flab.flab.fujitsu.JUNET)
Subject: GNUS: a NNTP based news reader for GNU Emacs (2 of 2) 
This is the only article in this thread  
View: Original Format 
Newsgroups: comp.emacs
Date: 1988-02-01 20:02:23 PST 

: This is a shar archive.  Extract with sh, not csh.
: The rest of this file will extract:
: nntp.el
echo x nntp.el
sed 's/^X//' > nntp.el << '*-*-END-of-nntp.el-*-*'
X;;; NNTP (RFC977) Interface for GNU Emacs
X;; Copyright (C) 1987, 1988 Fujitsu Laboratoris LTD.
X;; Copyrigth (C) 1987, 1988 Masanobu UMEDA (umerin@flab.flab.Fujitsu.JUNET)
X;; $Header: nntp.el,v 2.0 88/02/02 10:01:52 umerin Locked $
X
X;; This file is part of GNU Emacs.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY.  No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing.  Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License.   A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities.  It should be in a
X;; file named COPYING.  Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X;; This implementation depends on 1.2a NNTP software bundled with
X;;  4.3BSD.
X
X(provide 'nntp)
X
X(defvar nntp-server-process nil
X  "NNTP news server process.")
X
X(defvar nntp-server-hook nil
X  "*Hooks for NNTP news server.
XIf Kanji code of news server is different from local kanji code, you
Xhave to put the following code in your .emacs file:
X
X(setq nntp-server-hook
X      '(lambda ()
X  ;; Server's Kanji code is EUC (NEmacs hack).
X  (make-local-variable 'kanji-fileio-code)
X  (setq kanji-fileio-code 0)))")
X
X(defconst nntp-magic-tick 10
X  "Number of time waiting for server response using `accept-process-output'.
XThe value strongly depends on your machine and news server
Xperformance. It is recommended to re-define it in site-init.el or your
X.emacs file.
X
XOptimal values for well-known machines are as follows:
X
X SUN3/260: 10
X S-3500 UTS: 1")
X
X;; Retrieving lots of headers by sending command asynchronously.
X;; Access functions to headers are defined as macro.
X
X(defmacro nntp-headers-number (headers)
X  "Return article number in HEADERS."
X  (` (car (, headers))))
X
X(defmacro nntp-headers-subject (headers)
X  "Return subject string in HEADERS."
X  (` (nth 1 (, headers))))
X
X(defmacro nntp-headers-from (headers)
X  "Return author string in HEADERS."
X  (` (nth 2 (, headers))))
X
X(defmacro nntp-headers-xref (headers)
X  "Return xref string in HEADERS."
X  (` (nth 3 (, headers))))
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) ...)'.
XNews group must be selected before calling me."
X  (save-excursion
X    (let ((number (length sequence))
X   (headers nil)   ;Hold result list
X   (article 0)
X   (subject nil)
X   (xref nil)
X   (from nil)
X   (count 0))
X      (set-buffer (process-buffer nntp-server-process))
X      (erase-buffer)
X      ;; Send HEAD command.
X      (while sequence
X (nntp-send-strings-to-server "HEAD" (car sequence))
X (setq sequence (cdr sequence)))
X      ;; Wait for completion of reply.
X      (sleep-for 1)
X      ;;(accept-process-output)
X      (goto-char (point-min))
X      (while (< (nntp-count-reply "^[0-9]") number)
X ;;(message "Reading...: %d" count)
X ;; I'm not sure which is the fastest way to wait for
X ;;  completion of request, sleep-for or accept-process-output.
X (if (or (> count nntp-magic-tick)
X  (> number 10))
X     (progn
X       ;; Fujitsu UTS requires the next code. I don't know why?
X       ;; Usg-unix-v which supports TCP/IP stream is assumed as
X       ;;  Fujitsu UTS system.
X       (if (eq system-type 'usg-unix-v)
X    (message "Reading..."))
X       (sleep-for 1)
X       (if (eq system-type 'usg-unix-v)
X    (message "")))
X   (setq count (1+ count))
X   (accept-process-output))
X (goto-char (point-min))
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     ;;(sleep-for 1)
X     (accept-process-output)
X     ))
X      ;; Now all of replies are recieved.
X      ;; First, delete unnecessary lines.
X      (goto-char (point-min))
X      (delete-non-matching-lines
X       "^Subject:[ \t]\\|^Xref:[ \t]\\|^From:[ \t]\\|^[23]")
X      ;; Then examines replies.
X      (while (not (eobp))
X (cond ((looking-at "^[23].*[ \t]+\\([0-9]+\\)[ \t]+") ;Article exists.
X        (setq article (string-to-int
X         (buffer-substring (match-beginning 1)
X      (match-end 1))))
X        (forward-line 1)
X        (setq subject nil)
X        (setq xref nil)
X        (setq from nil)
X        ;; It is better to extract From:, Subject: and Xref:
X        ;;  field values in this order.
X        (while (looking-at "^[^23]")
X   (if (looking-at "^From:[ \t]\\(.*\\)\r$")
X       (progn
X         ;; Extract From: field.
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         ;; Extract Subject: field.
X         (setq subject (buffer-substring (match-beginning 1)
X             (match-end 1)))
X         (forward-line 1)))
X   (if (looking-at "^Xref:[ \t]\\(.*\\)\r$")
X       (progn
X         ;; Extract Xref: field.
X         (setq xref (buffer-substring (match-beginning 1)
X          (match-end 1)))
X         (forward-line 1)))
X   )
X        (if (and subject from)
X     (setq headers
X    (cons (list article subject from xref) headers))
X   ;; Subject: and From: field must be specified.
X   (error "NNTP: recieve error(1) on line: %s"
X   (buffer-substring
X    (point)
X    (save-excursion (end-of-line) (point)))))
X        )
X       (t   ;No matching lines
X        (error "NNTP: recieve error(2) on line: %s"
X        (buffer-substring
X         (point)
X         (save-excursion (end-of-line) (point))))
X        )))
X      (nreverse headers)
X      )))
X
X(defun nntp-count-reply (regexp)
X  "Count matches for REGEXP following point."
X  (let ((count 0))
X    (save-excursion
X      (while (and (not (eobp))
X    (re-search-forward regexp nil t))
X (setq count (1+ count))
X ))
X    ;; Return count
X    count
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    (if (nntp-open-server-internal host service)
X (nntp-wait-for-response "^[23].*\r$"))
X    ))
X
X(defun nntp-close-server ()
X  "Close news server."
X  (unwind-protect
X      ;; We cannot send QUIT command unless the process is running.
X      (if (memq (process-status nntp-server-process) '(run open))
X   (nntp-send-command nil "QUIT"))
X    (nntp-close-server-internal)
X    ))
X
X(fset 'nntp-request-quit (symbol-function 'nntp-close-server))
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;; Encoding and decoding of NNTP text.
X
X(defun nntp-decode-text ()
X  "Decode text transmitted by NNTP.
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 (process-buffer nntp-server-process))
X    ;; Insert newline at end of buffer.
X    (goto-char (point-max))
X    (if (not (bolp))
X (insert "\n"))
X    ;; Delete `^M' at end of line.
X    (goto-char (point-min))
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 (progn
X   (kill-line)
X   (kill-line)))
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 (process-buffer nntp-server-process))
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   (count 0))
X      (set-buffer (process-buffer nntp-server-process))
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      ;; I'm not sure which is better method for waiting for
X      ;;  completion of NNTP command. At least communication between
X      ;;  photon and flab works fine by `accept-process-output'.
X      ;;(sleep-for 1)
X      (accept-process-output)
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
X        ;;(message "Reading...: %d" count)
X        ;; I'm not sure `accept-process-output' causes infinite
X        ;;  loop.
X        (if (> count nntp-magic-tick)
X     (sleep-for 1)
X   (setq count (1+ count))
X   (accept-process-output))
X        ))
X )
X      (if status
X   (progn
X     (setq wait t)
X     (setq count 0)  ;Reset counter.
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 "Reading...: %d" count)
X  ;; I'm not sure `accept-process-output' causes
X  ;;  infinite loop.
X  (if (> count nntp-magic-tick)
X      (progn
X        ;; Fujitsu UTS requires the next code. I don't
X        ;;  know why? (UMERIN)
X        (message "Reading...")
X        (sleep-for 1)
X        (message ""))
X    (setq count (1+ count))
X    (accept-process-output))
X  ))
X     ;; Successfully recieved 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    (save-excursion
X      ;; Clear communication buffer.
X      (set-buffer (process-buffer nntp-server-process))
X      (erase-buffer))
X    (copy-to-buffer (process-buffer nntp-server-process) begin end)
X    ;; We have to work on the buffer associated with NNTP server
X    ;;  process because of NEmacs hack.
X    (set-buffer (process-buffer nntp-server-process))
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   (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    ;; Initialize communication buffer.
X    (set-buffer (get-buffer-create " *nntpd*"))
X    (kill-all-local-variables)
X    (erase-buffer)
X    (prog1
X (setq nntp-server-process
X       (open-network-stream "nntpd" (current-buffer)
X       host (or service "nntp")))
X      ;; You can change kanji-fileio-code in hooks.
X      (run-hooks 'nntp-server-hook))
X    ))
X
X(defun nntp-close-server-internal ()
X  "Close connection to news server."
X  (delete-process nntp-server-process)
X  (setq nntp-server-process nil))
*-*-END-of-nntp.el-*-*
exit 0
-- 
Masanobu UMEDA
umerin@flab.flab.Fujitsu.JUNET
umerin%flab.flab.Fujitsu.JUNET@uunet.uu.NET