;;; -*- Mode:Common-Lisp; Package:ZWEI; Base:10; Fonts:(CPTFONT HL12B HL12I MEDFNB) -*-


(defun 4ADD-FIELD-TO-ARTICLE* (newsgroup-component article-number field string)
  "2Add field and string to article.  If the field already exists, then it is replaced with the
new string.*"
  (if (assoc field (get newsgroup-component article-number))
      (rplacd (assoc field (get newsgroup-component article-number)) (list string))
      (push (list field string) (get newsgroup-component article-number))))


(defun 4APPEND-FIELD-TO-ARTICLE* (newsgroup-component article-number field string)
  "2Append string to field in article.  If the field does not exist, then it is added.*"
  (if (assoc field (get newsgroup-component article-number))
      (rplacd (assoc field (get newsgroup-component article-number))
	      (list (string-append (cadr (assoc field (get newsgroup-component article-number))) string)))
      (push (list field string) (get newsgroup-component article-number))))


(defun 4ADD-NEWSGROUP-COMPONENT-TO-NEWSRC-LIST* (newsgroup-component subscribed-p &optional articles-read-string)
  "2Add the newsgroup-component to the *newsrc-list*.  Return T if successful.*"
  (let (articles-read-bitmap)
    ;1;;If the articles-read-string was not specified then just use the high and low article numbers as the articles read string.*
    (unless articles-read-string
      (setf articles-read-string (format nil "~a-~a" (send newsgroup-component :low-article-number)
					 (send newsgroup-component :high-article-number))))
    (when (setf articles-read-bitmap (convert-articles-read-to-bitmap articles-read-string 
							       (send newsgroup-component :high-article-number)
							       (send newsgroup-component :low-article-number)))
      (send newsgroup-component :set-subscribed-p (if (equal subscribed-p *subscribed*) t nil))
      (send newsgroup-component :set-articles-read-string articles-read-string)
      (send newsgroup-component :set-newsrc-p t)
      (send newsgroup-component :set-articles-read-bitmap articles-read-bitmap)
      (send newsgroup-component :count-unread-articles-in-newsgroup)
      (setf *newsrc-list* (append *newsrc-list* (list newsgroup-component)))
      t)))


(defun 4ARTICLE-SELECTED-P* (newsgroup-component)
  "2Return T if an article has been selected. *"
  (not (or (send newsgroup-component :start-of-newsgroup-p) (send newsgroup-component :end-of-newsgroup-p))))


(defun 4BUFFER-NEWSGROUP-COMPONENT* (buffer)
  "2Return the current newsgroup-component from the buffer.*"
  (when buffer
    (send buffer :send-if-handles :newsgroup-component)))

;1;; *;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; The method used for checking for new news is as follows. * 1A new* 1connection*
;1;; is* 1opened each time this function is called. * 1This insures that we* 1get an up*
;1;; to date* 1picture of the data structures. * 1The NNTP list command is* 1executed*
;1;; to get the* 1latest high and low article numbers for each newsgroup.* 1If the*
;1;; newsgroup is* 1subscribed to and the new high article number is greater* 1than*
;1;; the current* 1high article number then* 1the* 1information for that newsgroup* 1is*
;1;; updated locally.*  1Newsgroups found* 1with the list command that* 1are not* 1found*
;1;; locally* 1are simply ignored.*  1The next time the news* 1system is* 1initialized these*
;1;; newsgroups will be picked* 1up.*
;1;;*
;1;; The previous implementation used the NNTP* 1group command to check*
;1;; subscribed* 1newsgroups for new news. * 1This* 1caused problems on the Unix*
;1;; news server side. * 1Every time the local machine issued a group* 1command,* 1the*
;1;; Unix* 1host would issue a* 1directory command on the* 1newsgroup directory* 1(in*
;1;; our* 1case the newsgroup directory was an NFS partition).*  1This loaded* 1down*
;1;; the* 1Unix* 1where* 1the newsgroup directory resided.*  1The* 1NNTP list* 1command*
;1;; alleviates* 1the problem because only one file is read to determine the latest*
;1;; information about the newsgroups.*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun 4CHECK-FOR-NEWNEWS* ()
  "2Check for new news.  Return a list of newsgroup strings with new news.*"
  (let (ret)
    (with-open-stream (nntp-stream (nntp:open-nntp-stream *nntp-host* t))
      (nntp:list-command nntp-stream t)
      (loop with line and eof and newsgroup-component do
	    (multiple-value-setq (line eof) (send nntp-stream :line-in))
	    (cond
	      (eof (return t))
	      (t
	       (multiple-value-bind (result newsgroup-string high-article-number low-article-number moderated)
		   (parse-system-line line)
		 (declare (ignore low-article-number moderated))
		 (when (and result
			    (setf newsgroup-component (get-newsgroup-component newsgroup-string))
			    (send newsgroup-component :subscribed-p)
			    (numberp high-article-number)
			    (send newsgroup-component :extend-articles-read-bitmap high-article-number))
		   (push (send newsgroup-component :newsgroup-string) ret)
		   (send newsgroup-component :count-unread-articles-in-newsgroup)))))))
    ret))


