;;; NNTP (RFC977) Interface for GNU Emacs
;; Copyright (C) 1987, 1988 Fujitsu Laboratoris LTD.
;; Copyrigth (C) 1987, 1988 Masanobu UMEDA (umerin@flab.flab.Fujitsu.JUNET)
;; $Header: nntp.el,v 2.0 88/02/02 10:01:52 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 depends on 1.2a NNTP software bundled with
;;  4.3BSD.

(provide 'nntp)

(defvar nntp-server-process nil
  "NNTP news server process.")

(defvar nntp-server-hook nil
  "*Hooks for NNTP news server.
If Kanji code of news server is different from local kanji code, you
have to put the following code in your .emacs file:

(setq nntp-server-hook
      '(lambda ()
  ;; Server's Kanji code is EUC (NEmacs hack).
  (make-local-variable 'kanji-fileio-code)
  (setq kanji-fileio-code 0)))")

(defconst nntp-magic-tick 10
  "Number of time waiting for server response using `accept-process-output'.
The value strongly depends on your machine and news server
performance. It is recommended to re-define it in site-init.el or your
.emacs file.

Optimal values for well-known machines are as follows:

 SUN3/260: 10
 S-3500 UTS: 1")

;; Retrieving lots of headers by sending command asynchronously.
;; Access functions to headers are defined as macro.

(defmacro nntp-headers-number (headers)
  "Return article number in HEADERS."
  (` (car (, headers))))

(defmacro nntp-headers-subject (headers)
  "Return subject string in HEADERS."
  (` (nth 1 (, headers))))

(defmacro nntp-headers-from (headers)
  "Return author string in HEADERS."
  (` (nth 2 (, headers))))

(defmacro nntp-headers-xref (headers)
  "Return xref string in HEADERS."
  (` (nth 3 (, headers))))

(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) ...)'.
News group must be selected before calling me."
  (save-excursion
    (let ((number (length sequence))
   (headers nil)   ;Hold result list
   (article 0)
   (subject nil)
   (xref nil)
   (from nil)
   (count 0))
      (set-buffer (process-buffer nntp-server-process))
      (erase-buffer)
      ;; Send HEAD command.
      (while sequence
 (nntp-send-strings-to-server "HEAD" (car sequence))
 (setq sequence (cdr sequence)))
      ;; Wait for completion of reply.
      (sleep-for 1)
      ;;(accept-process-output)
      (goto-char (point-min))
      (while (< (nntp-count-reply "^[0-9]") number)
 ;;(message "Reading...: %d" count)
 ;; I'm not sure which is the fastest way to wait for
 ;;  completion of request, sleep-for or accept-process-output.
 (if (or (> count nntp-magic-tick)
  (> number 10))
     (progn
       ;; Fujitsu UTS requires the next code. I don't know why?
       ;; Usg-unix-v which supports TCP/IP stream is assumed as
       ;;  Fujitsu UTS system.
       (if (eq system-type 'usg-unix-v)
    (message "Reading..."))
       (sleep-for 1)
       (if (eq system-type 'usg-unix-v)
    (message "")))
   (setq count (1+ count))
   (accept-process-output))
 (goto-char (point-min))
 )
      ;; Wait for text of last command.
      (goto-char (point-max))
      (re-search-backward "^[0-9]")
      (if (looking-at "^[23]")
   (while (progn
     (goto-char (- (point-max) 3))
     (not (looking-at "^\\.\r$")))
     ;;(sleep-for 1)
     (accept-process-output)
     ))
      ;; Now all of replies are recieved.
      ;; First, delete unnecessary lines.
      (goto-char (point-min))
      (delete-non-matching-lines
       "^Subject:[ \t]\\|^Xref:[ \t]\\|^From:[ \t]\\|^[23]")
      ;; Then examines replies.
      (while (not (eobp))
 (cond ((looking-at "^[23].*[ \t]+\\([0-9]+\\)[ \t]+") ;Article exists.
        (setq article (string-to-int
         (buffer-substring (match-beginning 1)
      (match-end 1))))
        (forward-line 1)
        (setq subject nil)
        (setq xref nil)
        (setq from nil)
        ;; It is better to extract From:, Subject: and Xref:
        ;;  field values in this order.
        (while (looking-at "^[^23]")
   (if (looking-at "^From:[ \t]\\(.*\\)\r$")
       (progn
         ;; Extract From: field.
         (setq from (buffer-substring (match-beginning 1)
          (match-end 1)))
         (forward-line 1)))
   (if (looking-at "^Subject:[ \t]\\(.*\\)\r$")
       (progn
         ;; Extract Subject: field.
         (setq subject (buffer-substring (match-beginning 1)
             (match-end 1)))
         (forward-line 1)))
   (if (looking-at "^Xref:[ \t]\\(.*\\)\r$")
       (progn
         ;; Extract Xref: field.
         (setq xref (buffer-substring (match-beginning 1)
          (match-end 1)))
         (forward-line 1)))
   )
        (if (and subject from)
     (setq headers
    (cons (list article subject from xref) headers))
   ;; Subject: and From: field must be specified.
   (error "NNTP: recieve error(1) on line: %s"
   (buffer-substring
    (point)
    (save-excursion (end-of-line) (point)))))
        )
       (t   ;No matching lines
        (error "NNTP: recieve error(2) on line: %s"
        (buffer-substring
         (point)
         (save-excursion (end-of-line) (point))))
        )))
      (nreverse headers)
      )))

(defun nntp-count-reply (regexp)
  "Count matches for REGEXP following point."
  (let ((count 0))
    (save-excursion
      (while (and (not (eobp))
    (re-search-forward regexp nil t))
 (setq count (1+ count))
 ))
    ;; Return count
    count
    ))

 
;;;
;;; 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")
    (error "NNTP: no server host is specified."))))
    (if (nntp-open-server-internal host service)
 (nntp-wait-for-response "^[23].*\r$"))
    ))