(defun 4CLEAR-BUFFER* (buffer)
  "2Delete the contents of a buffer.*"
  (with-read-only-suppressed (buffer)
    (delete-interval buffer)
    (redisplay *window* :start (interval-first-bp buffer) nil)))


(defun 4CONVERT-ARTICLES-READ-TO-BITMAP* (articles-read-string high-article-number low-article-number)
  "2Convert the articles read string to a bitmap.  Articles that are not
between high article number and low article number are ignored.  If the
high article number is less than the low article number than a zero
length bitmap is returned.  Return the bitmap if successful.  Return NIL
if unsuccessful.*"
  (let (num1 num2 (index 0) articles-read-bitmap)
    (if (< high-article-number low-article-number)
	(setf articles-read-bitmap (make-array 0 :element-type 'bit :initial-value 0))
	(setf articles-read-bitmap (make-array (1+ (- high-article-number low-article-number)) :element-type 'bit
					       :initial-value 0))
	(catch-error
	  (loop
	    ;1;get number.*
	    (multiple-value-setq (num1 index) (parse-integer articles-read-string :start index :junk-allowed t))
	    (cond
	      ;1;end of <articles-read>.*
	      ((>= index (length articles-read-string))
	       (if (<= low-article-number num1 high-article-number)	
		   (setf (aref articles-read-bitmap (- num1 low-article-number)) 1))
	       (return articles-read-bitmap))
	      ;1;comma or space separator.*
	      ((or (equal (aref articles-read-string index) #\,)
		   (equal (aref articles-read-string index) #\space))
	       (if (<= low-article-number num1 high-article-number)	
		   (setf (aref articles-read-bitmap (- num1 low-article-number)) 1))
	       (incf index))
	      ;1;hyphen separator.*
	      ((equal (aref articles-read-string index) #\-)
	       (multiple-value-setq (num2 index) (parse-integer articles-read-string :start (incf index) :junk-allowed t))
	       (if (>= num2 num1)		   
		   (loop for number from (max num1 low-article-number)
			 to (min num2 high-article-number) do
			 (setf (aref articles-read-bitmap (- number low-article-number)) 1)))
	       ;1;skip past next separtor and make sure we are not at the end of the text.*
	       (if (>= (incf index) (length articles-read-string))	   
		   (return articles-read-bitmap)))		   
	      ;1;nothing else passes test.*
	      (t (return nil))))
	  nil))))				;1Don't print error messages from the CATCH-ERROR form.*


(defun 4CONVERT-ARTICLES-READ-TO-STRING* (articles-read-bitmap high-article-number low-article-number)
  "2Convert the articles read bitmap to a string.  Return the ascii string.*"
  (declare (ignore high-article-number))

  (let (token comma-p (articles-read-string (make-array 100. :element-type 'string-char :fill-pointer 0)))
    (when (and (> (length articles-read-bitmap) 0) (> low-article-number 1))
      (string-nconc articles-read-string "1")
      (if (not (zerop (aref articles-read-bitmap 0)))
	  (setf token :range)
	  (string-nconc articles-read-string (format nil "-~a" (1- low-article-number)))
	  (setf comma-p t)))
    (loop for i from 0 to (1- (length articles-read-bitmap)) do
	  (if (zerop (aref articles-read-bitmap i))
	      (cond
		((equal token :range)
		 (string-nconc articles-read-string (format nil "-~a" (+ low-article-number (1- i))))
		 (setf token nil)
		 (setf comma-p t))

		(t
		 (setf token nil)))
	      
	      (cond
		((not token)
		 (string-nconc articles-read-string (format nil "~@[,~*~]~a" comma-p (+ low-article-number i)))
		 (setf token :digit)
		 (setf comma-p t))

		((equal token :digit)
		 (setf token :range))
		
		(t nil)))
	  
	  finally (when (equal token :range)   
		    (string-nconc articles-read-string (format nil "-~a" (+ low-article-number (1- i))))))
    (if (zerop (length articles-read-string))
	"0"
	articles-read-string)))


(defun 4CONVERT-TO-NEWSGROUP-COMPONENT-LIST* (newsgroups)
  "2Take a newsgroup string or a list of newsgroup strings and return a list of
newsgroup components. * 2Newsgroup components that do not exist are ignored.*"
  (let ((newsgroup-component-list nil))
    (dolist (newsgroup (if (consp newsgroups) newsgroups (list newsgroups)) newsgroup-component-list)
      (setf newsgroup-component-list (append newsgroup-component-list (list (get-newsgroup-component newsgroup)))))))


(defun 4CURRENT-NEWSGROUP-SUBSCRIBED-P* ()
  "2Return T if the current newsgroup is subscribed.  Return NIL otherwise.*"
  (when (<= 0 *newsrc-index* (1- (length *newsrc-list*)))
    (send (nth *newsrc-index* *newsrc-list*) :subscribed-p)))


(defun 4DEFAULT-SAVE-ARTICLE-PATHNAME* ()
  "2Return a default save article pathname.*"
  (cond
    (*saved-pathname*
     *saved-pathname*)
    (*default-article-save-pathname*
     *default-article-save-pathname*)
    (t
     (make-pathname :host "lm" :directory user-id :name "news" :type "txt"))))


(defun 4DEFAULT-NEWSRC-FILE* ()
  "2Return the default newsrc file.*"
  (let ((file *user-default-newsrc-file*))
    (cond ((null file)
	   (setq *user-default-newsrc-file*
		 (send (fs:user-homedir-pathname) :new-pathname
		       :name "NEWSRC"
		       :canonical-type :text
		       :version :newest)))
	  ((stringp file)
	   (setq file (fs:merge-pathname-defaults file))
	   (setq *user-default-newsrc-file* (send file :new-version :newest)))
	  ((pathnamep file)
	   (setq *user-default-newsrc-file* (send file :new-version :newest)))
	  (t
	    file))))


(defun 4DEFAULT-NEWS-HOST* ()
  "2Return the default news host.*"
  (let ((host *nntp-host*))
    (cond
      ((null host)
       (if (setf host (get-site-option :default-news-host))
	   (setf *nntp-host* (fs:parse-host host))
	   (setf *nntp-host* (fs:parse-host (send fs:user-login-machine :name)))))
      ((stringp host)
       (setf *nntp-host* (fs:parse-host host)))
      (t
       host))))


(defun 4DELETE-OLD-NEWS-FILES* (pathname)
  ;1; Limit the number of undeleted newsrc files per user option*
  (when (and (numberp *news-file-versions-kept*)	;1non-number means leave alone*
	     (> *news-file-versions-kept* 1)		;1small number means leave alone*
	     (eq (send pathname :version) :newest))	;1dangerous to do clean up if anything except newest was written*
							;1or if version is :unspecified (indicating a versionless file sys)*
    (let ((dirlist (fs:directory-list (send pathname :new-version :wild) :sorted :deleted :noerror)))	
      (when (listp dirlist)
	;1; Elimitate the directory entry from list*
	(setq dirlist (zwei:deleq (assoc nil dirlist) dirlist))
	(dotimes (x (- (length dirlist) *news-file-versions-kept*))
	  (let ((path (car (nth x dirlist))))
	    (send path :delete nil)
	    ;1; Expunge if it is allowed.*
	    (when (send path :undeletable-p)
	      (send path :expunge :error nil))))))))


(defun 4DISPLAY-BOGUS-NEWSGROUP-LIST* ()
  (when *bogus-newsgroup-list-p*
    (when *bogus-newsgroup-list*
      (format t "~%Bogus Newsgroups (i.e. Newsgroups found in your newsrc file but not on the news host)~%")
      (dolist (item *bogus-newsgroup-list*)
	(format t "~%~a" (cdr item)))
      (format t "~2%<Press any key to continue>"))))


(defun 4FIND-AND-SELECT-NEWS-BUFFER* (buffer-name)
  (let ((sheet (zwei:find-or-create-idle-zmacs-window)))
    (tv:await-window-exposure)
    (send sheet :force-kbd-input
	  `(:execute ,(zwei:find-buffer-named buffer-name nil) :select))
    (send sheet :select)))


(defun 4FORMAT-A-NEWSGROUP-SELECTION-LINE* (newsgroup-component line-number)
 "2Return a one line string containing of line-number, unread article count,*
 2newsgroup name, subscribed/unsubscribed indicator, and,* 2articles read.*"
 (format nil "~3d ~7a ~a~a ~a"
	  line-number
	  (cond
	    ((send newsgroup-component :subscribed-p)
	     (if (equal (send newsgroup-component :unread-article-count) 0)
		 "(READ)"
		 (send newsgroup-component :unread-article-count)))
	    (t
	     "(UNSUB)"))
	  (send newsgroup-component :newsgroup-string)
	  (if (send newsgroup-component :subscribed-p)
	      *subscribed*
	      *unsubscribed*)
	  (convert-articles-read-to-string (send newsgroup-component :articles-read-bitmap)
					   (send newsgroup-component :high-article-number)
					   (send newsgroup-component :low-article-number))))



(defun 4GET-CURRENT-NEWSGROUP* ()
  "2Return the current newsgroup-component.*"
  (when (>= *newsrc-index* 0)
    (nth *newsrc-index* *newsrc-list*)))


(defun 4GET-HEADER-FIELD* (newsgroup-component field &optional (parsed nil))
  "2Return the value of the current article header field (i.e.  :subject, :newsgroups,
etc.). Return NIL if not found.  If parsed is T then return the header field
without the header (i.e.  Subject: test returns test)*"
  (let* ((article-number (send newsgroup-component :current-article-number))
	 (line (assoc field (get newsgroup-component article-number))))
    (when line
      (setf line (cadr line))
      (cond
	(parsed
	 (string-trim '(#\space) (subseq line (or (1+ (position ":" line :test #'string-equal)) 0))))
	(t
	 line)))))


(defun 4GET-NEWSGROUP-COMPONENT* (newsgroup-string)
  "2Get the newsgroup component that matches the newsgroup string from
*newsgroup-component-table*. * 2The* 2newsgroup string is case independent.
Return the flavor instance of* 2NEWSGROUP-COMPONENT if successful. * 2If the
newsgroup-string is the actual newsgroup component then simply return the
newsgroup component. * 2Return* 2NIL if the newsgroup* 2component was not found.*"
  (if (equal (type-of newsgroup-string) 'newsgroup-component)
      newsgroup-string
      (gethash (string-upcase newsgroup-string) *newsgroup-component-table*)))


(defun 4GET-NEWSGROUP-COMPONENT-FROM-SYSTEM-LIST* (newsgroup-component)
  "2Get the newsgroup-component from the *system-list*.  Return NIL if not found.*"
  (when (typep newsgroup-component 'newsgroup-component)
    (setf newsgroup-component (send newsgroup-component :newsgroup-string)))
  (dolist (item *system-list* nil)
    (when (string-equal (send item :newsgroup-string) newsgroup-component)
      (return item))))


(defun 4GET-NEXT-NEWSGROUP* (&optional (mode nil))
  "2Return the index into the *newsrc-list* of the next* 2subscribed newsgroup
 (mode = t) or* 2next subscribed newsgroup with unread articles (mode = nil).
Return NIL* 2if there isn't a* 2next* subscribed2 newsgroup. * 2The *newsrc-index* is
updated to* 2the next* 2newsgroup or to* 2the value of *end-index* if there
isn't a next* 2newsgroup.*  2The* 2*previous-newsrc-index* is set to the previous
value of* 2*newsrc-index*.*"
  (setf *previous-newsrc-index* *newsrc-index*)
  (loop with newsgroup-component
	for i from (cond
		     ((= *newsrc-index* *start-index*)
		      0)
		     ((= *newsrc-index* *end-index*)
		      0)
		     (t
		      (1+ *newsrc-index*)))
	to (1- (length *newsrc-list*)) do
	(setf newsgroup-component (nth i *newsrc-list*))
	(when (and3 *(send newsgroup-component :subscribed-p)
		    (or mode (> (send newsgroup-component :unread-article-count) 0)))
	  (setf *newsrc-index* i)
	  (return *newsrc-index*))
	finally
	(progn
	  (setf *newsrc-index* *end-index*)
	  (return nil))))


(defun 4GET-PREVIOUS-NEWSGROUP* (&optional (mode nil))
  "2Return the index into the *newsrc-list* of the previous* 2subscribed newsgroup
 (mode = t)* 2or previous subscribed newsgroup with unread articles (mode = nil).
Return NIL* 2if there isn't a next* 2subscribed newsgroup. * 2The *newsrc-index* is
updated to the* 2previous* 2newsgroup or to the* 2value of *start-index* if
there is no next* 2newsgroup.*  2The* 2*previous-newsrc-index* is set to the previous
value of* 2*newsrc-index*.*"
  (setf *previous-newsrc-index* *newsrc-index*)
  (loop with newsgroup-component
	for i from (cond
		     ((= *newsrc-index* *end-index*)
		      (1- (length *newsrc-list*)))
		     ((= *newsrc-index* *start-index*)
		      -1)
		     (t
		      (1- *newsrc-index*)))
	downto 0 do
	(setf newsgroup-component (nth i *newsrc-list*))
	(when (and (send newsgroup-component :subscribed-p)
		   (or mode (> (send newsgroup-component :unread-article-count) 0)))
	    (setf *newsrc-index* i)
	    (return *newsrc-index*))
	finally
	(progn
	  (setf *newsrc-index* *start-index*)
	  (return nil))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; This function initializes the news systems.  The background news daemon is stoped*
;1;; until the data structures are built.  If an error is detected then the error*
;1;; INITIALIZE-NEWS-ERROR will be signaled.*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun 4INITIALIZE-NEWS* (&optional (initialize nil))
  "2Initialize news.  When INITIALIZE is non-nil then always initialize news regardless
of whether it was initialized or not.  When INITIALIZE is NIL then only initialize
news if it has not already been initialized.  Return T if news is initialized.
Return NIL if news is not initialized (i.e. it has already been initialized).*"
  (when (or initialize (null (news-initialized-p)))
    (reset-news-daemon nil)
    (en-close)
    (kill-newsgroup-summary-buffer)
    (setf *news-initialized-p* nil)
    (default-news-host)
    (default-newsrc-file)
    (en-open)
    (read-system-newsgroups)
    (read-newsrc-newsgroups)
    (merge-newsrc)
    (setf *newsrc-index* -1)
    (setf *initialized-news-host* *nntp-host*)
    (setf *initialized-newsrc-file* *user-default-newsrc-file*)
    (setf *news-username* user-id)
    (setf *newsrc-index* *start-index*)
    (setf *previous-newsrc-index* *start-index*)
    (setf *newsrc-changed* nil)
    (reset-news-daemon t)
    (setf *news-initialized-p* t)
    (display-bogus-newsgroup-list)
    (format *query-io* "Done")))


(defun 4MERGE-NEWSRC* ()
  "2Merge *system-list* into *newsrc-list* based on the value of
*merge-newsrc-p*.*"
  (dolist (newsgroup-component *system-list* t)
    (unless (send newsgroup-component :newsrc-p)
      (cond
	((equal *merge-newsrc-p* :subscribe)
	 (format *query-io* "~%Subscribing to the new newsgroup ~:@(~a~)."
		 (send newsgroup-component :newsgroup-string))
	 (send newsgroup-component :initialize-newsrc-component t "0")
	 (send newsgroup-component :set-newsrc-p t)
	 (setf *newsrc-list* (append *newsrc-list* (list newsgroup-component))))
	((equal *merge-newsrc-p* :unsubscribe)
	 (format *query-io* "~%Unsubscribing to the new newsgroup ~:@(~a~)."
		 (send newsgroup-component :newsgroup-string))
	 (send newsgroup-component :initialize-newsrc-component nil "0")
	 (send newsgroup-component :set-newsrc-p t)
	 (setf *newsrc-list* (append *newsrc-list* (list newsgroup-component))))))))
	 
  

(defun 4NEWS-INITIALIZED-P* ()
  "2Return T if news is initialized. *"
  (and *news-initialized-p*
       (string-equal *news-username* user-id)
       (equal *nntp-host* *initialized-news-host*)
       (equal *user-default-newsrc-file* *initialized-newsrc-file*)))


(defun 4NEWSGROUP-SELECTION* (&optional (string nil))
  "2Display a menu of newsgroups containing the string string. * 2If string is NIL
then all newsgroups* 2are selected.* 2 Return the newsgroup selected.
Return nil if* 2nothing was selected.*"
  (condition-case (cond-obj)
      (w:menu-choose
	 (let* (return-list (loc (locf return-list)) (line-number 0))
	   (dolist (newsgroup-component *newsrc-list* return-list)
	     (if (or (null string) (lisp:search string (send newsgroup-component :newsgroup-string) :test #'string-equal))
		 (rplacd loc (setf loc (list (list (format-a-newsgroup-selection-line newsgroup-component
										      (incf line-number))
						   :value newsgroup-component)))))))
       :menu-margin-choices '(:abort) :columns 1)
    (sys:abort nil)))


(defun 4PARSE-AND-STORE-ARTICLE-HEADER* (newsgroup-component article-number)
  "2Parse the article header.  Each field is stored onto the property list of the newsgroup component
by article number.  For example, article 0, has a property of 0 with the article header fields
stored as association lists.  The HEAD command must have already been issued prior to
calling this function.*"
  (let (field position-of-colon line eof continuation-mode)
    (loop
      (multiple-value-setq (line eof) (nntp:read-nntp-stream *nntp-stream*))
      (cond
	(eof (return :eof))
	;1;;Bogus field, ignore.*
	((zerop (length line))
	 (setf field nil)
	 (setf continuation-mode nil))
	(t
	 (setf position-of-colon (position ":" line :test #'string-equal))
	 (cond
	   ;1;;A Continuation line is indicated by a space or tab character in column 1.*
	   ((and continuation-mode (or (equal (aref line 0) #\space) (equal (aref line 0) #\tab)))
	    (append-field-to-article newsgroup-component article-number field line))
	   ;1;;Store the header line onto the property as an association list.  Strip trailing blanks.*
	   (position-of-colon
	    (setf field (read-from-string (format nil ":~a" (subseq line 0 position-of-colon))))
	    (add-field-to-article newsgroup-component article-number field (string-trim '(#\space) line))
	    (setf continuation-mode t))
	   ;1;;Bogus field, ignore.*
	   (t
	    (setf field nil)
	    (setf continuation-mode nil))))))))


(defun 4PARSE-AND-STORE-HEADER-FIELD* (newsgroup-component field)
  "2Parse the XHDR command output.*"
  (let (article-number eof line)
    (loop
      (multiple-value-setq (line eof) (nntp:read-nntp-stream *nntp-stream*))
      (cond
	(eof (return :eof))
	;1;;Bogus field, ignore.*
	((zerop (length line)))
	((setf article-number (parse-integer line :start 0 :junk-allowed t))
	 (add-field-to-article newsgroup-component article-number field
			       (format nil "~@(~a~):~a" field (subseq line (position #\space line :test #'char-equal)))))
	;1;;Bogus field, ignore.*
	(t)))))


(defun 4PARSE-ARTICLE-HEADER* (nntp-stream)
  "2Format and return the from field, newsgroups, subject, and message-id from
the article header.  The HEAD command must have already been issued
prior to calling this function.*"
  (let (working-field from newsgroups subject message-id line eof append-p end)
    (loop
      (multiple-value-setq (line eof) (nntp:read-nntp-stream nntp-stream))
      (cond
	(eof (return :eof))
	(t
	 (cond
	   ((setf end (position ":" line :test #'string-equal))
	    (cond
	      ;1;;A Continuation line is indicated by a space or tab character in column 1.*
	      ((or (equal (aref line 0) #\space) (equal (aref line 0) #\tab))
	        ;1;;If the previous line was a valid field then display the continuation line also.*
	       (if append-p (set working-field (string-append working-field (format nil "~%~a" (subseq line 1))))))
	      ;1;;From.*
	      ((string-equal (subseq line 0 (1+ end)) "FROM:")
	       (setf from (string-trim '(#\space) (subseq line (1+ end))))
	       (set working-field 'from)
	       (setf append-p t))
	      ;1;;Newsgroups.*
	      ((string-equal (subseq line 0 (1+ end)) "NEWSGROUPS:")
	       (setf newsgroups (string-trim '(#\space) (subseq line (1+ end))))
	       (set working-field 'newsgroups)
	       (setf append-p t))
	      ;1;;Subject. *
	      ((string-equal (subseq line 0 (1+ end)) "SUBJECT:")
	       (setf subject (string-trim '(#\space) (subseq line (1+ end))))
	       (set working-field 'subject)
	       (setf append-p t))
	      ;1;;Message id.*
	      ((string-equal (subseq line 0 (1+ end)) "MESSAGE-ID:")
	       (setf message-id (string-trim '(#\space) (subseq line (1+ end))))
	       (set working-field 'message-id)
	       (setf append-p t))
	      ;1;;Line does not contain a valid field.  Ignore the line.*
	      (t
	       (setf append-p nil))))
	   ;1;;Ignore this line.*
	   (t
	    (setf append-p nil))))))
    (values from newsgroups subject message-id)))


(defun 4PARSE-XREF* (line)
  "2Parse the xref line and return list, each item in the list is a cons in the
format newsgroup . * 2article number. * 2Return NIL if no valid items were found.*"
  (loop with xref and temp and newsgroup and article-number
	while (and (> (length line) 2) (lisp:search ":" line :test #'string-equal))	;1x:1 would result in a length of 3.*
	finally (return xref) do
	(setf temp (string-trim '(#\space) (subseq line 0 (or (position #\space line) nil))))
	(setf line (string-trim '(#\space) (subseq line (or (position #\space line) (length line)))))
	(when (and (lisp:search ":" temp :test #'string-equal)
		   (not (equal (aref temp 0) #\:))
		   (not (equal (aref temp (1- (length temp))) #\:)))
	  (setf newsgroup (subseq temp 0 (position #\: temp)))
	  (setf article-number (PARSE-NUMBER (subseq temp (1+ (position #\: temp))) 0 nil 10. t))
	  (when article-number
	    (setf xref (append xref (list (cons newsgroup article-number))))))))


(defun 4POSITION-TO-NEWSGROUP* (newsgroup)
  "2Position the current newsgroup to newsgroup string.  Return NIL if the newsgroup was not found.*"
  (let (newsgroup-component index)
    (and
      (setf newsgroup-component (get-newsgroup-component newsgroup))
      (setf index (position newsgroup-component *newsrc-list*))
      (setf *newsrc-index* index))))


(defun 4POSTNEWS-BUFFER* (buffer-name)
  "2Post the buffer name buffer-name to news.*"
  (condition-case (cond-obj)
      (with-open-stream (nntp-stream (nntp:open-nntp-stream *nntp-host* t))
	(format *query-io* "Posting...")
	(zwei:with-editor-stream (stream :buffer-name buffer-name :start :beginning)
	  (nntp:post-command nntp-stream)
	  (loop with line
		while (setf line (read-line stream nil))
		do
		(format *query-io* ".")
		(nntp:write-text nntp-stream line))
	  (format *query-io* "Checking status...")
	  (nntp:postend-command nntp-stream)
	  (format *query-io* "Successfully posted to ~a." *nntp-host*)))
    (error
     (progn
       (format *query-io* "~%Failed.  ~a" cond-obj)
       nil))))


(defun 4PUT-NEWSGROUP-COMPONENT* (newsgroup-component)
  "2Put the newsgroup component into the hash table.*"
  (puthash (string-upcase (send newsgroup-component :newsgroup-string))
	   newsgroup-component
	   *newsgroup-component-table*))


(defun 4SAVE-ARTICLE-SUBJECT* (newsgroup-component)
  "2Save the current article subject as a cons of subject string . article number.*"
  (let ((subject (get-header-field newsgroup-component :subject)))
    (if subject
	(setf *article-subject* (cons subject (send newsgroup-component :current-article-number)))
	(setf *article-subject* nil))))


(defun 4STRIP-SUBJECT* (subject)
  "2Remove subject:  and whitespace from the beginning of the subject line if it exists.*"
  (cond
    ((null subject)
     "")
    ((lisp:search "subject:" subject :test #'string-equal :start2 0 :end2 8)
     (string-trim '(#\space) (subseq subject (+ 2 (position #\: subject)))))
    (t
     (string-trim '(#\space) subject))))


(defun 4STRIP-RE-FROM-SUBJECT* (subject)
  "2Remove all RE:'s and whitespace from the beginning of the subject line if it exists.*"
  (cond
    ((lisp:search "re:" subject :test #'string-equal :start2 0 :end2 3)
     (if (position #\space subject :test-not #'equal :start 3)
	 (strip-re-from-subject (subseq subject (position #\space subject :test-not #'equal :start 3)))
	 ""))
    (t
     (string-trim '(#\space) subject))))


(defun 4SUBJECTS-EQUAL-P* (subject1 subject2)
  "2Returns non-nil if subject1 is contained in the beginning of subject2, ignoring
the subject: re:'s in both subject1 and subject2.*"
  (lisp:search (strip-re-from-subject (strip-subject subject1))
	       (strip-re-from-subject (strip-subject subject2))
	       :test #'string-equal :start2 0 :end2 (length (strip-re-from-subject (strip-subject subject1)))))


(defun 4SUBSCRIBE-NEWSGROUP* (newsgroup-name-or-component &optional (subscribe t))
  "2Subscribe t, or unsubscribe nil, the newsgroup.*"
  (send (get-newsgroup-component newsgroup-name-or-component) :set-subscribed-p subscribe)
  (setf *newsrc-changed* t))
  

(defun 4SUBSCRIBE-CURRENT-NEWSGROUP* (&optional (subscribe t))
  "2Subscribe t, or unsubscribe nil, the current newsgroup. * 2The current
newsgroup* 2is indexed into *NEWSRC-LIST* by *NEWSRC-INDEX*.*"
  (when (<= 0 *newsrc-index* (1- (length *newsrc-list*)))
    (when (get-newsgroup-component (nth *newsrc-index* *newsrc-list*))
      (subscribe-newsgroup (nth *newsrc-index* *newsrc-list*) subscribe))))


(defun 4VALIDATE-NEWSRC-FILENAME* (newsrc-file)
  "2Determine if the newsrc filename is valid. * 2Return :EXISTS if file* 2already
exists. * 2Return :NEW if file does not exist but it can be created.* 2Return NIL if
invalid.*"
  (condition-case (cond-obj)
      (cond
       ;1;NIL is not a valid filename.*
       ((null newsrc-file)
	nil)
       ;1;File already exists.*
       ((fs:probe-file newsrc-file)
	:EXISTS)
       (t
	;1;Make sure we can create the newsrc file.  Is there a better way to do this???  It has to work on ULTRIX too.*
	(let* ((fp (open newsrc-file :direction :output))
	       (truename (send fp :truename)))
	  (close fp)
	  (send truename :delete)
	  (send truename :expunge)
	  :NEW)))
    (error
     nil)))


(defun 4VALIDATE-NEWS-HOST* (host)
  "2Determine if the host contains an NNTP daemon.  Return NIL if it doesn't.*"
  (condition-case (cond-obj)
      (cond
       ;1;;NIL is not a valid host.*
       ((null host)
	nil)
       ;1;;Make sure we can open a connection.*
       (t
	(nntp:close-nntp-stream (nntp:open-nntp-stream-1 host :error t))
	t))
    (error nil)))


(defun 4WRITE-ARTICLE-INTO-BUFFER* (nntp-stream buffer-name)
"2Include any portion of the article into the buffer, prepending each line with the
zwei:*yank-message-prefix*.  The HEAD, ARTICLE, or, BODY
command must be called prior to calling this function.*"
  (zwei:with-editor-stream (stream :buffer-name buffer-name :start :end)
    (loop
      (multiple-value-bind (line eof) (nntp:read-nntp-stream nntp-stream)
	(cond
	  (eof (return :eof))
	  (t (format stream "~%~a~a" zwei:*yank-message-prefix* line)))))
    (format stream "~%")))


(defun 4WRITE-FORMATTED-HEADER* (stream newsgroup-component newsheader-include-list newsheader-exclude-list)
  "2Format the current article header and write it to stream.  Display only the
newsheader fields.  The article header must have already been saved onto
the article number.  Return the number of lines printed.*"
  (let (line (count 0))
    ;1;;Write the include list header fields minus the exclude list.*
    (dolist (item newsheader-include-list nil)
      (unless (member item newsheader-exclude-list)
	(when (setf line (get-header-field newsgroup-component item))
	  (incf count)
	  (format stream "~%~a" line))))
    ;1;;Merge the include list and exclude list and write the remaining header fields.*
    (setf newsheader-exclude-list (append newsheader-exclude-list newsheader-include-list))
    (dolist (item (reverse (get newsgroup-component (send newsgroup-component :current-article-number))) count)
      (unless (member (car item) newsheader-exclude-list)
	(when (setf line (get-header-field newsgroup-component (car item)))
	  (incf count)
	  (format stream "~%~a" line))))))


(defun 4WRITE-NEWSRC-FILE* (&optional (user-default-newsrc-file *user-default-newsrc-file*))
  "2Update the newsrc file.  If *keep-bogus-p* is non-nil, include the bogus newsgroups but mark them as unsubscribed.*"
  ;1;;Make sure we have a pathname.*
  (unless (pathnamep user-default-newsrc-file)
    (setf user-default-newsrc-file (fs:parse-pathname user-default-newsrc-file)))
  ;1;;Versionless file system, eg. UNIX.*
  (when (equal (send user-default-newsrc-file :version) :unspecific)
    (if (rename-file user-default-newsrc-file (string-append user-default-newsrc-file *backup-newsrc-file-append-string*)
		     :error nil)
	(format *query-io* "~:|Existing news file renamed to ~a." (string-append user-default-newsrc-file
								       *backup-newsrc-file-append-string*))))
  ;1;Write newsgroups.*
  (with-open-file (stream user-default-newsrc-file :direction :output)
    ;1;;When *keep-bogus-p* is T then each bogus newsgroup line is written back out in the correct position as read.*
    (loop with line-number = 0 and bogus-newsgroup-list = *bogus-newsgroup-list* and newsrc-list = *newsrc-list* and
	  newsgroup-component and done = nil
	  until done do
	  (incf line-number)
	  (cond
	    ((and *keep-bogus-p* bogus-newsgroup-list (equal line-number (caar bogus-newsgroup-list)))
	     (send stream :line-out (format nil "~a" (cdar bogus-newsgroup-list)))
	     (setf bogus-newsgroup-list (cdr bogus-newsgroup-list)))
	    (t
	     (cond
	       (newsrc-list
		(setf newsgroup-component (car newsrc-list))
		(setf newsrc-list (cdr newsrc-list))
		(send stream :line-out (format nil "~a~a ~a"
					       (send newsgroup-component :newsgroup-string)
					       (if (send newsgroup-component :subscribed-p)
						   *subscribed*
						   *unsubscribed*)
					       (convert-articles-read-to-string
						 (send newsgroup-component :articles-read-bitmap)
						 (send newsgroup-component :high-article-number)
						 (send newsgroup-component :low-article-number)))))
	       (t
		(setf done t)))))
	  finally
	  (when *keep-bogus-p*
	    (dolist (bogus-newsgroup-item bogus-newsgroup-list t)
	     (send stream :line-out (format nil "~a" (cdr bogus-newsgroup-item))))))
    (if (equal user-default-newsrc-file (fs:parse-pathname *user-default-newsrc-file*))
	(setf *newsrc-changed* nil))
    ;1;;Delete old versions.*
    (unless (equal (send user-default-newsrc-file :version) :unspecific)
      (delete-old-news-files user-default-newsrc-file )) 
    (format *query-io* "~:|~a written." user-default-newsrc-file)))


(defun 4WRITE-NEWSRC-FILE-MENU* ()
  (let ((newsrc-file *user-default-newsrc-file*))
    (declare (special newsrc-file))
    (w:choose-variable-values
      
      '((newsrc-file "Newsrc file"
		     :documentation "The default value is your default newsrc file.  If you specify another filename, the file is written but your default newsrc file remains unchanged."
		     :pathname))
      
      :label "Write the newsrc file"
      :margin-choices *default-cvv-margin-choices*
      :width 60
      )
    (write-newsrc-file newsrc-file)))


(defun 4WRITE-TO-BUFFER-P* (buffername)
  "2Return T if it is ok to write to buffername.*"
  (cond
    ((zwei:find-buffer-named buffername)
     (cond
       ((y-or-n-p "Buffer already exists.  Overwrite buffer? ")
	(zwei:kill-buffer (zwei:find-buffer-named buffername))
	t)
       (t nil)))
    (t t)))