(defun nntp-close-server ()
  "Close news server."
  (unwind-protect
      ;; We cannot send QUIT command unless the process is running.
      (if (memq (process-status nntp-server-process) '(run open))
   (nntp-send-command nil "QUIT"))
    (nntp-close-server-internal)
    ))

(fset 'nntp-request-quit (symbol-function 'nntp-close-server))

(defun nntp-request-article (id)
  "Select article by message ID (or number)."
  (prog1
      (nntp-send-command "^\\.\r$" "ARTICLE" id)
    (nntp-decode-text)
    ))

(defun nntp-request-body (id)
  "Select article body by message ID (or number)."
  (prog1
      (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].*$")
 )))

;; Encoding and decoding of NNTP text.

(defun nntp-decode-text ()
  "Decode text transmitted by NNTP.
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 (process-buffer nntp-server-process))
    ;; Insert newline at end of buffer.
    (goto-char (point-max))
    (if (not (bolp))
 (insert "\n"))
    ;; Delete `^M' at end of line.
    (goto-char (point-min))
    ;; (replace-regexp "\r$" "")
    (while (not (eobp))
      (end-of-line)
      (forward-char -1)
      (if (looking-at "\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 "^\\.$")
 (progn
   (kill-line)
   (kill-line)))
    ;; Replace `..' at beginning of line with `.'.
    (goto-char (point-min))
    ;; (replace-regexp "^\\.\\." ".")
    (while (not (eobp))
      (if (looking-at "^\\.\\.")
   (delete-char 1))
      (forward-line 1)
      (beginning-of-line))
    ))

(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 `.' ad beginning of line with `..'.
    (goto-char (point-min))
    ;; (replace-regexp "^\\." "..")
    (while (not (eobp))
      (if (looking-at "^\\.")
   (insert "."))
      (forward-line 1)
      (beginning-of-line))
    ;; 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)
  "Wailt for server RESPONSE after sending CMD and optional ARGS to
news server."
  (save-excursion
    ;; Clear communication buffer.
    (set-buffer (process-buffer nntp-server-process))
    (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)
   (count 0))
      (set-buffer (process-buffer nntp-server-process))
      ;; 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.
      ;; I'm not sure which is better method for waiting for
      ;;  completion of NNTP command. At least communication between
      ;;  photon and flab works fine by `accept-process-output'.
      ;;(sleep-for 1)
      (accept-process-output)
      (while wait
 (goto-char (point-min))
 (cond ((looking-at "[23]")
        (setq wait nil))
       ((looking-at "[45]")
        (setq status nil)
        (setq wait nil))
       (t
        ;;(message "Reading...: %d" count)
        ;; I'm not sure `accept-process-output' causes infinite
        ;;  loop.
        (if (> count nntp-magic-tick)
     (sleep-for 1)
   (setq count (1+ count))
   (accept-process-output))
        ))
 )
      (if status
   (progn
     (setq wait t)
     (setq count 0)  ;Reset counter.
     (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 "Reading...: %d" count)
  ;; I'm not sure `accept-process-output' causes
  ;;  infinite loop.
  (if (> count nntp-magic-tick)
      (progn
        ;; Fujitsu UTS requires the next code. I don't
        ;;  know why? (UMERIN)
        (message "Reading...")
        (sleep-for 1)
        (message ""))
    (setq count (1+ count))
    (accept-process-output))
  ))
     ;; Successfully recieved 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
    (save-excursion
      ;; Clear communication buffer.
      (set-buffer (process-buffer nntp-server-process))
      (erase-buffer))
    (copy-to-buffer (process-buffer nntp-server-process) begin end)
    ;; We have to work on the buffer associated with NNTP server
    ;;  process because of NEmacs hack.
    (set-buffer (process-buffer nntp-server-process))
    (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)))
   (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
    ;; Initialize communication buffer.
    (set-buffer (get-buffer-create " *nntpd*"))
    (kill-all-local-variables)
    (erase-buffer)
    (prog1
 (setq nntp-server-process
       (open-network-stream "nntpd" (current-buffer)
       host (or service "nntp")))
      ;; You can change kanji-fileio-code in hooks.
      (run-hooks 'nntp-server-hook))
    ))

(defun nntp-close-server-internal ()
  "Close connection to news server."
  (delete-process nntp-server-process)
  (setq nntp-server-process nil))