#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Scheme News Reader

(declare (usual-integrations))

(load-option 'ORDERED-VECTOR)

;;; Variables affecting the reader:

(define-variable news-server
  "Host name of the default News server.
This is the name used by \\[rnews].
If it is an empty string, \\[rnews] will prompt for a host name and
 save it back into news-server."
  ""
  string?)

(define-variable news-server-name-appearance
  "Switch controlling appearance of server name in News buffers.
This has three possible values:
  'NONE means do not include the server name.
  'FULL means include the fully qualified host name.
  'HOST-ONLY means include the host name, but not the domain."
  'NONE
  (lambda (object) (memq object '(NONE FULL HOST-ONLY))))

(define-variable news-server-proxy-alist
  "Alist mapping news servers to associated proxies.
Each entry in the list is a pair of strings:
 the car of the entry is the FQDN of a news server;
 the cdr of the entry is the FQDN of a proxy for that server,
 optionally followed by a colon and a service number."
  '()
  (lambda (object)
    (list-of-type? object
      (lambda (entry)
	(and (pair? entry)
	     (string? (car entry))
	     (string? (cdr entry)))))))

(define-variable news-server-initial-refresh
  "Switch controlling whether News groups are refreshed when reader starts.
If false (the default), groups are initially listed with the estimates
 that were current the last time the news-reader was run.
If true, the server is asked to provide current estimates for all
 subscribed groups.
Note that if this variable is true, the reader will go on-line when it
 is started."
  #f
  boolean?)

(define-variable news-server-offline-timeout
  "Number of seconds to stay online after each server transaction.
If no further transactions are performed after this long, the server
 connection is closed.
This variable can be set to #F to disable the timeout altogether.
[THIS VARIABLE CURRENTLY HAS NO EFFECT.]"
  #f
  (lambda (object) (or (not object) (exact-nonnegative-integer? object))))

(define-variable news-header-filter
  "Procedure for filtering news headers, or #F for no filter.
Every header read by the news reader is filtered through this filter.  If it
  returns false, the header is ignored."
  #f
  (lambda (filter)
    (or (not filter)
        (procedure-of-arity? filter 1))))

;;; Variables for News-group-list buffers:

(define-variable news-show-unsubscribed-groups
  "Switch controlling whether unsubscribed News groups appear in server buffers.
If false (the default), only currently subscribed groups are shown.
If true, previously subscribed groups are also shown."
  #f
  boolean?)

(define-variable news-show-nonexistent-groups
  "Switch controlling whether nonexistent News groups appear in server buffers.
If false, only News groups existing on the server are shown.  Note
 that this forces the reader to go on-line to determine which groups
 exist.
If true (the default), all subscribed groups are shown."
  #t
  boolean?)

(define-variable news-sort-groups
  "Switch controlling whether the News groups are sorted.
If true (the default), News groups in the subscribed-groups buffer are sorted.
If false, groups appear in the order they are listed in the init file."
  #t
  boolean?)

(define-variable news-hide-groups
  "List of regexps indicatings groups to be hidden.
Any News group whose name matches one of these regexps will not be shown
 in the all-groups and new-groups buffers.
Subscribing to such a group will still work, and afterwards the
 group will appear in the subscribed-groups buffer."
  '()
  list-of-strings?)

(define-variable news-refresh-group-when-selected
  "Switch controlling whether News group is refreshed when selected.
If true, selecting a group causes it to be refreshed, so that the
 headers shown are current at the time of selection.  Note that this
 forces the reader to go on-line to determine the current set of
 headers.
If false (the default), the headers shown are the ones that were
 current when the group was last selected."
  #f
  boolean?)

;;; Variables for News-group buffers:

(define-variable news-initially-collapse-threads
  "Switch controlling initial collapsing of News threads.
If true (the default), threads are initially collapsed.
If false, they are initially expanded.
A collapsed thread is automatically expanded when entered."
  #t
  boolean?)

(define-variable news-automatically-collapse-threads
  "Switch controlling automatic collapsing of News threads.
A collapsed thread is automatically expanded when entered.
This switch can take several values:
  'NEVER      Threads are never automatically collapsed.  This is the default.
  'AUTOMATIC  Any automatically expanded thread is re-collapsed when left.
  'ALWAYS     Any expanded thread is re-collapsed when left."
  'NEVER
  (lambda (object) (memq object '(NEVER AUTOMATIC ALWAYS))))

(define-variable news-split-threads-on-subject-changes
  "Switch controlling whether News threads can span subject changes.
If true (the default), a thread is broken into multiple threads when
 the Subject: header changes.  This guarantees that each thread covers
 only a single subject.
Otherwise, a thread containing subject changes remains whole."
  #t
  boolean?)

(define-variable news-join-threads-with-same-subject
  "Switch controlling whether News threads with same subject are joined.
If true (the default), two or more threads with the same Subject:
 header are joined together into a single thread.
Otherwise, threads with the same subject remain separate."
  #t
  boolean?)

(define-variable news-article-context-lines
  "The number of lines to show in a News-group context window."
  5
  (lambda (object) (and (exact-integer? object) (> object 0))))

(define-variable news-article-highlight-selected
  "Switch controlling display of selected articles in a News-group buffer.
If true (the default), selected articles are indicated by highlights.
If false, there is no indication.
This is primarily used to enhance the context window."
  #t
  boolean?)

(define-variable news-group-author-columns
  "Number of columns used to display the author in a News-article header line.
This applies only to header lines that contain subjects."
  15
  exact-nonnegative-integer?)

(define-variable news-group-show-author-name
  "Switch controlling appearance of author's name in a News-article header line.
If true (the default), the author's full name will be shown, if available.
If false, the email address of the author is shown."
  #t
  boolean?)

(define-variable news-group-ignored-subject-retention
  "How long to retain ignored-subject data, in days.
If an ignored subject is not seen for this many days, the subject line
 is removed from the ignored-subject database.  This stops it from
 being ignored.
By default, ignored subjects are kept for 30 days."
  30
  (lambda (object) (and (real? object) (not (negative? object)))))

(define-variable news-group-ignore-hidden-subjects
  "If true, ignore all subjects in a thread, even if hidden.
If false, subject changes within the thread are not ignored."
  #t
  boolean?)

(define-variable news-group-keep-seen-headers
  "Switch controlling which headers are kept in the off-line database.
If true (the default), all headers are kept.
Otherwise, only unseen headers are kept."
  #t
  boolean?)

(define-variable news-group-keep-ignored-headers
  "Switch controlling which headers are kept in the off-line database.
If true, all headers are kept.
Otherwise (the default), ignored headers aren't kept."
  #f
  boolean?)

(define-variable news-group-show-seen-headers
  "Switch controlling whether already-seen headers are shown.
If true, group buffers show all headers.
Otherwise (the default), only unseen headers are shown.
If this switch is true, it's important to set the variable
 news-group-keep-seen-headers, as otherwise there will be a
 serious performance impact."
  #f
  boolean?)

(define-variable news-group-show-context-headers
  "Switch controlling whether a thread's context headers are shown.
If true (the default), previously read headers are shown when they
 are needed to give context for a thread that contains one or more unread
 articles.  This makes it easier to see how a thread has developed.
If false, only the unread headers are fetched from the
 server, and no additional context is available."
  #t
  boolean?)

(define-variable news-group-cache-policy
  "Controls how cacheing is used.
The value of this variable is a list.
The first element of the list describes the groups that are cached:
 SUBSCRIBED            only subscribed groups are cached
 ALL                   all groups are cached
 [list of group names] only named groups are cached
The second element of the list is a list containing zero or more of
the following symbols:
 HEADERS               headers are cached
 BODIES                bodies are cached
The default value of this variable is (SUBSCRIBED (HEADERS BODIES))."
  '(SUBSCRIBED (HEADERS BODIES))
  (lambda (object)
    (and (pair? object)
	 (or (eq? 'SUBSCRIBED (car object))
	     (eq? 'ALL (car object))
	     (list-of-strings? (car object)))
	 (pair? (cdr object))
	 (list-of-type? (cadr object)
	   (lambda (element)
	     (or (eq? 'HEADERS element)
		 (eq? 'BODIES element))))
	 (null? (cddr object)))))

(define-variable news-kept-headers
  "A list of regular expressions matching header fields to display.
Header fields matching these regexps are shown in the given order, and
  other header fields are hidden.
This variable overrides RMAIL-IGNORED-HEADERS; to use RMAIL-IGNORED-HEADERS,
  set NEWS-KEPT-HEADERS to #F."
  '("date:" "from:" "newsgroups:" "subject:")
  (lambda (obj)
    (or (not obj)
        (list-of-type? obj regular-expression?))))

(define (regular-expression? obj)
  (or (string? obj)
      (compiled-regexp? obj)
      ;++ This should be stricter about strings, and it should also
      ;++ support REXPs.
      ))

(define-command rnews
  "Start a News reader.
Normally uses the server specified by the variable news-server,
 but with a prefix arg prompts for the server name.
Only one News reader may be open per server; if a previous News reader
 is open to that server, its buffer is selected."
  "P"
  (lambda (prompt?)
    (select-buffer
     (let ((server (get-news-server-name prompt?)))
       (or (find-news-server-buffer server)
	   (make-news-server-buffer server))))))

(define (get-news-server-name prompt?)
  (let ((server (ref-variable news-server #f)))
    (if (or prompt? (string-null? server))
	(prompt-for-news-server "News server")
	server)))

(define (prompt-for-news-server prompt)
  (let ((default (ref-variable news-server #f)))
    (let ((server
	   (prompt-for-string prompt
			      (and (not (string-null? default))
				   default))))
      (if (string-null? default)
	  (set-variable! news-server server #f))
      server)))

(define-major-mode news-common read-only "News Common"
  "This is an abstract mode to be used for building other modes."
  (lambda (buffer)
    (local-set-variable!
     mode-line-process
     (lambda (window)
       (let ((buffer (news-server-buffer (window-buffer window) #f)))
	 (cond ((not buffer) "")
	       ((nntp-connection:closed?
		 (news-server-buffer:connection buffer))
		": offline")
	       (else ": online"))))
     buffer)
    (event-distributor/invoke! (ref-variable news-common-mode-hook buffer)
			       buffer)))

(define-variable news-common-mode-hook
  "An event distributor that is invoked when entering any News mode."
  (make-event-distributor))

(define-key 'news-common #\a 'news-compose-article)
(define-key 'news-common #\O 'news-toggle-online)
(define-key 'news-common #\q 'news-kill-current-buffer)
(define-key 'news-common #\m 'mail)
(define-key 'news-common #\? 'describe-mode)
(define-key 'news-common '(#\c-x #\c-s) 'news-save-server-data)

(define-command news-kill-current-buffer
  "Kill the current buffer."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (let ((parent (buffer-tree:parent buffer #f)))
	(kill-buffer buffer)
	(if parent (select-buffer parent))))))

(define-command news-save-server-data
  "Update the init file with current data."
  ()
  (lambda ()
    (news-server-buffer:save-groups (current-news-server-buffer #t))))

(define-command news-toggle-online
  "Toggle between online and offline states."
  ()
  (lambda ()
    (let ((connection (buffer-nntp-connection (selected-buffer))))
      (if (nntp-connection:closed? connection)
	  (nntp-connection:reopen connection)
	  (nntp-connection:close connection)))))

(define (buffer-nntp-connection buffer)
  (news-server-buffer:connection (news-server-buffer buffer #t)))

(define (update-nntp-connection-modeline! connection)
  (global-window-modeline-event!
   (lambda (window)
     (let ((buffer (news-server-buffer (window-buffer window) #f)))
       (and buffer
	    (eq? (news-server-buffer:connection buffer) connection)
	    'NNTP-CONNECTION-STATUS)))))

(define (news-buffer-name server prefix)
  (case (ref-variable news-server-name-appearance #f)
    ((HOST-ONLY)
     (string-append prefix
		    ":"
		    (let ((dot (string-find-next-char server #\.)))
		      (if dot
			  (string-head server dot)
			  server))))
    ((FULL) (string-append prefix ":" server))
    (else prefix)))

;;;; News-Server Buffer

(define (find-news-server-buffer server)
  (find (lambda (buffer)
	  (and (news-server-buffer? buffer)
	       (string-ci=? (news-server-buffer:server buffer) server)))
	(buffer-list)))

(define (make-news-server-buffer server)
  (create-news-buffer (news-buffer-name server "subscribed-groups")
		      (ref-mode-object news-server)
    (lambda (buffer)
      (add-kill-buffer-hook buffer news-server-buffer:kill)
      (buffer-put! buffer 'NNTP-CONNECTION
		   (make-nntp-connection-1 server buffer))
      (let ((sort? (ref-variable news-sort-groups buffer)))
	(let ((groups
	       (let ((groups
		      (read-groups-init-file
		       (news-server-buffer:connection buffer))))
		 (if sort?
		     (sort groups news-group:<)
		     groups))))
	  (if (ref-variable news-server-initial-refresh buffer)
	      (for-each-vector-element groups news-group:update-ranges!))
	  (buffer-put! buffer 'NEWS-GROUPS groups)
	  (install-news-groups-buffer-procedures
	   buffer
	   'SERVER
	   news-server-buffer:group-mark
	   news-server-buffer:mark-group
	   news-server-buffer:next-group
	   news-server-buffer:previous-group
	   news-server-buffer:group-adjective
	   news-server-buffer:show-group?)
	  (buffer-put! buffer 'NEWS-GROUPS-SORTED? sort?)
	  (initialize-news-groups-buffer buffer groups)))
      (find-first-property-line buffer 'NEWS-GROUP #f))))

(define (news-server-buffer:kill buffer)
  (for-each kill-buffer (buffer-tree:children buffer))
  (ignore-errors
   (lambda ()
     (news-server-buffer:save-groups buffer)
     (news-server-buffer:close-connection buffer))))

(define (news-server-buffer:groups buffer)
  (buffer-get buffer 'NEWS-GROUPS '#()))

(define (news-server-buffer:groups-sorted? buffer)
  (buffer-get buffer 'NEWS-GROUPS-SORTED? #f))

(define (news-server-buffer? buffer)
  (nntp-connection? (buffer-get buffer 'NNTP-CONNECTION #f)))

(define (news-server-buffer buffer error?)
  (if (news-server-buffer? buffer)
      buffer
      (let ((buffer (buffer-tree:parent buffer error?)))
	(and buffer
	     (news-server-buffer buffer error?)))))

(define (current-news-server-buffer error?)
  (news-server-buffer (selected-buffer) error?))

(define (news-server-buffer:connection buffer)
  (let ((connection (buffer-get buffer 'NNTP-CONNECTION #f)))
    (if (not (nntp-connection? connection))
	(error "Buffer isn't a News server buffer:" (buffer-name buffer)))
    connection))

(define (news-server-buffer:server buffer)
  (nntp-connection:server (news-server-buffer:connection buffer)))

(define (news-server-buffer:close-connection buffer)
  (nntp-connection:close (news-server-buffer:connection buffer)))

(define (make-nntp-connection-1 server buffer)
  (let ((entry (assoc server (ref-variable news-server-proxy-alist buffer))))
    (if entry
	(receive (proxy service) (parse-proxy-name (cdr entry))
	  (make-nntp-connection server
				proxy
				update-nntp-connection-modeline!
				service))
	(make-nntp-connection server #f update-nntp-connection-modeline!))))

(define (parse-proxy-name string)
  (let ((parts (burst-string string (char-set #\:) #f)))
    (cond ((and (pair? parts) (null? (cdr parts)))
	   (values (car parts) #!default))
	  ((and (pair? parts) (pair? (cdr parts)) (null? (cddr parts)))
	   (values (car parts)
                   (or (string->number (cadr parts) #d10)
                       (cadr parts))))
	  (else
	   (error "Malformed NNTP proxy name:" string)))))

(define (news-server-buffer:save-groups buffer)
  (write-groups-init-file buffer)
  (for-each-vector-element (news-server-buffer:groups buffer)
    (lambda (group)
      (write-ignored-subjects-file group
				   (find-news-group-buffer buffer group)))))

(define (initialize-news-groups-buffer buffer groups)
  (let ((mark (mark-left-inserting-copy (buffer-start buffer)))
	(server-buffer (news-server-buffer buffer #t)))
    (insert-string (news-groups-buffer:group-adjective buffer) mark)
    (insert-string " newsgroups on news server " mark)
    (insert-string (news-server-buffer:server server-buffer) mark)
    (insert-string ":" mark)
    (insert-newline mark)
    (for-each-vector-element groups
      (lambda (group)
	(if (news-groups-buffer:show-group? buffer group)
	    (insert-news-group-line group mark)
	    (set-news-group:index! group #f))))
    (mark-temporary! mark)))

(define (news-server-buffer:show-group? buffer group)
  (and (or (ref-variable news-show-unsubscribed-groups buffer)
	   (news-group:subscribed? group))
       (or (ref-variable news-show-nonexistent-groups buffer)
	   (news-group:active? group))))

(define (insert-news-group-line group mark)
  (let ((start (mark-right-inserting-copy mark)))
    (call-with-values
	(lambda ()
	  (if (news-group? group)
	      (values (news-group:subscribed? group)
		      (news-group:articles-marked? group)
		      (news-group:number-of-articles group)
		      (news-group:name group))
	      (values #f #f #f group)))
      (lambda (subscribed? marked? n-articles name)
	(insert-char (if subscribed? #\space #\U) mark)
	(insert-char (if marked? #\M #\space) mark)
	(insert-char #\space mark)
	(insert-string-pad-left (if n-articles (number->string n-articles) "")
				5 #\space mark)
	(insert-string " " mark)
	(insert-string name mark)
	(insert-newline mark)))
    (if (news-server-buffer? (mark-buffer start))
	(begin
	  (region-put! start mark 'NEWS-GROUP group)
	  (set-news-group:index! group (mark-index start))))
    (mark-temporary! start)))

(define (update-news-groups-buffers buffer group)
  (let ((buffer (news-server-buffer buffer #f)))
    (if buffer
	(begin
	  (news-server-buffer:update-group buffer group)
	  (for-each (lambda (child)
		      (let ((update-group
			     (buffer-get child 'UPDATE-NEWS-GROUP #f)))
			(if update-group
			    (update-group child group))))
		    (buffer-tree:children buffer))))))

(define (news-server-buffer:update-group buffer group)
  (let ((del
	 (let ((m (news-server-buffer:group-mark buffer group #f)))
	   (and m
		(mark-left-inserting-copy m))))
	(ins
	 (and (news-server-buffer:show-group? buffer group)
	      (news-server-buffer:find-group buffer (news-group:name group)
		(lambda (i)
		  (mark-left-inserting-copy
		   (let ((groups (news-server-buffer:groups buffer)))
		     (let loop ((i (fix:+ i 1)))
		       (if (fix:= i (vector-length groups))
			   (begin
			     (guarantee-newline (buffer-end buffer))
			     (buffer-end buffer))
			   (or (news-server-buffer:group-mark
				buffer (vector-ref groups i) #f)
			       (loop (fix:+ i 1))))))))
		(lambda (i) i #f)))))
    (if (or ins del)
	(with-buffer-open-1 buffer
	  (lambda ()
	    (let ((col
		   (and del ins
			(let ((point (buffer-point buffer)))
			  (and (mark<= del point)
			       (mark<= point (line-end del 0))
			       (mark-column point))))))
	      (if del (delete-string del (line-start del 1 'LIMIT)))
	      (if ins
		  (let ((m (mark-right-inserting-copy ins)))
		    (insert-news-group-line group ins)
		    (if col
			(set-buffer-point! buffer (move-to-column m col)))
		    (mark-temporary! m))
		  (set-news-group:index! group #f)))
	    (let loop
		((ls
		  (if (or (not ins) (and del (mark< del ins)))
		      del
		      ins)))
	      (let ((group (region-get ls 'NEWS-GROUP #f)))
		(if group
		    (set-news-group:index! group (mark-index ls))))
	      (let ((ls (line-start ls 1 #f)))
		(if ls
		    (loop ls))))
	    (if ins (mark-temporary! ins))
	    (if del (mark-temporary! del))))
	(set-news-group:index! group #f))))

(define (news-server-buffer:add-group buffer group)
  (news-server-buffer:find-group buffer (news-group:name group)
    (lambda (i) i unspecific)
    (lambda (i)
      (buffer-put! buffer 'NEWS-GROUPS
		   (vector-insert (news-server-buffer:groups buffer) i
				  group))))
  (update-news-groups-buffers buffer group))

(define (news-server-buffer:remove-group buffer group)
  (news-server-buffer:find-group buffer (news-group:name group)
    (lambda (i)
      (buffer-put! buffer 'NEWS-GROUPS
		   (vector-delete (news-server-buffer:groups buffer) i)))
    (lambda (i) i unspecific))
  (update-news-groups-buffers buffer group))

(define (install-news-groups-buffer-procedures buffer key group-mark mark-group
					       next-group previous-group
					       group-adjective show-group)
  (buffer-put! buffer 'NEWS-GROUPS-KEY key)
  (buffer-put! buffer 'GROUP-MARK group-mark)
  (buffer-put! buffer 'MARK-GROUP mark-group)
  (buffer-put! buffer 'NEXT-GROUP next-group)
  (buffer-put! buffer 'PREVIOUS-GROUP previous-group)
  (buffer-put! buffer 'GROUP-ADJECTIVE group-adjective)
  (buffer-put! buffer 'SHOW-GROUP show-group))

(define (news-groups-buffer:key buffer)
  (buffer-get buffer 'NEWS-GROUPS-KEY #f))

(define (news-groups-buffer:group-mark buffer group error?)
  ((buffer-get buffer 'GROUP-MARK #f) buffer group error?))

(define (news-groups-buffer:mark-group mark error?)
  (or ((buffer-get (mark-buffer mark) 'MARK-GROUP #f) mark)
      (and error? (not-on-property-line-error "news-group"))))

(define (news-groups-buffer:next-group buffer group)
  ((buffer-get buffer 'NEXT-GROUP #f) buffer group))

(define (news-groups-buffer:previous-group buffer group)
  ((buffer-get buffer 'PREVIOUS-GROUP #f) buffer group))

(define (news-groups-buffer:group-adjective buffer)
  ((buffer-get buffer 'GROUP-ADJECTIVE #f) buffer))

(define (news-groups-buffer:show-group? buffer group)
  ((buffer-get buffer 'SHOW-GROUP #f) buffer group))

(define (news-server-buffer:group-mark buffer group error?)
  (let ((index (news-group:index group)))
    (if index
	(make-mark (buffer-group buffer) index)
	(and error?
	     (error "Buffer has no line for this group:" group buffer)))))

(define (news-server-buffer:mark-group mark)
  (region-get mark 'NEWS-GROUP #f))

(define (news-server-buffer:next-group buffer group)
  (news-server-buffer:find-group buffer (news-group:name group)
    (lambda (i)
      (let ((groups (news-server-buffer:groups buffer)))
	(let loop ((i (fix:+ i 1)))
	  (and (fix:< i (vector-length groups))
	       (let ((group (vector-ref groups i)))
		 (if (news-server-buffer:group-mark buffer group #f)
		     group
		     (loop (fix:+ i 1))))))))
    (lambda (i) i #f)))

(define (news-server-buffer:previous-group buffer group)
  (news-server-buffer:find-group buffer (news-group:name group)
    (lambda (i)
      (let ((groups (news-server-buffer:groups buffer)))
	(let loop ((i (fix:- i 1)))
	  (and (fix:>= i 0)
	       (let ((group (vector-ref groups i)))
		 (if (news-server-buffer:group-mark buffer group #f)
		     group
		     (loop (fix:- i 1))))))))
    (lambda (i) i #f)))

(define (news-server-buffer:find-group buffer name if-found if-not-found)
  (let ((groups (news-server-buffer:groups buffer)))
    (if (news-server-buffer:groups-sorted? buffer)
	(search-ordered-vector groups name news-group:name string-order
			       if-found if-not-found)
	(let ((l (vector-length groups)))
	  (let loop ((i 0))
	    (cond ((fix:= i l)
		   (if-not-found i))
		  ((string=? (news-group:name (vector-ref groups i)) name)
		   (if-found i))
		  (else
		   (loop (fix:+ i 1)))))))))

(define (news-server-buffer:listed-group? buffer group)
  (news-server-buffer:find-group buffer
				 (news-group:name group)
				 (lambda (i) i #t)
				 (lambda (i) i #f)))

(define (news-server-buffer:group-adjective buffer)
  (if (ref-variable news-show-unsubscribed-groups buffer)
      "Selected"
      "Subscribed"))

;;;; News-Server Mode

(define-major-mode news-server news-common "News Server"
  "Major mode for browsing a News server.

Each line shows one of the News groups on the server.  The number near
the left of the line is an estimate of the number of unread messages
available in that group.  A `U' character appearing in the left column
indicates that the group is Unsubscribed.

When a News-server buffer is created, the hooks news-server-mode-hook
and news-common-mode-hook are invoked.

When a News-server buffer is killed, its associated News-group and
All-groups buffers are automatically killed at the same time.

This mode's commands include:

\\[news-read-subscribed-group-headers]	get unread headers for the subscribed groups
\\[news-read-group-headers]	get unread headers for the group indicated by point
\\[news-refresh-groups]	update estimates for the subscribed groups
\\[news-refresh-group]	update estimate for the group indicated by point
\\[news-save-server-data]	write info about the subscribed groups to the init file

\\[news-subscribe-group]	subscribe to the group indicated by point
\\[news-subscribe-group-by-name]	subscribe to a named group
\\[news-unsubscribe-group]	unsubscribe from the group indicated by point
\\[news-unsubscribe-group-backwards]	back up to the previous line and unsubscribe from its group

\\[news-all-groups]	show a list of all of this server's groups
\\[news-new-groups]	show a list of new groups on this server

\\[news-select-group]	browse articles in the group indicated by point
\\[news-compose-article]	post a new article to the group indicated by point
\\[mail]	send a new email message"
  (lambda (buffer)
    (event-distributor/invoke! (ref-variable news-server-mode-hook buffer)
			       buffer)))

(define-variable news-server-mode-hook
  "An event distributor that is invoked when entering News-server mode."
  (make-event-distributor))

(define-key 'news-server #\space 'news-select-group)
(define-key 'news-server #\g 'news-read-subscribed-group-headers)
(define-key 'news-server #\M-g 'news-read-group-headers)
(define-key 'news-server #\G 'news-refresh-groups)
(define-key 'news-server #\M-G 'news-refresh-group)
(define-key 'news-server #\l 'news-all-groups)
(define-key 'news-server #\n 'news-new-groups)
(define-key 'news-server #\r 'news-read-marked-bodies)
(define-key 'news-server #\s 'news-subscribe-group)
(define-key 'news-server #\M-s 'news-subscribe-group-by-name)
(define-key 'news-server #\u 'news-unsubscribe-group)
(define-key 'news-server #\rubout 'news-unsubscribe-group-backwards)

(define (current-news-group)
  (news-groups-buffer:mark-group (current-point) #t))

(define (group-iteration argument procedure)
  (iterate-on-lines (lambda (mark) (news-groups-buffer:mark-group mark #f))
		    "news-group" #f argument
		    (lambda (g) g)
		    news-groups-buffer:next-group
		    news-groups-buffer:previous-group
    (lambda (buffer group next n)
      (if argument
	  (let ((mark (news-groups-buffer:group-mark buffer group #f)))
	    (if mark
		(set-buffer-point! buffer mark))))
      (procedure buffer group)
      (if (and argument (> n 0) next)
	  (let ((mark (news-groups-buffer:group-mark buffer next #f)))
	    (if mark
		(set-buffer-point! buffer mark)))))))

(define-command news-select-group
  "Browse the News group indicated by point.
Select a buffer showing the subject lines of the articles in the News group.
With no argument, show all unread articles in the group.
With \\[universal-argument], show all of the group's articles.
With positive argument N, show the N newest unread articles.
With negative argument -N, show the N oldest unread articles."
  "P"
  (lambda (argument)
    (let ((buffer (current-news-server-buffer #t)))
      (let ((group (current-news-group)))
	(let ((buffer
	       (or (find-news-group-buffer buffer group)
		   (make-news-group-buffer buffer group argument)))
	      (key (news-groups-buffer:key (selected-buffer))))
	  (if (and key (not (buffer-get buffer 'SELECTED-FROM #f)))
	      (buffer-put! buffer 'SELECTED-FROM key))
	  (select-buffer buffer))
	(update-news-groups-buffers buffer group)))))

(define-command news-read-subscribed-group-headers
  "Read the unread headers for all of the subscribed News groups."
  ()
  (lambda ()
    (let ((buffer (current-news-server-buffer #t)))
      (for-each-vector-element (news-server-buffer:groups buffer)
	(lambda (group)
	  (if (news-group:subscribed? group)
	      (read-news-group-headers buffer group)
	      (refresh-news-group buffer group))
	  (update-screens! '(IGNORE-INPUT))))
      (news-server-buffer:save-groups buffer))))

(define-command news-read-group-headers
  "Read the unread headers for the News group indicated by point.
With prefix argument, updates the next several News groups."
  "P"
  (lambda (argument)
    (group-iteration argument read-news-group-headers)))

(define (read-news-group-headers buffer group)
  (news-group:get-unread-headers group buffer)
  (update-news-groups-buffers buffer group)
  (write-ignored-subjects-file group buffer)
  (write-groups-init-file buffer))

(define-command news-refresh-groups
  "Update the unread-message estimates for all of the News groups shown.
This command has no effect in the all-groups buffer."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (if (news-server-buffer? buffer)
	  (begin
	    (for-each-vector-element (news-server-buffer:groups buffer)
	      (lambda (group)
		(refresh-news-group buffer group)
		(update-screens! '(IGNORE-INPUT))))
	    (news-server-buffer:save-groups buffer))))))

(define-command news-refresh-group
  "Update the unread-message estimate for the News group indicated by point.
With prefix argument, updates the next several News groups."
  "P"
  (lambda (argument)
    (group-iteration argument refresh-news-group)))

(define (refresh-news-group buffer group)
  (let ((msg
	 (string-append "Refreshing news group "
			(news-group:name group)
			"... ")))
    (message msg)
    (news-group:update-ranges! group)
    (update-news-groups-buffers buffer group)
    (message msg "done")))

(define-command news-clear-read-messages
  "Clear the read-messages list for the News group indicated by point.
With prefix argument, clears the list for the next several News groups."
  "P"
  (lambda (argument)
    (group-iteration argument
      (lambda (buffer group)
	(set-news-group:ranges-deleted! group '())
	(update-news-groups-buffers buffer group)))))

(define-command news-subscribe-group
  "Subscribe to the News group indicated by point.
With prefix argument, subscribes to the next several News groups."
  "P"
  (lambda (argument)
    (group-iteration argument subscribe-news-group)))

(define (subscribe-news-group buffer group)
  (set-news-group:subscribed?! group #t)
  (news-server-buffer:add-group (news-server-buffer buffer #t) group))

(define-command news-subscribe-group-by-name
  "Subscribe to a News group by name.
Prompts for the News-group name, with completion."
  ()
  (lambda ()
    (let ((buffer (current-news-server-buffer #t)))
      (subscribe-news-group
       buffer
       (prompt-for-active-news-group "Subscribe to news group"
				     #f
				     buffer)))))

(define (prompt-for-active-news-group prompt default server-buffer)
  (let ((connection (news-server-buffer:connection server-buffer)))
    (let ((group-names
	   (lambda () (nntp-connection:active-groups connection #f)))
	  (string->group
	   (lambda (string)
	     (let ((group (find-active-news-group connection string)))
	       (if group (news-group:apply-cache-policy group))
	       group))))
      (string->group
       (let ((convert
	      (lambda (vector) (map news-group:name (vector->list vector)))))
	 (prompt-for-completed-string prompt default
	   (lambda (string if-unique if-not-unique if-not-found)
	     (ordered-vector-minimum-match (group-names) string (lambda (s) s)
					   string-order (prefix-matcher string)
	       if-unique
	       (lambda (name gcm all-matches)
		 (if-not-unique (string-head name gcm)
				(lambda () (convert (all-matches)))))
	       if-not-found))
	   (lambda (string)
	     (convert
	      (ordered-vector-matches (group-names) string (lambda (s) s)
				      string-order (prefix-matcher string))))
	   string->group
	   'REQUIRE-MATCH? #t))))))

(define-command news-unsubscribe-group
  "Unsubscribe from the News group indicated by point.
With prefix argument, unsubscribes from the next several News groups."
  "P"
  (lambda (argument)
    (group-iteration argument unsubscribe-news-group)))

(define-command news-unsubscribe-group-backwards
  "Back up to the previous News group and unsubscribe from it.
With prefix argument, unsubscribes from the previous several News groups."
  "p"
  (lambda (argument)
    (group-iteration (- argument) unsubscribe-news-group)))

(define (unsubscribe-news-group buffer group)
  (news-group:purge-pre-read-headers group 'ALL)
  (news-group:close-database group)
  (set-news-group:subscribed?! group #f)
  (update-news-groups-buffers buffer group))

;;;; All-Groups Buffer

(define-command news-all-groups
  "Select a buffer showing all of the News groups on this server.
This buffer shows subscribed and unsubscribed groups, and is useful
 for choosing new groups to subscribe to.
Normally, the News groups list is saved in a local file, so that
 subsequent references to the list do not require interacting with the
 server.
With prefix argument, the saved list is discarded and a new list is
 obtained from the server."
  "P"
  (lambda (argument)
    (select-buffer
     (let ((server-buffer (current-news-server-buffer #t)))
       (or (buffer-tree:child server-buffer 'ALL-NEWS-GROUPS #f)
	   (make-ang-buffer server-buffer
			    (nntp-connection:active-groups
			     (news-server-buffer:connection server-buffer)
			     argument)
			    "all"
			    'ALL-NEWS-GROUPS))))))

(define (all-news-groups-buffer? buffer)
  (let ((server-buffer (news-server-buffer buffer #f)))
    (and server-buffer
	 (eq? buffer (buffer-tree:child server-buffer 'ALL-NEWS-GROUPS #f)))))

(define-command news-new-groups
  "Select a buffer showing new News groups on this server.
This shows News groups that have been created since the last time that
 the News-groups list was examined."
  ()
  (lambda ()
    (let ((server-buffer (current-news-server-buffer #t)))
      (let ((buffer (buffer-tree:child server-buffer 'NEW-NEWS-GROUPS #f)))
	(if buffer
	    (select-buffer buffer)
	    (let ((new-groups
		   (nntp-connection:new-groups
		    (news-server-buffer:connection server-buffer))))
	      (if (= (vector-length new-groups) 0)
		  (message "No new News groups since previous check")
		  (let ((all-groups-buffer
			 (buffer-tree:child server-buffer 'ALL-NEWS-GROUPS
					    #f)))
		    (if all-groups-buffer
			(for-each-vector-element new-groups
			  (lambda (name)
			    (ang-buffer:insert-group-line all-groups-buffer
							  name))))
		    (select-buffer
		     (make-ang-buffer server-buffer
				      new-groups
				      "new"
				      'NEW-NEWS-GROUPS))))))))))

(define (new-news-groups-buffer? buffer)
  (let ((server-buffer (news-server-buffer buffer #f)))
    (and server-buffer
	 (eq? buffer (buffer-tree:child server-buffer 'NEW-NEWS-GROUPS #f)))))

(define (make-ang-buffer server-buffer group-names prefix keyword)
  (let ((name (string-append prefix "-groups")))
    (create-news-buffer
     (news-buffer-name (news-server-buffer:server server-buffer) name)
     (ref-mode-object news-server)
     (lambda (buffer)
       (buffer-tree:attach-child! server-buffer keyword buffer)
       (add-kill-buffer-hook buffer ang-buffer:kill)
       (buffer-put! buffer 'UPDATE-NEWS-GROUP ang-buffer:update-group)
       (install-news-groups-buffer-procedures
	buffer
	keyword
	ang-buffer:group-mark
	ang-buffer:mark-group
	ang-buffer:next-group
	ang-buffer:previous-group
	(lambda (buffer) buffer (string-capitalize prefix))
	(lambda (buffer group) buffer group #t))
       (let ((msg (string-append "Building " name " buffer... ")))
	 (message msg)
	 (initialize-news-groups-buffer
	  buffer
	  (vector-map (lambda (name) (name->news-group buffer name))
		      group-names))
	 (message msg "done"))
       (find-first-line buffer ang-buffer:mark-group-name)))))

(define (ang-buffer:kill buffer)
  (ignore-errors
   (lambda ()
     (let ((buffer (news-server-buffer buffer #f)))
       (if buffer
	   (nntp-connection:purge-group-cache
	    (news-server-buffer:connection buffer)
	    (lambda (group)
	      (not (news-server-buffer:listed-group? buffer group)))))))))

(define (ang-buffer:update-group buffer group)
  (let ((mark (ang-buffer:group-mark buffer group #f)))
    (if mark
	(ang-buffer:replace-group-line buffer group mark))))

(define (ang-buffer:insert-group-line buffer name)
  (let ((group (name->news-group buffer name)))
    (ang-buffer:find-line buffer name
			  (lambda (ls)
			    (ang-buffer:replace-group-line buffer group ls))
			  (lambda (ls)
			    (insert-news-group-line group ls)))))

(define (ang-buffer:replace-group-line buffer group ls)
  (with-buffer-open-1 buffer
    (lambda ()
      (let ((ls (mark-right-inserting-copy ls))
	    (col
	     (let ((point (buffer-point buffer)))
	       (and (mark<= ls point)
		    (mark<= point (line-end ls 0))
		    (mark-column point)))))
	(delete-string ls (line-start ls 1 'LIMIT))
	(let ((ls (mark-left-inserting-copy ls)))
	  (insert-news-group-line group ls)
	  (mark-temporary! ls))
	(if col (set-buffer-point! buffer (move-to-column ls col)))
	(mark-temporary! ls)))))

(define (name->news-group buffer name)
  (let ((connection
	 (let ((buffer (news-server-buffer buffer #f)))
	   (and buffer
		(news-server-buffer:connection buffer)))))
    (or (and connection
	     (find-news-group connection name))
	name)))

(define (ang-buffer:group-mark buffer group error?)
  (ang-buffer:find-line buffer
			(news-group:name group)
			(lambda (ls) ls)
			(lambda (ls)
			  ls
			  (and error?
			       (error "Buffer has no line for this group:"
				      group buffer)))))

(define (ang-buffer:find-line buffer name if-found if-not-found)
  (find-buffer-line buffer
		    ang-buffer:mark-group-name
		    (lambda (name*) (string-order name name*))
		    if-found
		    if-not-found))

(define (ang-buffer:next-group buffer group)
  (let ((m (ang-buffer:group-mark buffer group #f)))
    (and m
	 (let ((m (line-start m 1 #f)))
	   (and m
		(ang-buffer:mark-group m))))))

(define (ang-buffer:previous-group buffer group)
  (let ((m (ang-buffer:group-mark buffer group #f)))
    (and m
	 (let ((m (line-start m -1 #f)))
	   (and m
		(ang-buffer:mark-group m))))))

(define (ang-buffer:mark-group mark)
  (let ((name (ang-buffer:mark-group-name mark)))
    (and name
	 (let ((connection (buffer-nntp-connection (mark-buffer mark))))
	   (or (find-news-group connection name)
	       (make-news-group-1 connection name #f #f '() '() '()))))))

(define (ang-buffer:mark-group-name mark)
  (and (re-match-forward
	"^[ U][ M] [ 0-9][ 0-9][ 0-9][ 0-9][ 0-9] \\([^ ]+\\)$"
	(line-start mark 0)
	(line-end mark 0)
	#f)
       (extract-string (re-match-start 1) (re-match-end 1))))

;;;; News-Group Buffer

(define (find-news-group-buffer server-buffer group)
  (buffer-tree:child server-buffer group #f))

(define (make-news-group-buffer server-buffer group argument)
  (create-news-buffer (news-group-buffer-name group)
		      (ref-mode-object news-group)
    (lambda (buffer)
      (buffer-put! buffer 'NEWS-GROUP group)
      (buffer-tree:attach-child! server-buffer group buffer)
      (add-kill-buffer-hook buffer news-group-buffer:kill)
      (add-select-buffer-hook buffer news-group-buffer:select)
      (initialize-news-group-buffer buffer argument)
      (let ((ls (find-first-property-line buffer 'NEWS-HEADER #f)))
	(and ls
	     (let ((header
		    (let ((header (region-get ls 'NEWS-HEADER #f)))
		      (and (news-header:article-deleted? header)
			   (news-group-buffer:next-header
			    buffer header news-header:unread?)))))
	       (if header
		   (if (news-header:pre-read-body? header)
		       (news-group-buffer:header-mark-1 buffer header)
		       (or (news-group-buffer:header-mark buffer header)
			   (news-group-buffer:thread-start-mark
			    buffer (news-header:thread header)) ls))
		   ls)))))))

(define (news-group-buffer-name group)
  (news-buffer-name (news-group:server group) (news-group:name group)))

(define (news-group-buffer? buffer)
  (news-group? (buffer-get buffer 'NEWS-GROUP #f)))

(define (news-group-buffer:group buffer)
  (let ((group (buffer-get buffer 'NEWS-GROUP #f)))
    (if (not (news-group? group))
	(error:wrong-type-argument buffer "News-group buffer"
				   'NEWS-GROUP-BUFFER:GROUP))
    group))

(define (news-group-buffer buffer error?)
  (if (news-group-buffer? buffer)
      buffer
      (let ((buffer (buffer-tree:parent buffer error?)))
	(and buffer
	     (news-group-buffer buffer error?)))))

(define (news-group-buffer:kill buffer)
  (ignore-errors
   (lambda ()
     (let ((group (news-group-buffer:group buffer)))
       (update-news-groups-buffers buffer group)
       (write-ignored-subjects-file group buffer)
       (if (and (selected-buffer? buffer)
		(eq? (buffer-get buffer 'SELECTED-FROM #f) 'SERVER))
	   (let ((buffer (news-server-buffer buffer #t)))
	     (if (eq? group (region-get (buffer-point buffer) 'NEWS-GROUP #f))
		 (let loop ((group group))
		   (let ((next (news-server-buffer:next-group buffer group)))
		     (if next
			 (let ((n (news-group:number-of-articles next)))
			   (if (and n (> n 0))
			       (let ((ls
				      (news-server-buffer:group-mark
				       buffer next #f)))
				 (if ls
				     (set-buffer-point! buffer ls)))
			       (loop next)))))))))
       (news-group:purge-and-compact-headers! group buffer)
       (set-news-group:ignored-subjects! group 'UNKNOWN)
       (write-groups-init-file buffer)))))

(define (news-group-buffer:select group-buffer window)
  (news-group-buffer:delete-context-window group-buffer window))

(define (initialize-news-group-buffer buffer argument)
  (let ((group (news-group-buffer:group buffer)))
    (let ((mark (mark-left-inserting-copy (buffer-end buffer)))
	  (threads (news-group:get-threads group argument buffer)))
      (for-each-vector-element threads
	(let ((expanded?
	       (not (ref-variable news-initially-collapse-threads buffer))))
	  (lambda (thread)
	    (set-news-thread:expanded?! thread expanded?))))
      (buffer-put! buffer 'NEWS-THREADS threads)
      (insert-string "Messages in news group " mark)
      (insert-string (news-group:name group) mark)
      (insert-string " on server " mark)
      (insert-string (news-group:server group) mark)
      (insert-string ":" mark)
      (insert-newline mark)
      (for-each-vector-element threads
	(lambda (thread)
	  (insert-news-thread-lines thread mark)))
      (mark-temporary! mark))
    (update-news-groups-buffers buffer group)
    (news-group:close-database group)))

(define (news-group-buffer:collapse-thread buffer thread)
  (if (news-thread:expanded? thread)
      (news-group-buffer:adjust-thread-display buffer thread #f)))

(define (news-group-buffer:expand-thread buffer thread)
  (if (not (news-thread:expanded? thread))
      (news-group-buffer:adjust-thread-display buffer thread #t)))

(define (news-group-buffer:auto-expand-thread buffer thread)
  (if (not (news-thread:expanded? thread))
      (news-group-buffer:adjust-thread-display buffer thread 'AUTOMATIC)))

(define (news-group-buffer:adjust-thread-display buffer thread expanded?)
  (with-buffer-open-1 buffer
    (lambda ()
      (let ((ls
	     (mark-left-inserting-copy
	      (or (delete-news-thread-lines buffer thread)
		  (let loop ((thread thread))
		    (let ((next (news-group-buffer:next-thread buffer thread)))
		      (if next
			  (or (news-group-buffer:thread-start-mark buffer next)
			      (loop next))
			  (begin
			    (guarantee-newline (buffer-end buffer))
			    (buffer-end buffer)))))))))
	(set-news-thread:expanded?! thread expanded?)
	(insert-news-thread-lines thread ls)
	(mark-temporary! ls)
	(update-subsequent-news-header-lines ls)))))

(define (delete-news-thread-lines buffer thread)
  (let ((region (news-thread-lines-region buffer thread)))
    (and region
	 (let ((start (mark-right-inserting-copy (region-start region))))
	   (news-thread:clear-indices! thread)
	   (delete-string start (region-end region))
	   (mark-temporary! start)
	   start))))

(define (news-thread-lines-region buffer thread)
  (let ((ls (news-group-buffer:thread-start-mark buffer thread)))
    (and ls
	 (let ((start (mark-temporary-copy ls))
	       (end (mark-temporary-copy (line-start ls 1 'LIMIT))))
	   (news-thread:for-each-header thread
	     (lambda (header)
	       (let ((ls (news-group-buffer:header-mark buffer header)))
		 (if ls
		     (let ((nls (line-start ls 1 'LIMIT)))
		       (if (mark< ls start) (move-mark-to! start ls))
		       (if (mark> nls end) (move-mark-to! end nls)))))))
	   (make-region start end)))))

(define (insert-news-thread-lines thread mark)
  (if (news-thread:show-collapsed? thread)
      (insert-collapsed-news-thread-line thread mark)
      (insert-expanded-news-thread-lines thread mark))
  (news-thread:for-each-real-header thread
    (let ((buffer (mark-buffer mark)))
      (lambda (header)
	(news-header:article-browsed! header buffer)))))

(define (insert-expanded-news-thread-lines thread mark)
  (let ((subject
	 (news-header:subject
	  (news-thread:first-header thread news-header:real?))))
    (let loop ((header (news-thread:root thread)) (indentation 0))
      (if (news-header:real? header)
	  (let* ((subject* (news-header:subject header)))
	    (let ((comparison
		   (and (> indentation 0)
			(compare-subjects
			 (canonicalize-subject subject)
			 (canonicalize-subject subject*)))))
	      (insert-news-header-line header
				       indentation
				       (and (not comparison) subject*)
				       mark)
	      (if (or (not comparison)
		      ;; OK to lengthen prefix, but don't shorten.
		      (eq? 'LEFT-PREFIX comparison))
		  (set! subject subject*))))
	  (insert-dummy-header-line header indentation
				    (and (= indentation 0) subject)
				    mark))
      (for-each (let ((indentation (+ indentation 4)))
		  (lambda (header)
		    (loop header indentation)))
		(news-header:followups header)))))

(define (insert-collapsed-news-thread-line thread mark)
  (news-thread:for-each-header thread
    (lambda (header)
      (set-news-header:index! header #f)))
  (let ((header (news-thread:first-header thread news-header:real?)))
    (insert-subject-line
     (news-thread:status thread)
     (news-thread:pre-read-bodies thread)
     (lambda (mark width)
       (insert-char #\+ mark)
       (insert-string-pad-left
	(string-append
	 (number->string
	  (- (news-thread:n-articles thread news-header:real?) 1))
	 ">")
	(- width 1)
	#\space
	mark))
     0
     (news-header:subject header)
     (news-header:from header)
     header
     mark)))

(define (update-subsequent-news-header-lines ls)
  (let ((header (region-get ls 'NEWS-HEADER #f)))
    (if header
	(set-news-header:index! header (mark-index ls))))
  (let ((ls (line-start ls 1 #f)))
    (if ls
	(update-subsequent-news-header-lines ls))))

(define (insert-news-header-line header indentation subject mark)
  (insert-subject-line (news-header:status header)
		       (news-header:pre-read-body? header)
		       (news-header:n-lines header)
		       indentation
		       subject
		       (news-header:from header)
		       header
		       mark))

(define (insert-dummy-header-line header indentation subject mark)
  (insert-subject-line #\space #f "" indentation subject #f header mark))

(define (insert-subject-line status b? n indentation subject from header mark)
  (let ((start (mark-right-inserting-copy mark)))
    (insert-char status mark)
    (insert-char (case b?
		   ((#f) #\space)
		   ((SOME) #\b)
		   (else #\B))
		 mark)
    (if (string? n)
	(begin
	  (insert-char #\space mark)
	  (insert-string-pad-left n 4 #\space mark)
	  (insert-char #\space mark))
	(n mark 6))
    (insert-char #\space mark)
    (insert-chars #\space indentation mark)
    (if subject
	(let ((subject-column (mark-column mark))
	      (subject/author-spacing 5)
	      (author-columns (ref-variable news-group-author-columns mark))
	      (x-size (mark-x-size mark)))
	  (let ((subject-length
		 (max (- (- x-size 1)
			 (+ subject-column
			    subject/author-spacing
			    author-columns))
		      10)))
	    (insert-string (if (> (string-length subject) subject-length)
			       (string-head subject subject-length)
			       subject)
			   mark)
	    (if from
		(let ((delta
		       (- (+ subject-column
			     subject-length
			     subject/author-spacing)
			  (mark-column mark))))
		  (if (> delta 0)
		      (insert-chars #\space delta mark)))))))
    (if (or from (not subject))
	(begin
	  (insert-string "(" mark)
	  (insert-string (if from (compose-author-string from mark) "...")
			 mark)
	  (insert-char #\) mark)))
    (insert-newline mark)
    (region-put! start mark 'NEWS-HEADER header)
    (news-group-buffer:maybe-highlight-header header start)
    (set-news-header:index! header (mark-index start))
    (mark-temporary! start)))

(define (compose-author-string from mark)
  (let ((r
	 (and (ref-variable news-group-show-author-name mark)
	      (or (re-string-match "^\"\\(.+\\)\"[ \t]+<.+>$" from)
		  (re-string-match "^\\(.+\\)<.+>$" from)
		  (re-string-match "^[^ \t]+[ \t]+(\\(.+\\))$" from)))))
    (if r
	(string-trim (substring from
				(re-match-start-index 1 r)
				(re-match-end-index 1 r)))
	(or (rfc822:first-address from) from))))

(define (news-group-buffer:header-mark buffer header)
  (let ((index (news-header:index header)))
    (and index
	 (make-mark (buffer-group buffer) index))))

(define (news-group-buffer:thread-start-mark buffer thread)
  (let ((header
	 (news-thread:first-header thread
	   (lambda (header)
	     (news-group-buffer:header-mark buffer header)))))
    (and header
	 (news-group-buffer:header-mark buffer header))))

(define (update-buffer-news-header-status buffer header)
  (let ((mark (news-group-buffer:header-mark buffer header))
	(thread (news-header:thread header)))
    (if (and mark (not (news-thread:show-collapsed? thread)))
	(%update-buffer-news-header-status buffer mark
					   (news-header:status header)
					   (news-header:pre-read-body? header))
	(update-buffer-news-thread-status buffer thread))))

(define (update-buffer-news-thread-status buffer thread)
  (let ((header (news-thread:first-header thread news-header:real?)))
    (let ((mark (news-group-buffer:header-mark buffer header)))
      (if mark
	  (%update-buffer-news-header-status
	   buffer mark
	   (news-thread:status thread)
	   (if (news-thread:show-collapsed? thread)
	       (news-thread:pre-read-bodies thread)
	       (news-header:pre-read-body? header)))))))

(define (%update-buffer-news-header-status buffer mark status body?)
  (with-buffer-open-1 buffer
    (lambda ()
      (let ((mark (mark-right-inserting-copy mark))
	    (header (region-get mark 'NEWS-HEADER #f)))
	(let ((preserve-point? (mark= (buffer-point buffer) mark)))
	  (delete-right-char mark)
	  (delete-right-char mark)
	  (insert-char (case body?
			 ((#f) #\space)
			 ((SOME) #\b)
			 (else #\B))
		       mark)
	  (insert-char status mark)
	  ;; Grumble: must rewrite 'NEWS-HEADER property because
	  ;; inserted characters have no properties.
	  (region-put! mark (mark+ mark 2) 'NEWS-HEADER header)
	  (news-group-buffer:maybe-highlight-header header mark)
	  (if preserve-point? (set-buffer-point! buffer mark)))
	(mark-temporary! mark)))))

(define (news-group-buffer:maybe-highlight-header header mark)
  (highlight-region
   (make-region (mark+ mark 2) (mark+ mark 6))
   (if (and (ref-variable news-article-highlight-selected mark)
	    (find-news-article-buffer (mark-buffer mark)
				      header))
       (highlight-face)
       (default-face))))

(define (news-group-buffer:move-to-header buffer header)
  (let ((point (news-group-buffer:header-mark-1 buffer header))
	(header* (region-get (buffer-point buffer) 'NEWS-HEADER #f)))
    (if (not (eq? header header*))
	(begin
	  (with-editor-interrupts-disabled
	    (lambda ()
	      (set-buffer-point! buffer point)
	      (news-group-buffer:maybe-update-context-window buffer point)))
	  (let ((flag
		 (ref-variable news-automatically-collapse-threads buffer)))
	    (if (and header* (not (eq? flag 'NEVER)))
		(let ((thread (news-header:thread header*)))
		  (if (and (not (eq? thread (news-header:thread header)))
			   (let ((expanded? (news-thread:expanded? thread)))
			     (and expanded?
				  (or (eq? expanded? 'AUTOMATIC)
				      (eq? flag 'ALWAYS)))))
		      (news-group-buffer:collapse-thread buffer thread)))))))))

(define (news-group-buffer:header-mark-1 buffer header)
  (or (news-group-buffer:header-mark buffer header)
      (begin
	(news-group-buffer:auto-expand-thread buffer
					      (news-header:thread header))
	(news-group-buffer:header-mark buffer header))
      (error "News header invisible after thread expansion:" header)))

(define (news-group-buffer:threads buffer)
  (buffer-get buffer 'NEWS-THREADS '#()))

(define (news-group-buffer:next-thread buffer thread)
  (let ((threads (news-group-buffer:threads buffer)))
    (let ((index (find-thread-index threads thread)))
      (and index
	   (fix:< (fix:+ index 1) (vector-length threads))
	   (vector-ref threads (fix:+ index 1))))))

(define (news-group-buffer:previous-thread buffer thread)
  (let ((threads (news-group-buffer:threads buffer)))
    (let ((index (find-thread-index threads thread)))
      (and index
	   (fix:> index 0)
	   (vector-ref threads (fix:- index 1))))))

(define (find-thread-index threads thread)
  (search-ordered-vector threads thread (lambda (t) t)
			 (lambda (t1 t2)
			   (cond ((news-thread:< t1 t2) 'LESS)
				 ((news-thread:< t2 t1) 'GREATER)
				 (else 'EQUAL)))
			 (lambda (i) i)
			 (lambda (i) i #f)))

(define (news-group-buffer:next-header buffer header predicate)
  (or (news-thread:next-header header predicate)
      (news-group-buffer:first-header-in-next-thread buffer header predicate)))

(define (news-group-buffer:previous-header buffer header predicate)
  (or (news-thread:previous-header header predicate)
      (news-group-buffer:last-header-in-previous-thread buffer header
							predicate)))

(define (news-group-buffer:first-header-in-next-thread buffer header predicate)
  (let loop ((thread (news-header:thread header)))
    (let ((thread (news-group-buffer:next-thread buffer thread)))
      (and thread
	   (or (news-thread:first-header thread predicate)
	       (loop thread))))))

(define (news-group-buffer:last-header-in-previous-thread buffer header
							  predicate)
  (let loop ((thread (news-header:thread header)))
    (let ((thread (news-group-buffer:previous-thread buffer thread)))
      (and thread
	   (or (news-thread:last-header thread predicate)
	       (loop thread))))))

;;;; Article Context Window

(define (show-news-article-context article-window context-lines)
  (with-editor-interrupts-disabled
    (lambda ()
      (let ((context-window
	     (window-split-vertically! article-window
				       (- (window-y-size article-window)
					  context-lines)))
	    (group-buffer
	     (buffer-tree:parent (window-buffer article-window) #t)))
	(buffer-put! group-buffer 'CONTEXT-WINDOW
		     (weak-cons context-window #f))
	(select-buffer group-buffer context-window)
	(center-news-article-context context-window)))))

(define (news-group-buffer:delete-context-window group-buffer window)
  (let ((context-window (news-group-buffer:context-window group-buffer #t)))
    (if (and context-window (not (eq? window context-window)))
	(with-editor-interrupts-disabled
	  (lambda ()
	    (window-delete! context-window window)
	    (buffer-remove! group-buffer 'CONTEXT-WINDOW))))))

(define (news-group-buffer:maybe-update-context-window group-buffer mark)
  (let ((context-window (news-group-buffer:context-window group-buffer #t)))
    (if context-window
	(begin
	  (set-window-point! context-window mark)
	  (center-news-article-context context-window)))))

(define (center-news-article-context context-window)
  (window-scroll-y-absolute! context-window
			     (integer-floor (window-y-size context-window) 2)))

(define (news-group-buffer:context-window buffer require-buffer?)
  (let ((pair (buffer-get buffer 'CONTEXT-WINDOW #f)))
    (and pair
	 (let ((window
		(let ((window (weak-car pair)))
		  (and (window? window)
		       (window-visible? window)
		       (or (not require-buffer?)
			   (eq? buffer (window-buffer window)))
		       window))))
	   (if (not window)
	       (buffer-remove! buffer 'CONTEXT-WINDOW))
	   window))))

;;;; News-Group Mode

(define-major-mode news-group news-common "News Group"
  "Major mode for browsing subjects of articles in a News group.

Each line shows one of the articles in the group.  A `D' in the left
column indicates that the article has either been read or marked as
such.  The right-hand side of the line shows the subject line from the
article, followed by the author's name in parenthesis.

Articles are grouped into conversational `threads' where possible.
Such threads can be `expanded', such that all of the articles
composing the thread are shown, or `collapsed', in which only the
first article of the thread is shown.

When expanded, the subjects of followup articles are suppressed, and
the parenthesized author's name appears indented.  The indentation
shows the structure of the conversation, with follow-ups being
indented a bit more than the articles they follow-up to.  The number
appearing to the left of the column is an estimate of the number of
lines in the message; if blank it means that the associated article is
no longer available from the server.

When collapsed, a thread is represented by a single line, which shows
the subject and author of the first message in the thread.  The second
column contains a `+' character, followed by the number of articles in
the thread in addition to the one that is shown.  Moving into the
thread's other articles will cause the thread to expand automatically.

The variable news-initially-collapse-threads controls whether threads
are initially collapsed or expanded.

The variable news-automatically-collapse-threads controls whether the
thread will collapse again when it is left.

A collapsed thread's status is shown by the character in the left
column.  A space indicates that all of the articles in the thread are
unread, a `D' that all of the articles are read, and a `d' that the
thread contains both read and unread articles.  Similarly, an `I'
indicates that all of the thread's articles have been ignored, and an
`i' that only some of them have been ignored.

The variable news-group-author-columns can be used to control the
appearance of header lines.

When a News-group buffer is created, the hooks news-group-mode-hook
and news-common-mode-hook are invoked.

This mode's commands include:

\\[news-select-article]	select a buffer containing the article indicated by point
\\[news-compose-article]	post a new article to this group
\\[mail]	send a new email message

\\[news-delete-article]	mark the article indicated by point as read
\\[news-delete-thread]	mark the whole thread as read
\\[news-mark-article]	mark the article indicated by point for retrieval
\\[news-mark-thread]	mark the whole thread for retrieval
\\[news-ignore-thread]	ignore the thread indicated by point
\\[news-unmark-article]	unmark the article indicated by point
\\[news-unmark-thread]	unmark the whole thread
\\[news-unmark-article-backwards]	move to prev line and unmark article

\\[news-group-next-unread-header]	move down to the next unread article
\\[news-group-next-unread-article]	move down to the next unread article and select it
\\[news-group-next-thread]	move down to the next unread thread
\\[news-group-next-thread-article]	move down to the next unread thread and select it
\\[news-group-previous-unread-header]	move up to the previous unread article
\\[news-group-previous-unread-article]	move up to the previous unread article and select it
\\[news-group-previous-thread]	move up to the previous unread thread
\\[news-group-previous-thread-article]	move up to the previous unread thread and select it

\\[news-toggle-thread]	toggle current thread between collapsed and expanded
\\[news-collapse-threads]	collapse all threads
\\[news-expand-threads]	expand all threads

\\[news-output-article]	output this article to a mail file
\\[news-output-article-to-rmail-file]	output this article to an RMAIL file

\\[news-catch-up-group]	mark all articles as read and return to news-groups buffer
\\[news-expunge-group]	remove marked threads from the article list
\\[news-revert-group]	refresh the article list from the news server
\\[news-save-server-data]	write info about the subscribed groups to the init file

\\[news-group-show-header]	show the header of the article indicated by point
\\[news-group-show-subject]	show the subject of the article indicated by point"
  (lambda (buffer)
    (local-set-variable! truncate-lines #t buffer)
    (event-distributor/invoke! (ref-variable news-group-mode-hook buffer)
			       buffer)))

(define-variable news-group-mode-hook
  "An event distributor that is invoked when entering News-group mode."
  (make-event-distributor))

(define-key 'news-group #\space 'news-select-article)
(define-key 'news-group #\c 'news-catch-up-group)
(define-key 'news-group #\M-c 'news-collapse-threads)
(define-key 'news-group #\d 'news-delete-article)
(define-key 'news-group #\M-d 'news-delete-thread)
(define-key 'news-group #\M-e 'news-expand-threads)
(define-key 'news-group #\g 'news-revert-group)
(define-key 'news-group #\h 'news-group-show-header)
(define-key 'news-group #\i 'news-ignore-thread)
(define-key 'news-group #\m 'news-mark-article)
(define-key 'news-group #\M-m 'news-mark-thread)
(define-key 'news-group #\n 'news-group-next-unread-header)
(define-key 'news-group #\N 'news-group-next-unread-article)
(define-key 'news-group #\M-n 'news-group-next-thread)
(define-key 'news-group #\M-N 'news-group-next-thread-article)
(define-key 'news-group #\o 'news-output-article-to-rmail-file)
(define-key 'news-group #\c-o 'news-output-article)
(define-key 'news-group #\p 'news-group-previous-unread-header)
(define-key 'news-group #\P 'news-group-previous-unread-article)
(define-key 'news-group #\M-p 'news-group-previous-thread)
(define-key 'news-group #\M-P 'news-group-previous-thread-article)
(define-key 'news-group #\q 'news-group-quit)
(define-key 'news-group #\r 'news-read-marked-bodies)
(define-key 'news-group #\s 'news-group-show-subject)
(define-key 'news-group #\t 'news-toggle-thread)
(define-key 'news-group #\u 'news-unmark-article)
(define-key 'news-group #\M-u 'news-unmark-thread)
(define-key 'news-group #\x 'news-expunge-group)
(define-key 'news-group #\rubout 'news-unmark-article-backwards)

(define (current-news-header)
  (let ((header (region-get (current-point) 'NEWS-HEADER #f)))
    (if (not header)
	(not-on-property-line-error "news-article header"))
    header))

(define-command news-group-next-unread-header
  "Move down to the next unread article header.
With prefix argument, moves down several headers."
  "p"
  (lambda (n)
    (let ((b (selected-buffer))
	  (m (current-point)))
      (define (next-loop h n)
	(if (= n 0)
	    (win h)
	    (let ((next
		   (news-group-buffer:next-header b h news-header:unread?)))
	      (if next
		  (next-loop next (- n 1))
		  (partial-win h n)))))

      (define (prev-loop h n)
	(if (= n 0)
	    (win h)
	    (let ((next
		   (news-group-buffer:previous-header b h
						      news-header:unread?)))
	      (if next
		  (prev-loop next (+ n 1))
		  (partial-win h n)))))

      (define (win h)
	(news-group-buffer:move-to-header b h)
	#t)

      (define (partial-win h n*)
	(if (not (= n n*)) (news-group-buffer:move-to-header b h))
	(lose))

      (define (lose)
	(editor-failure)
	#f)

      (cond ((> n 0)
	     (cond ((region-get m 'NEWS-HEADER #f)
		    => (lambda (h) (next-loop h n)))
		   ((find-next-line-property m 'NEWS-HEADER #f)
		    => (lambda (h)
			 (next-loop h (if (news-header:unread? h) (- n 1) n))))
		   (else (lose))))
	    ((< n 0)
	     (cond ((region-get m 'NEWS-HEADER #f)
		    => (lambda (h) (prev-loop h n)))
		   ((find-previous-line-property m 'NEWS-HEADER #f)
		    => (lambda (h)
			 (prev-loop h (if (news-header:unread? h) (+ n 1) n))))
		   (else (lose))))
	    (else #f)))))

(define-command news-group-previous-unread-header
  "Move up to the previous unread article header.
With prefix argument, moves up several headers."
  "p"
  (lambda (n)
    ((ref-command news-group-next-unread-header) (- n))))

(define-command news-group-next-unread-article
  "Select the next unread article.
With prefix argument, moves down several articles."
  "p"
  (lambda (n)
    (if ((ref-command news-group-next-unread-header) n)
	((ref-command news-select-article)))))

(define-command news-group-previous-unread-article
  "Select the previous unread article.
With prefix argument, moves up several articles."
  "p"
  (lambda (n)
    ((ref-command news-group-next-unread-article) (- n))))

(define-command news-group-next-thread
  "Move to the first unread header of the next unread thread.
With prefix argument, moves down several threads."
  "p"
  (lambda (n)
    (let ((b (selected-buffer))
	  (m (current-point)))
      (define (next-loop t n)
	(if (= n 0)
	    (win t)
	    (let ((next (news-group-buffer:next-thread b t)))
	      (if next
		  (next-loop-1 next n)
		  (partial-win t n)))))

      (define (next-loop-1 t n)
	(next-loop t (if (news-thread:all-articles-deleted? t) n (- n 1))))

      (define (prev-loop t n)
	(if (= n 0)
	    (win t)
	    (let ((next (news-group-buffer:previous-thread b t)))
	      (if next
		  (prev-loop-1 next n)
		  (partial-win t n)))))

      (define (prev-loop-1 t n)
	(prev-loop t (if (news-thread:all-articles-deleted? t) n (+ n 1))))

      (define (win t)
	(news-group-buffer:move-to-header
	 b
	 (news-thread:first-header t news-header:unread?))
	#t)

      (define (partial-win t n*)
	(if (not (= n n*)) (win t))
	(lose))

      (define (lose)
	(editor-failure)
	#f)

      (cond ((> n 0)
	     (cond ((region-get m 'NEWS-HEADER #f)
		    => (lambda (h) (next-loop (news-header:thread h) n)))
		   ((find-next-line-property m 'NEWS-HEADER #f)
		    => (lambda (h) (next-loop-1 (news-header:thread h) n)))
		   (else (lose))))
	    ((< n 0)
	     (cond ((region-get m 'NEWS-HEADER #f)
		    => (lambda (h) (prev-loop (news-header:thread h) n)))
		   ((find-previous-line-property m 'NEWS-HEADER #f)
		    => (lambda (h) (prev-loop-1 (news-header:thread h) n)))
		   (else (lose))))
	    (else #f)))))

(define-command news-group-previous-thread
  "Move to the first unread header of the previous unread thread.
With prefix argument, moves up several threads."
  "p"
  (lambda (n)
    ((ref-command news-group-next-thread) (- n))))

(define-command news-group-next-thread-article
  "Select the first unread article of the next unread thread.
With prefix argument, moves down several threads."
  "p"
  (lambda (n)
    (if ((ref-command news-group-next-thread) n)
	((ref-command news-select-article)))))

(define-command news-group-previous-thread-article
  "Select the first unread article of the previous unread thread.
With prefix argument, moves up several threads."
  "p"
  (lambda (n)
    ((ref-command news-group-next-thread-article) (- n))))

(define-command news-delete-article
  "Mark as read the News article indicated by point.
With prefix argument, marks the next several articles."
  "P"
  (lambda (argument)
    (header-iteration argument
      (lambda (buffer header)
	(mark/unmark-news-header-line buffer header 'SEEN)))))

(define-command news-mark-article
  "Mark for retrieval the News article indicated by point.
With prefix argument, marks the next several articles."
  "P"
  (lambda (argument)
    (header-iteration argument
      (lambda (buffer header)
	(mark/unmark-news-header-line buffer header 'MARKED)))))

(define-command news-unmark-article
  "Unmark the News article indicated by point.
With prefix argument, unmarks the next several articles."
  "P"
  (lambda (argument)
    (header-iteration argument unmark-news-header-line)))

(define-command news-unmark-article-backwards
  "Back up to the previous article and unmark it.
With prefix argument, unmarks the previous several articles."
  "p"
  (lambda (argument)
    (header-iteration (- argument) unmark-news-header-line)))

(define (unmark-news-header-line buffer header)
  (mark/unmark-news-header-line buffer header 'UNSEEN))

(define (header-iteration argument procedure)
  (defer-marking-updates (selected-buffer)
    (lambda ()
      (iterate-on-lines
       (lambda (mark) (region-get mark 'NEWS-HEADER #f))
       "news-article header"
       news-header:real?
       argument
       (lambda (h) h)
       (lambda (buffer header)
	 (if (news-thread:expanded? (news-header:thread header))
	     (news-group-buffer:next-header buffer header news-header:real?)
	     (news-group-buffer:first-header-in-next-thread
	      buffer header news-header:real?)))
       (lambda (buffer header)
	 (if (news-thread:expanded? (news-header:thread header))
	     (news-group-buffer:previous-header buffer header
						news-header:real?)
	     (news-group-buffer:last-header-in-previous-thread
	      buffer header news-header:real?)))
       (lambda (buffer header next n)
	 (procedure buffer header)
	 (news-group-buffer:move-to-header buffer
					   (if (and next (> n 0))
					       next
					       header)))))))

(define (mark/unmark-news-header-line buffer header name)
  (let ((thread (news-header:thread header)))
    (if (news-thread:expanded? thread)
	(with-editor-interrupts-disabled
	  (lambda ()
	    ((name->article-marker name) header buffer)
	    (update-buffer-news-header-status buffer header)))
	(mark/unmark-news-thread-lines buffer thread name))))

(define (name->article-marker name)
  (case name
    ((SEEN) news-header:article-deleted!)
    ((MARKED) news-header:article-marked!)
    ((UNSEEN) news-header:article-not-deleted!)
    ((IGNORED) news-header:article-ignored!)
    (else (error "Unknown marker name:" name))))

(define-command news-read-marked-bodies
  "Download the bodies of the marked messages and save them on the disk.
Subsequent reading of the message bodies can be done offline."
  ()
  (lambda ()
    (let* ((buffer (selected-buffer))
	   (headers
	    (cond ((news-group-buffer? buffer)
		   (news-group:marked-headers
		    (news-group-buffer:group buffer)))
		  ((news-server-buffer? buffer)
		   (append-map news-group:marked-headers
			       (vector->list
				(news-server-buffer:groups buffer))))
		  (else
		   '())))
	   (n-articles (length headers))
	   (n-read 0))
      (do ((headers headers (cdr headers))
	   (n 1 (fix:+ n 1)))
	  ((null? headers))
	(let ((header (car headers)))
	  (if (news-header? header)
	      (begin
		(message
		 (string-append "Reading article "
				(number->string n)
				" of "
				(number->string n-articles)))
		(news-header:read-marked-body header buffer)
		(set! n-read (fix:+ n-read 1)))
	      (let ((group (cadr header))
		    (number (caddr header)))
		(set-news-group:ranges-marked!
		 group
		 (remove-from-ranges! (news-group:ranges-marked group) number))
		(news-group:maybe-defer-update buffer group)))))
      (cond ((news-group-buffer? buffer)
	     (news-group:close-database (news-group-buffer:group buffer)))
	    ((news-server-buffer? buffer)
	     (for-each-vector-element (news-server-buffer:groups buffer)
				      news-group:close-database)))
      (message (number->string n-read) " articles read"))))

(define-command news-delete-thread
  "Mark as read the conversation thread indicated by point.
This marks the article indicated by point and any other articles in
 the same thread as that article.
With prefix argument, marks next several threads."
  "P"
  (lambda (argument)
    (thread-iteration argument
      (lambda (buffer thread)
	(mark/unmark-news-thread-lines buffer thread 'SEEN)))))

(define-command news-mark-thread
  "Mark for retrieval the conversation thread indicated by point.
This marks the article indicated by point and any other unread articles in
 the same thread as that article.
With prefix argument, marks next several threads."
  "P"
  (lambda (argument)
    (thread-iteration argument
      (lambda (buffer thread)
	(mark/unmark-news-thread-lines buffer thread 'MARKED)))))

(define-command news-ignore-thread
  "Ignore the conversation thread indicated by point.
With prefix argument, ignores the next several threads."
  "P"
  (lambda (argument)
    (thread-iteration argument news-group-buffer:ignore-thread)))

(define-command news-unmark-thread
  "Unmark the conversation thread indicated by point.
This unmarks the article indicated by point and any other articles in
 the same thread as that article."
  "P"
  (lambda (argument)
    (thread-iteration argument
      (lambda (buffer thread)
	(mark/unmark-news-thread-lines buffer thread 'UNSEEN)))))

(define (thread-iteration argument procedure)
  (defer-marking-updates (selected-buffer)
    (lambda ()
      (iterate-on-lines (lambda (mark) (region-get mark 'NEWS-HEADER #f))
			"news-article header" #f argument
			news-header:thread
			news-group-buffer:next-thread
			news-group-buffer:previous-thread
	(lambda (buffer thread next n)
	  (procedure buffer thread)
	  (news-group-buffer:move-to-thread buffer
					    (if (and next (> n 0))
						next
						thread)))))))

(define (news-group-buffer:move-to-thread buffer thread)
  (news-group-buffer:move-to-header
   buffer
   (news-thread:first-header thread news-header:real?)))

(define (mark/unmark-news-thread-lines buffer thread name)
  (with-editor-interrupts-disabled
    (lambda ()
      (news-thread:for-each-real-header thread
	(let ((marker
	       (let ((marker (name->article-marker name)))
		 (if (eq? name 'IGNORED)
		     marker
		     (lambda (header buffer)
		       (news-header:article-not-ignored! header buffer)
		       (marker header buffer))))))
	  (lambda (header)
	    (marker header buffer)
	    (update-buffer-news-header-status buffer header))))
      (update-buffer-news-thread-status buffer thread))))

(define (news-group-buffer:ignore-thread buffer thread)
  (if (or (ref-variable news-group-ignore-hidden-subjects buffer)
	  (news-thread:expanded? thread))
      (mark/unmark-news-thread-lines buffer thread 'IGNORED)
      (let ((header (news-thread:first-header thread news-header:real?)))
	(if header
	    (with-editor-interrupts-disabled
	      (lambda ()
		(news-thread:for-each-real-header thread
		  (let ((subject
			 (canonicalize-subject (news-header:subject header))))
		    (lambda (header)
		      (if (compare-subjects
			   subject
			   (canonicalize-subject (news-header:subject header)))
			  (news-header:article-ignored! header buffer)))))
		(update-buffer-news-thread-status buffer thread)))))))

(define-command news-select-article
  "Select a buffer in the other window containing the News article at point.
With prefix arg, select the buffer in the same window."
  "P"
  (lambda (same-window?)
    (let ((proc (if same-window?
                    select-buffer
                    select-buffer-other-window)))
      (proc
       (let ((buffer (selected-buffer)))
         (cond ((news-article-buffer? buffer)
                buffer)
               ((news-group-buffer? buffer)
                (call-with-values
                    (lambda ()
                      (get-article-buffer buffer (current-news-header) #t))
                  (lambda (buffer new?)
                    new?
                    buffer)))
               (else
                (editor-error "No article selected."))))))))

(define-command news-toggle-thread
  "Expand or collapse the current thread."
  ()
  (lambda ()
    (let ((buffer (selected-buffer))
	  (thread (news-header:thread (current-news-header))))
      (if (news-thread:expanded? thread)
	  (news-group-buffer:collapse-thread buffer thread)
	  (news-group-buffer:expand-thread buffer thread))
      (news-group-buffer:move-to-thread buffer thread))))

(define-command news-collapse-threads
  "Collapse all of the threads in this News group."
  ()
  (lambda ()
    (let ((buffer (selected-buffer))
	  (header (region-get (current-point) 'NEWS-HEADER #f)))
      (for-each-vector-element (news-group-buffer:threads buffer)
	(lambda (thread)
	  (news-group-buffer:collapse-thread buffer thread)))
      (if header
	  (if (news-group-buffer:header-mark buffer header)
	      (news-group-buffer:move-to-header buffer header)
	      (news-group-buffer:move-to-thread
	       buffer
	       (news-header:thread header)))))))

(define-command news-expand-threads
  "Expand all of the threads in this News group."
  ()
  (lambda ()
    (let ((buffer (selected-buffer))
	  (header (region-get (current-point) 'NEWS-HEADER #f)))
      (for-each-vector-element (news-group-buffer:threads buffer)
	(lambda (thread)
	  (news-group-buffer:expand-thread buffer thread)))
      (if header
	  (news-group-buffer:move-to-header buffer header)))))

(define-command news-revert-group
  "Refresh the article list from the News server.
Any new unread articles are added to the list of available articles.
With \\[universal-argument], all articles in the group are shown,
 including those that were previously marked as read.
With positive argument N, show only N newest unread articles.
With negative argument -N, show only N oldest unread articles."
  "P"
  (lambda (argument)
    (let ((buffer (selected-buffer)))
      (with-buffer-open-1 buffer
	(lambda ()
	  (region-delete! (buffer-region buffer))
	  (initialize-news-group-buffer buffer argument)
	  (set-buffer-point!
	   buffer
	   (or (find-first-property-line buffer 'NEWS-HEADER news-header:real?)
	       (buffer-end buffer))))))))

(define-command news-expunge-group
  "Remove all threads marked as seen from the article list.
Any thread whose articles are all marked is removed;
 if a thread contains any unmarked articles, it is retained.
This command has no effect if the variable
 news-group-show-seen-headers is true."
  ()
  (lambda ()
    (let ((buffer (selected-buffer))
	  (on-header? (region-get (current-point) 'NEWS-HEADER #f)))
      (if (not (ref-variable news-group-show-seen-headers buffer))
	  (let ((threads (vector->list (news-group-buffer:threads buffer))))
	    (with-buffer-open-1 buffer
	      (lambda ()
		(let ((regions '()))
		  (for-each
		   (lambda (thread)
		     (if (news-thread:all-articles-deleted? thread)
			 (let ((region
				(news-thread-lines-region buffer thread)))
			   (if region
			       (set! regions
				     (cons (make-region
					    (mark-right-inserting-copy
					     (region-start region))
					    (mark-left-inserting-copy
					     (region-end region)))
					   regions)))
			   (news-thread:for-each-header thread
			     (lambda (header)
			       (news-group:discard-cached-header! header)
			       (set-news-header:index! header #f))))))
		   threads)
		  (for-each
		   (lambda (region)
		     (delete-string (region-start region) (region-end region))
		     (mark-temporary! (region-start region))
		     (mark-temporary! (region-end region)))
		   regions))
		(update-subsequent-news-header-lines (buffer-start buffer))
		(buffer-put! buffer 'NEWS-THREADS
			     (list->vector
			      (remove news-thread:all-articles-deleted?
				      threads)))
		(if (and on-header?
			 (not (region-get (current-point) 'NEWS-HEADER #f)))
		    (let ((ls
			   (find-previous-property-line (current-point)
							'NEWS-HEADER
							#f)))
		      (if ls
			  (set-current-point! ls)))))))))))

(define-command news-catch-up-group
  "Mark all of the articles as read, and return to the News server buffer.
This kills the current buffer."
  ()
  (lambda ()
    (if (prompt-for-confirmation? "Delete all articles not marked as read")
	(begin
	  (let ((buffer (selected-buffer)))
	    (for-each-vector-element (news-group-buffer:threads buffer)
	      (lambda (thread)
		(news-thread:for-each-real-header thread
		  (lambda (header)
		    (news-header:article-deleted! header buffer))))))
	  ((ref-command news-kill-current-buffer))))))

(define-command news-group-quit
  "Kill the current buffer, going back to the groups list."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (let ((alternate
	     (let ((server-buffer (news-server-buffer buffer #f)))
	       (and server-buffer
		    (or (let ((key (buffer-get buffer 'SELECTED-FROM #f)))
			  (and key
			       (not (eq? key 'SERVER))
			       (buffer-tree:child server-buffer key #f)))
			server-buffer)))))
	(kill-buffer buffer)
	(if alternate (select-buffer alternate))))))

(define-command news-group-show-subject
  "Show the subject of the current article.
Without argument, the subject is shown in the echo area if it will fit there.
Otherwise (or with argument) a buffer containing the subject is popped up.
This is useful when the subject has been truncated by the one-line display."
  "P"
  (lambda (argument)
    (let ((subject
	   (canonicalize-subject (news-header:subject (current-news-header)))))
      (if (and (not argument)
	       (< (string-columns subject 0 8
				  (ref-variable char-image-strings))
		  (window-x-size (typein-window))))
	  (message subject)
	  (pop-up-temporary-buffer " news-header subject"
				   '(READ-ONLY SHRINK-WINDOW FLUSH-ON-SPACE)
	    (lambda (buffer window)
	      window
	      (insert-string subject (buffer-point buffer))))))))

(define-command news-group-show-header
  "Show the header of the current article.
With argument, the complete header is shown.
Otherwise, the standard pruned header is shown."
  "P"
  (lambda (argument)
    (let ((header (current-news-header)))
      (if argument (news-header:guarantee-full-text! header))
      (pop-up-temporary-buffer " news-header subject"
			       '(READ-ONLY SHRINK-WINDOW FLUSH-ON-SPACE)
	(lambda (buffer window)
	  window
	  (insert-news-header header buffer (not argument))
	  ;; delete two blank lines at end
	  (let ((end (buffer-end buffer)))
	    (delete-string (mark- end 2) end)))))))

;;;; News-Article Buffer

(define (find-news-article-buffer group-buffer header)
  (buffer-tree:child group-buffer header #f))

(define (make-news-article-buffer group-buffer header)
  (news-header:guarantee-full-text! header)
  (let ((buffer (new-buffer (news-article-buffer-name header))))
    (set-buffer-major-mode! buffer (ref-mode-object news-article))
    (disable-group-undo! (buffer-group group-buffer))
    (if (let ((msg "Reading article... "))
	  (message msg)
	  (let ((value
		 (call-with-output-mark (buffer-end buffer)
		   (lambda (port)
		     (news-header:read-body header port)))))
	    (message msg "done")
	    value))
	(begin
	  (insert-news-header header buffer #t)
	  (enable-group-undo! (buffer-group group-buffer))
	  (buffer-put! buffer 'NEWS-HEADER header)
	  ;; The next two statements must be executed in this order,
	  ;; because NEWS-ARTICLE-BUFFER:KILL assumes that the
	  ;; kill-buffer hook registered by BUFFER-TREE:ATTACH-CHILD!
	  ;; has already been run.
	  (buffer-tree:attach-child! group-buffer header buffer)
	  (add-kill-buffer-hook buffer news-article-buffer:kill)
	  (set-buffer-point! buffer (buffer-start buffer))
	  (buffer-not-modified! buffer)
	  (set-buffer-read-only! buffer)
	  (news-header:article-deleted! header group-buffer)
	  (update-buffer-news-header-status group-buffer header)
	  (news-group:close-database (news-group-buffer:group group-buffer))
	  buffer)
	(begin
	  (kill-buffer buffer)
	  (news-header:article-deleted! header group-buffer)
	  (update-buffer-news-header-status group-buffer header)
	  (news-group:close-database (news-group-buffer:group group-buffer))
	  #f))))

(define (news-article-buffer-name header)
  (string-append (number->string (news-header:number header))
		 ":"
		 (news-group-buffer-name (news-header:group header))))

(define (news-article-buffer? buffer)
  (news-header? (buffer-get buffer 'NEWS-HEADER #f)))

(define (news-article-buffer:header buffer)
  (let ((header (buffer-get buffer 'NEWS-HEADER #f)))
    (if (not (news-header? header))
	(error "Buffer isn't a News article buffer:" (buffer-name buffer)))
    header))

(define (news-article-buffer:kill buffer)
  (let ((group-buffer (news-group-buffer buffer #f)))
    (if group-buffer
	(ignore-errors
	 (lambda ()
	   (update-buffer-news-header-status
	    group-buffer
	    (news-article-buffer:header buffer))
	   (news-group:close-database
	    (news-group-buffer:group group-buffer)))))))

(define (insert-news-header header buffer truncate?)
  (let ((hend (mark-left-inserting-copy (buffer-start buffer)))
        (text (news-header:text header)))
    (cond ((and truncate?
                (ref-variable news-kept-headers))
           => (lambda (regexps)
                (insert-filtered-news-header text regexps hend buffer)
                (insert-newline hend)))
          (else
           (if (and (not (string-null? text))
                    (char=? #\newline (string-ref text 0)))
               (insert-substring text 1 (string-length text) hend)
               (insert-string text hend))
           (insert-newline hend)
           (if truncate? (delete-ignored-headers (buffer-start buffer) hend))))
    (mark-temporary! hend)
    (buffer-put! buffer 'NEWS-ARTICLE-HEADER-TRUNCATED? truncate?)))

(define (insert-filtered-news-header text regexps mark buffer)
  buffer
  (for-each (lambda (regexp)
              (cond ((re-string-search-forward (string-append "^" regexp)
                                               text
                                               #t)
                     => (lambda (match)
                          (let ((start-index (re-match-start-index 0 match)))
                            (insert-substring text start-index
                                              (find-header-end text
                                                               start-index)
                                              mark))
                          (insert-newline mark)))))
            regexps))

(define (find-header-end text start-index)
  (let* ((limit (string-length text))
         (scan-line (lambda (start)
                      (cond ((substring-find-next-char text start limit
                                                       #\newline)
                             => fix:1+)
                            (else #f)))))
    (let loop ((index (scan-line start-index)))
      (cond ((or (not index) (fix:= index limit))
             limit)
            ((let ((char (string-ref text index)))
               (or (char=? char #\space)
                   (char=? char #\tab)))
             (loop (scan-line index)))
            (else
             ;; Lose the trailing newline.
             (fix:-1+ index))))))

(define (delete-ignored-headers hstart hend)
  (let ((regexp (ref-variable rmail-ignored-headers hstart)))
    (if regexp
	(let ((point (mark-right-inserting-copy hstart))
	      (p1 (re-compile-pattern regexp #t))
	      (p2 (re-compile-pattern "\n[^ \t]" #f)))
	  (do ()
	      ((not (re-search-forward p1 point hend)))
	    (move-mark-to! point (line-start (re-match-start 0) 0))
	    (delete-string
	     point
	     (mark-1+ (re-search-forward p2 point hend))))
	  (mark-temporary! point)))))

(define (delete-news-header buffer)
  (let ((start (buffer-start buffer)))
    (delete-string start (mark1+ (mail-header-end start)))))

(define (get-article-buffer group-buffer header error?)
  (if (not (news-header:real? header))
      (editor-error "Can't select a placeholder article."))
  (let ((buffer (find-news-article-buffer group-buffer header)))
    (if buffer
	(values buffer #f)
	(let ((buffer (make-news-article-buffer group-buffer header)))
	  (if (and error? (not buffer))
	      (editor-error "Article no longer available from server."))
	  (values buffer #t)))))

;;;; News-Article Mode

(define-major-mode news-article news-common "News Article"
  "Major mode for reading a News article.

When a News-article buffer is created, the hooks news-article-mode-hook
and news-common-mode-hook are invoked.

This mode's commands include:

\\[news-next-article]	read the next article
\\[news-previous-article]	read the previous article
\\[news-next-unread-article]	read the next unread article
\\[news-previous-unread-article]	read the previous unread article
\\[news-next-article-in-thread]	read the next article in this thread
\\[news-previous-article-in-thread]	read the previous article in this thiread
\\[news-next-unread-article-in-thread]	read the next unread article in this thread
\\[news-previous-unread-article-in-thread]	read the previous unread article in this thread
\\[news-next-thread-article]	read the first article of the next thread
\\[news-previous-thread-article]	read the first article of the previous thread

\\[news-toggle-article-header]	show/don't show all of this article's header lines
\\[news-toggle-article-context]	show/don't show window into the News group buffer

\\[news-compose-followup-article]	post a reply to this article
\\[news-reply-to-article]	reply by email to this article
\\[news-compose-article]	post a new article to this group
\\[news-forward-article]	forward this article by email
\\[mail]	send a new email message

\\[news-output-article]	output this article to a mail file
\\[news-output-article-to-rmail-file]	output this article to an RMAIL file

\\[news-save-server-data]	write info about the subscribed groups to the init file"
  (lambda (buffer)
    (event-distributor/invoke! (ref-variable news-article-mode-hook buffer)
			       buffer)))

(define-variable news-article-mode-hook
  "An event distributor that is invoked when entering News-article mode."
  (make-event-distributor))

(define-key 'news-article #\space '(news-article . #\c-v))
(define-key 'news-article #\rubout '(news-article . #\m-v))
(define-key 'news-article #\c 'news-toggle-article-context)
(define-key 'news-article #\d 'news-next-article)
(define-key 'news-article #\D 'news-next-article-in-thread)
(define-key 'news-article #\f 'news-forward-article)
(define-key 'news-article #\i 'news-ignore-article-thread)
(define-key 'news-article #\n 'news-next-unread-article)
(define-key 'news-article #\N 'news-next-unread-article-in-thread)
(define-key 'news-article #\M-n 'news-next-thread-article)
(define-key 'news-article #\o 'news-output-article-to-rmail-file)
(define-key 'news-article #\c-o 'news-output-article)
(define-key 'news-article #\p 'news-previous-unread-article)
(define-key 'news-article #\P 'news-previous-unread-article-in-thread)
(define-key 'news-article #\M-p 'news-previous-thread-article)
(define-key 'news-article #\r 'news-reply-to-article)
(define-key 'news-article #\R 'news-compose-followup-article)
(define-key 'news-article #\t 'news-toggle-article-header)
(define-key 'news-article #\u 'news-previous-article)
(define-key 'news-article #\U 'news-previous-article-in-thread)

(define-command news-next-article
  "Select a buffer containing the next article in the News group.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       (news-group-buffer:next-header buffer header news-header:real?)))))

(define-command news-previous-article
  "Select a buffer containing the previous article in the News group.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       (news-group-buffer:previous-header buffer header news-header:real?)))))

(define-command news-next-unread-article
  "Select a buffer containing the next unread article in the News group.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       (news-group-buffer:next-header buffer header news-header:unread?)))))

(define-command news-previous-unread-article
  "Select a buffer containing the previous unread article in the News group.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       (news-group-buffer:previous-header buffer header
					  news-header:unread?)))))

(define-command news-next-article-in-thread
  "Select a buffer containing the next article in this thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       buffer
       (news-thread:next-header header news-header:real?)))))

(define-command news-previous-article-in-thread
  "Select a buffer containing the previous article in this thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       buffer
       (news-thread:previous-header header news-header:real?)))))

(define-command news-next-unread-article-in-thread
  "Select a buffer containing the next unread article in this thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       buffer
       (news-thread:next-header header news-header:unread?)))))

(define-command news-previous-unread-article-in-thread
  "Select a buffer containing the previous unread article in this thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-header-motion-command
     (lambda (buffer header)
       buffer
       (news-thread:previous-header header news-header:unread?)))))

(define-command news-next-thread-article
  "Select a buffer containing the first unread article in the next thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-thread-motion-command news-group-buffer:next-thread)))

(define-command news-previous-thread-article
  "Select a buffer containing the first unread article in the previous thread.
If there is no such article, return to the News-group buffer.
Kill the current buffer in either case."
  ()
  (lambda ()
    (news-article-thread-motion-command news-group-buffer:previous-thread)))

(define-command news-ignore-article-thread
  "Ignore the thread that this article is in, and skip to the next thread."
  ()
  (lambda ()
    (news-article-thread-action-command news-group-buffer:next-thread
					news-group-buffer:ignore-thread)))

(define (news-article-header-motion-command select-next)
  (news-article-header-action-command select-next #f))

(define (news-article-thread-motion-command select-next)
  (news-article-thread-action-command select-next #f))

(define (news-article-thread-action-command select-next action)
  (news-article-header-action-command
   (lambda (buffer header)
     (let ((thread (select-next buffer (news-header:thread header))))
       (and thread
	    (news-thread:first-header thread news-header:unread?))))
   (and action
	(lambda (buffer header)
	  (action buffer (news-header:thread header))))))

(define (news-article-header-action-command select-next action)
  (let ((buffer (selected-buffer)))
    (let ((group-buffer (buffer-tree:parent buffer #t))
	  (header (news-article-buffer:header buffer)))
      (if action (action group-buffer header))
      (let loop ((header header))
	(let ((header (select-next group-buffer header)))
	  (if (not header)
	      (begin
		(message "No more articles.")
		(select-buffer group-buffer)
		(kill-buffer buffer)
		#f)
	      (let ((article-buffer
		     (or (find-news-article-buffer group-buffer header)
			 (make-news-article-buffer group-buffer header))))
		(if article-buffer
		    (begin
		      (news-group-buffer:move-to-header group-buffer header)
		      (select-buffer article-buffer)
		      (kill-buffer buffer)
		      #t)
		    (loop header)))))))))

(define-command news-toggle-article-header
  "Show original article header if pruned header currently shown, or vice versa.
Normally, the header lines specified in the variable rmail-ignored-headers
 are not shown; this command shows them, or hides them if they are shown."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (with-buffer-open-1 buffer
	(lambda ()
	  (let ((header (news-article-buffer:header buffer)))
	    (delete-news-header buffer)
	    (insert-news-header
	     header
	     buffer
	     (not (buffer-get buffer 'NEWS-ARTICLE-HEADER-TRUNCATED? #f))))))
      (set-current-point! (buffer-start buffer)))))

(define-command news-toggle-article-context
  "Show context window into News group buffer, or hide it if currently shown.
This is a small window showing a few lines around the subject line of the
 current article.  The number of lines is specified by the variable
 news-article-context-lines, but a prefix argument overrides this."
  "P"
  (lambda (argument)
    (let ((article-window (current-window))
	  (context-lines
	   (if argument
	       (min 1 (command-argument-value argument))
	       (ref-variable news-article-context-lines))))
      (let ((article-buffer (window-buffer article-window)))
	(let ((group-buffer (buffer-tree:parent article-buffer #t)))
	  (let ((context-window
		 (news-group-buffer:context-window group-buffer #f)))
	    (let ((set-height
		   (lambda ()
		     (let ((delta
			    (- context-lines (window-y-size context-window))))
		       (if (not (= delta 0))
			   (window-grow-vertically! context-window delta)))
		     (center-news-article-context context-window))))
	      (with-editor-interrupts-disabled
		(lambda ()
		  (cond ((not context-window)
			 (show-news-article-context article-window
						    context-lines))
			((not (eq? group-buffer
				   (window-buffer context-window)))
			 (select-buffer group-buffer context-window)
			 (set-height))
			(argument
			 (set-height))
			(else
			 (window-delete! context-window article-window)
			 (buffer-remove! group-buffer
					 'CONTEXT-WINDOW))))))))))))

(define-command news-output-article-to-rmail-file
  "Append the current article to an Rmail file named FILE-NAME.
If the file does not exist, ask if it should be created.
If file is being visited, the article is appended to the
 buffer visiting that file.
With prefix argument, appends next several articles."
  (lambda ()
    (list (prompt-for-rmail-output-filename
	   "Output article to Rmail file"
	   (ref-variable rmail-last-rmail-file))
	  (command-argument)))
  (lambda (pathname argument)
    (set-variable! rmail-last-rmail-file (->namestring pathname))
    (call-on-news-article-buffers argument
      (lambda (article-buffer)
	(with-article-output-buffer article-buffer
	  (lambda (buffer)
	    (rfc822-region->babyl (buffer-region buffer))
	    (rmail-output-to-rmail-file (buffer-region buffer) pathname)))))))

(define-command news-output-article
  "Append this article to Unix mail file named FILE-NAME.
With prefix argument, appends next several articles."
  (lambda ()
    (list (prompt-for-rmail-output-filename "Output article to Unix mail file"
					    (ref-variable rmail-last-file))
	  (command-argument)))
  (lambda (pathname argument)
    (set-variable! rmail-last-file (->namestring pathname))
    (call-on-news-article-buffers argument
      (lambda (article-buffer)
	(with-article-output-buffer article-buffer
	  (lambda (buffer)
	    (rmail-output-to-unix-mail-file (buffer-region buffer)
					    pathname)))))))

(define (call-on-news-article-buffers argument procedure)
  (let ((buffer (selected-buffer)))
    (cond ((news-article-buffer? buffer)
	   (let loop
	       ((buffer buffer)
		(n (command-argument-numeric-value argument)))
	     (if (> n 0)
		 (begin
		   (procedure buffer)
		   (if ((ref-command news-next-article))
		       (loop (selected-buffer) (- n 1)))))))
	  ((news-group-buffer? buffer)
	   (header-iteration argument
	     (lambda (group-buffer header)
	       (call-with-values
		   (lambda () (get-article-buffer group-buffer header #f))
		 (lambda (article-buffer new?)
		   (if article-buffer
		       (begin
			 (procedure article-buffer)
			 (if new? (kill-buffer article-buffer)))))))))
	  (else
	   (editor-error "No article selected.")))))

(define (with-article-output-buffer article-buffer procedure)
  (with-editor-interrupts-disabled
    (lambda ()
      (let ((buffer (temporary-buffer " news conversion")))
	(insert-region (buffer-absolute-start article-buffer)
		       (buffer-absolute-end article-buffer)
		       (buffer-start buffer))
	(delete-news-header buffer)
	(insert-news-header (news-article-buffer:header article-buffer)
			    buffer
			    #f)
	(procedure buffer)
	(kill-buffer buffer)))))

(define-command news-reply-to-article
  "Mail a reply to the author of the current News article.
While composing the reply, use \\[mail-yank-original] to yank the
 original message into it."
  ()
  (lambda ()
    (guarantee-rmail-variables-initialized)
    (let ((article-buffer (selected-buffer)))
      (if (and (not (news-article-buffer:followup-to-poster? article-buffer))
	       (prompt-for-confirmation? "Post a follow-up article"))
	  (make-news-reply-buffer
	   (merge-header-alists
	    (news-article-buffer:rfc822-reply-headers article-buffer)
	    (news-article-buffer:followup-fields article-buffer))
	   article-buffer
	   select-buffer-other-window)
	  (make-mail-buffer
	   (news-article-buffer:rfc822-reply-headers article-buffer)
	   article-buffer
	   select-buffer-other-window)))))

(define (merge-header-alists x y)
  (append (remove (lambda (entry)
		    (find (lambda (entry*)
			    (string-ci=? (car entry) (car entry*)))
			  y))
		  x)
	  y))

(define (news-article-buffer:rfc822-reply-headers article-buffer)
  (call-with-temporary-buffer " news conversion"
    (lambda (buffer)
      (insert-news-header (news-article-buffer:header article-buffer)
			  buffer #f)
      (rfc822-region-reply-headers (buffer-region buffer) #t))))

(define-command news-forward-article
  "Forward the current News article to another user by email."
  ()
  (lambda ()
    (let ((article-buffer (selected-buffer)))
      (make-mail-buffer
       (let ((header (news-article-buffer:header article-buffer)))
	 `(("To" "")
	   ("Subject"
	    ,(string-append
	      "["
	      (let ((from
		     (rfc822:canonicalize-address-string
		      (news-header:from header)))
		    (subject (news-header:subject header)))
		(if (string-null? from)
		    subject
		    (string-append from ": " subject)))
	      "]"))))
       #f
       (if (window-has-no-neighbors? (current-window))
	   select-buffer
	   select-buffer-other-window))
      (insert-region (buffer-start article-buffer)
		     (buffer-end article-buffer)
		     (buffer-end (selected-buffer))))))

;;;; Posting

(define-command news-compose-article
  "Begin editing a News article to be posted.
Argument means resume editing previous article (don't erase).
Once editing the article, type \\[describe-mode] to get a list of commands."
  "P"
  (lambda (no-erase?)
    (compose-news no-erase? select-buffer)))

(define-command news-compose-article-other-window
  "Like \\[news-compose-article], but display article buffer in other window."
  "P"
  (lambda (no-erase?)
    (compose-news no-erase? select-buffer-other-window)))

(define (compose-news no-erase? selector)
  (let ((server
	 (let ((buffer (current-news-server-buffer #f)))
	   (and buffer
		(news-server-buffer:server buffer))))
	(group
	 (or (region-get (current-point) 'NEWS-GROUP #f)
	     (buffer-get (selected-buffer) 'NEWS-GROUP #f)
	     (let ((header (buffer-get (selected-buffer) 'NEWS-header #f)))
	       (and header
		    (news-header:group header))))))
    (let ((buffer
	   (make-mail-buffer `(("Newsgroups"
				,(if group (news-group:name group) ""))
			       ("Subject" ""))
			     #f
			     selector
			     (if no-erase?
				 'KEEP-PREVIOUS-MAIL
				 'QUERY-DISCARD-PREVIOUS-MAIL)
			     "*news*"
			     (ref-mode-object compose-news))))
      (if buffer
	  (begin
	    (if server (buffer-put! buffer 'NEWS-SERVER server))
	    (if (not group)
		(set-buffer-point! buffer
				   (mail-position-on-field buffer
							   "Newsgroups"))))))))

(define-command news-compose-followup-article
  "Begin editing a follow-up to the current News article.
While composing the follow-up, use \\[mail-yank-original] to yank the
 original message into it."
  ()
  (lambda ()
    (guarantee-rmail-variables-initialized)
    (let ((article-buffer (selected-buffer)))
      (if (news-article-buffer:followup-to-poster? article-buffer)
	  (make-mail-buffer
	   (news-article-buffer:rfc822-reply-headers article-buffer)
	   article-buffer
	   select-buffer-other-window)
	  (make-news-reply-buffer
	   (news-article-buffer:followup-fields article-buffer)
	   article-buffer
	   select-buffer-other-window)))))

(define (news-article-buffer:followup-to-poster? buffer)
  (string-ci=? (news-header:field-value (news-article-buffer:header buffer)
					"followup-to")
	       "poster"))

(define (make-news-reply-buffer header-fields article-buffer select-buffer)
  (let ((buffer
	 (make-mail-buffer header-fields
			   article-buffer
			   select-buffer
			   'QUERY-DISCARD-PREVIOUS-MAIL
			   "*news*"
			   (ref-mode-object compose-news))))
    (if (and buffer article-buffer)
	(buffer-put! buffer 'NEWS-SERVER
		     (nntp-connection:server
		      (news-group:connection
		       (news-header:group
			(news-article-buffer:header article-buffer))))))))

(define (news-article-buffer:followup-fields buffer)
  (let ((header (news-article-buffer:header buffer)))
    `(("Newsgroups"
       ,(let ((followup-to (news-header:field-value header "followup-to")))
	  (if (string-null? followup-to)
	      (news-header:field-value header "newsgroups")
	      followup-to)))
      ("Subject" ,(let ((subject (news-header:subject header)))
		    (if (and (not (string-null? subject))
			     (not (string-prefix-ci? "re:" subject)))
			(string-append "Re: " subject)
			subject)))
      ("References" ,(let ((refs (news-header:references header))
			   (id (news-header:message-id header)))
		       (if (string-null? refs)
			   id
			   (string-append refs " " id)))
		    #T)
      ("In-reply-to"
       ,(make-in-reply-to-field (news-header:from header)
				(news-header:field-value header "date")
				(news-header:message-id header)))
      ("Distribution"
       ,(let ((distribution (news-header:field-value header "distribution")))
	  (and (not (string-null? distribution))
	       distribution))))))

(define-major-mode compose-news mail "News"
  "Major mode for editing news to be posted on USENET.

Like Text mode but with these additional commands:

C-c C-s  mail-send (post the message)           C-c C-c  mail-send-and-exit
C-c C-f	 move to a header field (and create it if there isn't):
	 C-c C-f C-n  move to Newsgroups:	C-c C-f C-s  move to Subject:
	 C-c C-f C-f  move to Followup-To:      C-c C-f C-k  move to Keywords:
	 C-c C-f C-d  move to Distribution:	C-c C-f C-a  move to Summary:
C-c C-w  mail-signature (insert ~/.signature at end).
C-c C-y  mail-yank-original (insert current message, in News reader).
C-c C-q  mail-fill-yanked-message (fill what was yanked)."
  (lambda (buffer)
    (local-set-variable! send-mail-procedure
			 (lambda () (news-post-it))
			 buffer)
    (event-distributor/invoke! (ref-variable compose-news-mode-hook buffer)
			       buffer)))

(define-variable compose-news-mode-hook
  "An event distributor that is invoked when entering Compose News mode."
  (make-event-distributor))

(define-key 'compose-news '(#\c-c #\c-f #\c-a) 'news-move-to-summary)
(define-key 'compose-news '(#\c-c #\c-f #\c-d) 'news-move-to-distribution)
(define-key 'compose-news '(#\c-c #\c-f #\c-f) 'news-move-to-followup-to)
(define-key 'compose-news '(#\c-c #\c-f #\c-k) 'news-move-to-keywords)
(define-key 'compose-news '(#\c-c #\c-f #\c-n) 'news-move-to-newsgroups)

(define ((field-mover field))
  (set-current-point! (mail-position-on-field (selected-buffer) field)))

(define-command news-move-to-newsgroups
  "Move point to end of Newsgroups: field."
  ()
  (field-mover "Newsgroups"))

(define-command news-move-to-followup-to
  "Move point to end of Followup-to: field."
  ()
  (field-mover "Followup-to"))

(define-command news-move-to-distribution
  "Move point to end of Distribution: field."
  ()
  (field-mover "Distribution"))

(define-command news-move-to-keywords
  "Move point to end of Keywords: field."
  ()
  (field-mover "Keywords"))

(define-command news-move-to-summary
  "Move point to end of Summary: field."
  ()
  (field-mover "Summary"))

(define (news-post-it)
  (let ((article-buffer (selected-buffer)))
    (prepare-mail-buffer-for-sending article-buffer
      (lambda (h-start h-end b-start b-end)
	(news-post-process-headers h-start h-end b-start b-end article-buffer)
	(let ((m (mail-field-start h-start h-end "X-Mailer")))
	  (if m
	      (let ((ls (line-start m 0)))
		(delete-string ls (mark-1+ (char-search-forward #\: ls m)))
		(insert-string "X-Newsreader" ls))))
	(finish-preparing-mail-buffer h-start h-end b-start b-end
				      article-buffer
	  (lambda (send-mail message-pathname)
	    (if (or (mail-field-start h-start h-end "To")
		    (mail-field-start h-start h-end "CC")
		    (mail-field-start h-start h-end "BCC"))
		(send-mail))
	    (post-news-buffer message-pathname article-buffer)))))))

(define (post-news-buffer message-pathname lookup-buffer)
  (let ((do-it
	 (lambda (connection)
	   (let ((msg "Posting..."))
	     (message msg)
	     (let ((error
		    (call-with-input-file message-pathname
		      (lambda (port)
			(nntp-connection:post-article connection port)))))
	       (if error
		   (string-append msg "failed: " error)
		   (begin
		     (message msg "done")
		     #f))))))
	(finish
	 (lambda (result)
	   (if result
	       (editor-error result)))))
    (let ((server
	   (or (buffer-get lookup-buffer 'NEWS-SERVER #f)
	       (get-news-server-name #f))))
      (let ((server-buffer (find-news-server-buffer server)))
	(if server-buffer
	    (finish (do-it (news-server-buffer:connection server-buffer)))
	    (let ((connection (make-nntp-connection-1 server lookup-buffer)))
	      (let ((result (do-it connection)))
		(nntp-connection:close connection)
		(finish result))))))))

(define (news-post-process-headers h-start h-end b-start b-end lookup-context)
  (let ((h-start (mark-left-inserting-copy h-start)))
    (if (not (mail-field-end h-start h-end "From"))
	(insert-string (mail-from-string #f)
		       (mail-insert-field h-start "From")))
    (if (not (mail-field-end h-start h-end "Date"))
	(insert-string (universal-time->string (get-universal-time))
		       (mail-insert-field h-start "Date")))
    (if (not (mail-field-end h-start h-end "Subject"))
	(mail-insert-field h-start "Subject"))
    (if (not (mail-field-end h-start h-end "Lines"))
	(insert-string (number->string (count-lines b-start b-end))
		       (mail-insert-field h-start "Lines")))
    (let ((region (mail-field-region h-start h-end "Newsgroups")))
      (if region
	  (news-post-canonicalize-newsgroups region)
	  (mail-insert-field h-start "Newsgroups")))
    (if (not (mail-field-end h-start h-end "Message-id"))
	(insert-string
	 (news-post-default-message-id (mail-field-region h-start h-end
							  "Subject")
				       lookup-context)
	 (mail-insert-field h-end "Message-id")))
    (if (not (mail-field-end h-start h-end "Path"))
	(insert-string (news-post-default-path)
		       (mail-insert-field h-end "Path")))
    (mark-temporary! h-start)))

(define (news-post-canonicalize-newsgroups region)
  (let ((start (mark-right-inserting-copy (region-start region)))
	(end (mark-left-inserting-copy (region-end region))))
    (let ((replace-regexp
	   (lambda (from to)
	     (let loop ((start start))
	       (let ((mark (re-search-forward from start end #f)))
		 (if mark
		     (loop (replace-match to))))))))
      (replace-regexp "\n[ \t]+" " ")
      (replace-regexp "[ \t]*,[ \t]*" ",")
      (replace-regexp "[ \t]+" ","))
    (mark-temporary! end)
    (mark-temporary! start)))

(define (news-post-default-path)
  (string-append (get-news-server-name #f) "!" (current-user-name)))

(define (news-post-default-message-id subject-region lookup-context)
  ;; From "News Article Format and Transmission, 2 June 1994, section
  ;; 6.5: The followup agent MUST not delete any message ID whose
  ;; local part ends with "_-_" (underscore (ASCII 95), hyphen (ASCII
  ;; 45), underscore); followup agents are urged to use this form to
  ;; mark subject changes, and to avoid using it otherwise.
  (string-append "<"
		 (current-user-name)
		 "."
		 (number->string (get-universal-time))
		 (if (compare-subjects
		      (canonicalize-subject
		       (let ((reply-buffer
			      (ref-variable mail-reply-buffer lookup-context)))
			 (if reply-buffer
			     (news-header:subject
			      (news-article-buffer:header reply-buffer))
			     "")))
		      (canonicalize-subject
		       (if subject-region (region->string subject-region) "")))
		     ""
		     "_-_")
		 "@"
		 (os/hostname)
		 ">"))

;;;; Init Files

(define (read-init-file pathname description get-valid-entry?)
  (if (file-exists? pathname)
      (bind-condition-handler (list condition-type:error)
	  (lambda (condition)
	    condition
	    (editor-error description
			  " in "
			  (->namestring pathname)
			  " is damaged."))
	(lambda ()
	  (let ((entries (fasload pathname)))
	    (if (not (list? entries))
		(error:datum-out-of-range entries))
	    (let ((valid-entry? (get-valid-entry? (car entries))))
	      (if (not valid-entry?)
		  (error:datum-out-of-range (car entries)))
	      (for-each (lambda (entry)
			  (if (not (valid-entry? entry))
			      (error:datum-out-of-range entry)))
			(cdr entries)))
	    (cdr entries))))
      '()))

(define (write-init-file pathname buffer key entries)
  (guarantee-init-file-directory pathname)
  (if buffer
      (begin
	(local-set-variable! version-control 'NEVER buffer)
	(backup-buffer! buffer pathname #f)))
  (fasdump (cons key entries) pathname #t)
  (message "Wrote " (->namestring pathname))
  (if buffer
      (call-with-values (lambda () (os/buffer-backup-pathname pathname buffer))
	(lambda (backup-pathname targets)
	  targets
	  (delete-file-no-errors backup-pathname)))))

(define (init-file-pathname . components)
  (init-file-specifier->pathname (cons "snr" components)))

;;;; Groups File

(define (read-groups-init-file connection)
  (list->vector
   (let ((convert-entry #f))
     (let ((entries
	    (let ((server (nntp-connection:server connection)))
	      (read-init-file (groups-init-file-pathname server)
			      (groups-init-file-description server)
		(lambda (key)
		  (case key
		    ((1)
		     (set! convert-entry convert-groups-init-file-entry-type-1)
		     validate-groups-init-file-entry-type-1)
		    ((2)
		     (set! convert-entry convert-groups-init-file-entry-type-2)
		     validate-groups-init-file-entry-type-2)
		    ((3)
		     (set! convert-entry convert-groups-init-file-entry-type-3)
		     validate-groups-init-file-entry-type-3)
		    ((4)
		     (set! convert-entry convert-groups-init-file-entry-type-4)
		     validate-groups-init-file-entry-type-4)
		    (else #f)))))))
       (if (null? entries)
	   entries
	   (map (convert-entry connection) entries))))))

(define (write-groups-init-file buffer)
  (let ((server-buffer (news-server-buffer buffer #t)))
    (let ((server (news-server-buffer:server server-buffer))
	  (groups (news-server-buffer:groups server-buffer)))
      (write-init-file
       (groups-init-file-pathname server)
       server-buffer
       4
       (let loop ((groups (vector->list groups)) (entries '()))
	 (if (null? groups)
	     entries
	     (loop
	      (cdr groups)
	      (let ((group (car groups)))
		(if (and (not (news-group:subscribed? group))
			 (ranges-empty? (news-group:ranges-deleted group))
			 (ranges-empty? (news-group:ranges-marked group))
			 (ranges-empty? (news-group:ranges-browsed group)))
		    entries
		    (cons (vector (news-group:name group)
				  (news-group:subscribed? group)
				  (news-group:server-info group)
				  (news-group:ranges-deleted group)
				  (news-group:ranges-marked group)
				  (news-group:ranges-browsed group))
			  entries))))))))))

(define (groups-init-file-pathname server)
  (init-file-pathname server "groups"))

(define (groups-init-file-description server)
  (string-append "News-groups data for " server))

(define (validate-groups-init-file-entry-type-1 entry)
  (and (list? entry)
       (>= (length entry) 2)
       (string? (car entry))
       (boolean? (cadr entry))
       (every range? (cddr entry))))

(define ((convert-groups-init-file-entry-type-1 connection) entry)
  (make-news-group-1 connection (car entry) (cadr entry) #f (cddr entry)
		     '() '()))

(define (validate-groups-init-file-entry-type-2 entry)
  (and (list? entry)
       (>= (length entry) 3)
       (string? (car entry))
       (boolean? (cadr entry))
       (valid-group-server-info? (caddr entry))
       (every range? (cdddr entry))))

(define ((convert-groups-init-file-entry-type-2 connection) entry)
  (make-news-group-1 connection
		     (car entry)
		     (cadr entry)
		     (caddr entry)
		     (cdddr entry)
		     '()
		     '()))

(define (validate-groups-init-file-entry-type-3 entry)
  (and (vector? entry)
       (= (vector-length entry) 5)
       (string? (vector-ref entry 0))
       (boolean? (vector-ref entry 1))
       (valid-group-server-info? (vector-ref entry 2))
       (every range? (vector-ref entry 3))
       (every range? (vector-ref entry 4))))

(define ((convert-groups-init-file-entry-type-3 connection) entry)
  (make-news-group-1 connection
		     (vector-ref entry 0)
		     (vector-ref entry 1)
		     (vector-ref entry 2)
		     (vector-ref entry 3)
		     (vector-ref entry 4)
		     '()))

(define (validate-groups-init-file-entry-type-4 entry)
  (and (vector? entry)
       (= (vector-length entry) 6)
       (string? (vector-ref entry 0))
       (boolean? (vector-ref entry 1))
       (valid-group-server-info? (vector-ref entry 2))
       (every range? (vector-ref entry 3))
       (every range? (vector-ref entry 4))
       (every range? (vector-ref entry 5))))

(define ((convert-groups-init-file-entry-type-4 connection) entry)
  (make-news-group-1 connection
		     (vector-ref entry 0)
		     (vector-ref entry 1)
		     (vector-ref entry 2)
		     (vector-ref entry 3)
		     (vector-ref entry 4)
		     (vector-ref entry 5)))

(define (valid-group-server-info? server-info)
  (and (vector? server-info)
       (= (vector-length server-info) 3)
       (or (equal? '#(#f #f #f) server-info)
	   (equal? '#(0 0 0) server-info)
	   (and (exact-nonnegative-integer? (vector-ref server-info 0))
		(article-number? (vector-ref server-info 1))
		(article-number? (vector-ref server-info 2))))))

;;;; Ignored-Subjects File

(define (read-ignored-subjects-file group)
  (let ((entries
	 (read-init-file (ignored-subjects-file-pathname group)
			 (ignored-subjects-file-description group)
	   (lambda (key)
	     (case key
	       ((1)
		(lambda (entry)
		  (and (pair? entry)
		       (pair? (cdr entry))
		       (null? (cddr entry))
		       (string? (car entry))
		       (not (string-null? (car entry)))
		       (exact-nonnegative-integer? (cadr entry)))))
	       (else #f))))))
    (if (null? entries)
	#f
	(let ((table (make-string-hash-table (length entries))))
	  (for-each (lambda (entry)
		      (hash-table-set! table (car entry) (cadr entry)))
		    entries)
	  table))))

(define (write-ignored-subjects-file group buffer)
  ;; Action of NEWS-GROUP:PURGE-IGNORED-SUBJECTS! has been integrated
  ;; into this procedure to increase performance.  The
  ;; ignored-subjects lists can be quite large, and this allows the
  ;; list to be processed in a single pass rather than two.
  (let ((table
	 (and (pair? (news-group:ignored-subjects group))
	      (news-group:get-ignored-subjects group #f))))
    (and table
	 (let ((entries (hash-table->alist table))
	       (t
		(- (get-universal-time)
		   (* (ref-variable news-group-ignored-subject-retention #f)
		      86400))))
	   (and (or (news-group:ignored-subjects-modified? group)
		    (any (lambda (entry) (< (cdr entry) t)) entries))
		(begin
		  (write-init-file (ignored-subjects-file-pathname group)
				   buffer
				   1
				   (let loop ((entries entries) (result '()))
				     (cond ((null? entries)
					    result)
					   ((< (cdar entries) t)
					    (hash-table-delete! table
								(caar entries))
					    (loop (cdr entries) result))
					   (else
					    (loop (cdr entries)
						  (cons (list (caar entries)
							      (cdar entries))
							result))))))
		  (news-group:ignored-subjects-not-modified! group)
		  #t))))))

(define (ignored-subjects-file-pathname group)
  (init-file-pathname (news-group:server group)
		      "ignored-subjects"
		      (news-group:name group)))

(define (ignored-subjects-file-description group)
  (string-append "Ignored-subjects data for "
		 (news-group:server group)
		 ":"
		 (news-group:name group)))

;;;; .newsrc File

(define-command read-newsrc-file
  "Read the .newsrc file and apply it to the current subscribed-groups list.
Normally, merges the .newsrc entries into the groups list.
With prefix arg, replaces the groups list with the .newsrc entries."
  "P"
  (lambda (replace?)
    (let ((buffer (current-news-server-buffer #t)))
      (let ((connection (news-server-buffer:connection buffer)))
	(let ((entries
	       (call-with-newsrc-file-buffer connection parse-newsrc-buffer)))
	  (if replace?
	      (for-each-vector-element (news-server-buffer:groups buffer)
		(lambda (group)
		  (if (not (assoc (news-group:name group) entries))
		      (unsubscribe-news-group buffer group)))))
	  (for-each
	   (lambda (entry)
	     (let ((name (car entry))
		   (subscribed? (cadr entry))
		   (ranges (cddr entry)))
	       (let ((group
		      (let ((group (find-news-group connection name)))
			(if group
			    (begin
			      (set-news-group:ranges-deleted!
			       group
			       (if replace?
				   ranges
				   (merge-ranges
				    (news-group:ranges-deleted group)
				    ranges)))
			      (news-group:guarantee-ranges-deleted group)
			      group)
			    (make-news-group-1 connection name #f #f ranges
					       '() '())))))
		 (if subscribed?
		     (subscribe-news-group buffer group)
		     (unsubscribe-news-group buffer group)))))
	   entries))))))

(define-command write-newsrc-file
  "Write the .newsrc file corresponding to the current subscribed-groups list.
Normally, merges the list information into the file.
With prefix arg, replaces the file with the list information."
  "P"
  (lambda (replace?)
    (let ((buffer (current-news-server-buffer #t)))
      (let ((connection (news-server-buffer:connection buffer)))
	(call-with-newsrc-file-buffer connection
	  (lambda (newsrc)
	    (if replace? (delete-region (buffer-unclipped-region newsrc)))
	    (for-each-vector-element (news-server-buffer:groups buffer)
	      (lambda (group)
		(update-newsrc-group newsrc group)))
	    (save-buffer newsrc #f)))))))

(define (parse-newsrc-buffer buffer)
  (let loop ((start (buffer-start buffer)) (entries '()))
    (let ((end (line-end start 0)))
      (let ((entries
	     (let ((mark (re-match-forward "^[^:! \t\n]+[:!]" start end)))
	       (if mark
		   (cons (cons* (extract-string start (mark-1+ mark))
				(char=? #\: (extract-left-char mark))
				(parse-newsrc-group-ranges mark end))
			 entries)
		   entries))))
	(if (group-end? end)
	    (reverse! entries)
	    (loop (mark1+ end) entries))))))

(define (parse-newsrc-group-ranges mark end)
  (let loop ((mark mark) (ranges '()))
    (if (re-match-forward "[, \t]*\\([0-9-]+\\)" mark end)
	(let ((s (re-match-start 1))
	      (e (re-match-end 1)))
	  (loop e
		(let ((test
		       (lambda (pattern)
			 (let ((m (re-match-forward pattern s e)))
			   (and m
				(mark= m e))))))
		  (cond ((test "[0-9]+")
			 (cons (let ((n (extract-nonnegative-integer s e)))
				 (make-range n n))
			       ranges))
			((test "\\([0-9]+\\)-\\([0-9]+\\)")
			 (let ((n
				(extract-nonnegative-integer
				 (re-match-start 1)
				 (re-match-end 1)))
			       (m
				(extract-nonnegative-integer
				 (re-match-start 2)
				 (re-match-end 2))))
			   (if (< n m)
			       (cons (make-range n m) ranges)
			       ranges)))
			(else
			 ranges)))))
	(canonicalize-ranges (reverse! ranges)))))

(define (extract-nonnegative-integer start end)
  (let loop ((mark start) (n 0))
    (if (mark= mark end)
	n
	(loop (mark1+ mark)
	      (+ (* n 10)
		 (fix:- (char->integer (extract-right-char mark))
			(char->integer #\0)))))))

(define (update-newsrc-group buffer group)
  (let ((mark
	 (re-search-forward
	  (string-append "^"
			 (re-quote-string (news-group:name group))
			 "[:!]")
	  (buffer-start buffer)))
	(finish
	 (lambda (mark)
	   (insert-char (if (news-group:subscribed? group) #\: #\!) mark)
	   (let ((ranges
		  (let ((ranges (news-group:guarantee-ranges-deleted group))
			(first (news-group:first-article group)))
		    (if (> first 1)
			(canonicalize-ranges
			 (cons (make-range 1 (- first 1)) ranges))
			ranges)))
		 (write-range
		  (lambda (range)
		    (let ((f (range-first range))
			  (l (range-last range)))
		      (if (= f l)
			  (insert-string (number->string f) mark)
			  (begin
			    (insert-string (number->string f) mark)
			    (insert-char #\- mark)
			    (insert-string (number->string l) mark)))))))
	     (if (not (null? ranges))
		 (begin
		   (insert-char #\space mark)
		   (write-range (car ranges))
		   (for-each (lambda (range)
			       (insert-char #\, mark)
			       (write-range range))
			     (cdr ranges))))))))
    (if mark
	(let ((mark (mark-left-inserting-copy (mark-1+ mark))))
	  (delete-string mark (line-end mark 0))
	  (finish mark)
	  (mark-temporary! mark))
	(let ((mark (mark-left-inserting-copy (buffer-end buffer))))
	  (guarantee-newline mark)
	  (insert-string (news-group:name group) mark)
	  (finish mark)
	  (insert-newline mark)
	  (mark-temporary! mark)))))

(define (call-with-newsrc-file-buffer connection receiver)
  (let ((pathname (os/newsrc-file-name (nntp-connection:server connection))))
    (let ((buffer (pathname->buffer pathname)))
      (if buffer
	  (receiver (find-file-revert buffer))
	  (let ((buffer (find-file-noselect pathname #f)))
	    (set-variable! version-control #f buffer)
	    (let ((value (receiver buffer)))
	      (kill-buffer buffer)
	      value))))))

;;;; Line Property Items

(define (iterate-on-lines get-item adjective predicate argument
			  first-item next-item previous-item procedure)
  (call-with-values
      (lambda ()
	(start-property-iteration get-item adjective predicate argument))
    (lambda (item n)
      (cond (item
	     (let ((buffer (selected-buffer)))
	       (cond ((> n 0)
		      (let loop ((item (first-item item)) (n n))
			(let ((next (next-item buffer item)))
			  (procedure buffer item next n)
			  (if (> n 1)
			      (if next
				  (loop next (- n 1))
				  (editor-failure))))))
		     ((< n 0)
		      (let loop ((item (first-item item)) (n n))
			(let ((previous (previous-item buffer item)))
			  (procedure buffer item previous n)
			  (if (< n -1)
			      (if previous
				  (loop previous (+ n 1))
				  (editor-failure)))))))))
	    ((not (= n 0))
	     (editor-failure))))))

(define (start-property-iteration get-item adjective predicate argument)
  (let ((start (line-start (current-point) 0)))
    (if (not argument)
	(let ((item (get-item start)))
	  (if (and item (or (not predicate) (predicate item)))
	      (values item 1)
	      (not-on-property-line-error adjective)))
	(let ((n (command-argument-value argument)))
	  (cond ((> n 0)
		 (let loop ((ls start))
		   (let ((item (get-item ls)))
		     (if (and item (or (not predicate) (predicate item)))
			 (values item n)
			 (let ((ls (line-start ls 1 #f)))
			   (if ls
			       (loop ls)
			       (values #f n)))))))
		((< n 0)
		 (let ((ls (line-start start -1 #f)))
		   (if ls
		       (let loop ((ls ls))
			 (let ((item (get-item ls)))
			   (if (and item (or (not predicate) (predicate item)))
			       (values item n)
			       (let ((ls (line-start ls -1 #f)))
				 (if ls
				     (loop ls)
				     (values #f n))))))
		       (values #f n))))
		(else
		 (values #f n)))))))

(define (not-on-property-line-error adjective)
  (editor-error "Point isn't on a"
		(if (memv (string-ref adjective 0) '(#\a #\e #\i #\o #\u))
		    "n"
		    "")
		" "
		adjective
		" line."))

(define (find-next-property-line ls key predicate)
  (let loop ((ls ls))
    (let ((ls (line-start ls 1 #f)))
      (if (or (not ls)
	      (let ((item (region-get ls key #f)))
		(and item
		     (or (not predicate)
			 (predicate item)))))
	  ls
	  (loop ls)))))

(define (find-previous-property-line ls key predicate)
  (let loop ((ls ls))
    (let ((ls (line-start ls -1 #f)))
      (if (or (not ls)
	      (let ((item (region-get ls key #f)))
		(and item
		     (or (not predicate)
			 (predicate item)))))
	  ls
	  (loop ls)))))

(define (find-first-property-line buffer key predicate)
  (let ((ls (buffer-start buffer)))
    (if (let ((item (region-get ls key #f)))
	  (and item
	       (or (not predicate)
		   (predicate item))))
	ls
	(find-next-property-line ls key predicate))))

(define (find-next-line-property ls key predicate)
  (let loop ((ls ls))
    (let ((ls (line-start ls 1 #f)))
      (and ls
	   (let ((item (region-get ls key #f)))
	     (if (and item
		      (or (not predicate)
			  (predicate item)))
		 item
		 (loop ls)))))))

(define (find-previous-line-property ls key predicate)
  (let loop ((ls ls))
    (let ((ls (line-start ls -1 #f)))
      (and ls
	   (let ((item (region-get ls key #f)))
	     (if (and item
		      (or (not predicate)
			  (predicate item)))
		 item
		 (loop ls)))))))

(define (find-first-line buffer get-item)
  (let loop ((ls (buffer-start buffer)))
    (if (get-item ls)
	ls
	(let ((ls (line-start ls 1 #f)))
	  (and ls
	       (loop ls))))))

(define (find-buffer-line buffer get-item test-item if-found if-not-found)
  (let loop
      ((low (buffer-start buffer))
       (high
	(let loop ((end (buffer-end buffer)))
	  (if (and (line-start? end)
		   (not (group-start? end)))
	      (loop (mark-1+ end))
	      end))))
    (let inner ((ls (line-start (mark-average low high) 0)))
      (let ((item (get-item ls)))
	(cond (item
	       (case (test-item item)
		 ((EQUAL)
		  (if-found ls))
		 ((LESS)
		  (if (mark< low ls)
		      (loop low (mark-1+ ls))
		      (if-not-found low)))
		 (else
		  (let ((le (line-end ls 0)))
		    (if (mark< le high)
			(loop (mark1+ le) high)
			(if-not-found
			 (if (group-end? le)
			     le
			     (mark1+ le))))))))
	      ((let loop ((ls ls))
		 (let ((le (line-end ls 0)))
		   (and (mark< le high)
			(let ((ls (mark1+ le)))
			  (if (get-item ls)
			      ls
			      (loop ls))))))
	       => inner)
	      ((let loop ((ls ls))
		 (and (mark< low ls)
		      (let ((ls (line-start (mark-1+ ls) 0)))
			(if (get-item ls)
			    ls
			    (loop ls)))))
	       => inner)
	      (else
	       (if-not-found (buffer-end buffer))))))))

;;;; Miscellaneous

(define (vector-insert v i x)
  (let ((l (vector-length v)))
    (let ((v* (make-vector (fix:+ l 1))))
      (subvector-move-right! v 0 i v* 0)
      (vector-set! v* i x)
      (subvector-move-right! v i l v* (fix:+ i 1))
      v*)))

(define (vector-delete v i)
  (let ((l (vector-length v)))
    (let ((v* (make-vector (fix:- l 1))))
      (subvector-move-right! v 0 i v* 0)
      (subvector-move-right! v (fix:+ i 1) l v* i)
      v*)))

(define (string-order x y)
  (string-compare x y
		  (lambda () 'EQUAL)
		  (lambda () 'LESS)
		  (lambda () 'GREATER)))

(define (prefix-matcher prefix)
  (let ((plen (string-length prefix)))
    (lambda (x y)
      (let ((n (string-match-forward x y)))
	(and (fix:>= n plen)
	     n)))))

(define (create-news-buffer name mode procedure)
  (let ((buffer (new-buffer name)))
    (set-buffer-major-mode! buffer mode)
    (disable-group-undo! (buffer-group buffer))
    (set-buffer-point! buffer (or (procedure buffer) (buffer-end buffer)))
    (buffer-not-modified! buffer)
    (set-buffer-read-only! buffer)
    buffer))

(define (mark-average m1 m2)
  (make-mark (mark-group m1)
	     (fix:quotient (fix:+ (mark-index m1) (mark-index m2)) 2)))

(define (with-buffer-open-1 buffer thunk)
  (with-buffer-open buffer
    (lambda ()
      (with-editor-interrupts-disabled thunk)
      (buffer-not-modified! buffer))))

;;;; Buffer Trees

(define (buffer-tree:parent buffer error?)
  (or (let ((node (buffer-tree:node buffer #f)))
	(and node
	     (car node)))
      (and error?
	   (error "Missing parent buffer:" (buffer-name buffer)))))

(define (buffer-tree:child buffer key error?)
  (or (let ((node (buffer-tree:node buffer #f)))
	(and node
	     (let ((entry (assq key (cdr node))))
	       (and entry
		    (cdr entry)))))
      (and error?
	   (error "Missing child buffer:" key (buffer-name buffer)))))

(define (buffer-tree:children buffer)
  (let ((node (buffer-tree:node buffer #f)))
    (if node
	(map cdr (cdr node))
	'())))

(define (buffer-tree:attach-child! parent key child)
  (with-editor-interrupts-disabled
    (lambda ()
      (let ((node (buffer-tree:node parent #t)))
	(let ((entry (assq key (cdr node))))
	  (if entry
	      (set-cdr! entry child)
	      (set-cdr! node (cons (cons key child) (cdr node))))))
      (set-car! (buffer-tree:node child #t) parent))))

(define (buffer-tree:node buffer intern?)
  (or (buffer-get buffer 'BUFFER-TREE #f)
      (and intern?
	   (let ((node (cons #f '())))
	     (with-editor-interrupts-disabled
	       (lambda ()
		 (buffer-put! buffer 'BUFFER-TREE node)
		 (add-kill-buffer-hook buffer buffer-tree:kill)))
	     node))))

(define (buffer-tree:kill buffer)
  (with-editor-interrupts-disabled
    (lambda ()
      (ignore-errors
       (lambda ()
	 (let ((node (buffer-tree:node buffer #f)))
	   (if node
	       (begin
		 (let ((parent (car node)))
		   (if parent
		       (let ((node (buffer-tree:node parent #f)))
			 (and node
			      (set-cdr! node
					((list-deletor!
					  (lambda (entry)
					    (eq? buffer (cdr entry))))
					 (cdr node)))))))
		 (for-each (lambda (child)
			     (let ((node (buffer-tree:node child #f)))
			       (if node
				   (set-car! node #f))))
			   (map cdr (cdr node)))))))))))

;;;; Article Ranges

(define (range? object)
  (or (article-number? object)
      (and (pair? object)
	   (article-number? (car object))
	   (article-number? (cdr object))
	   (<= (car object) (cdr object)))))

(define (article-number? object)
  (and (exact-integer? object)
       (> object 0)))

(define (make-range f l) (if (= f l) f (cons f l)))
(define (range-first r)  (if (pair? r) (car r) r))
(define (range-last r)   (if (pair? r) (cdr r) r))
(define (range-length r) (if (pair? r) (+ (- (cdr r) (car r)) 1) 1))
(define ranges-empty? null?)

(define (count-ranges ranges)
  (let loop ((ranges ranges) (count 0))
    (if (null? ranges)
	count
	(loop (cdr ranges) (+ count (range-length (car ranges)))))))

(define (canonicalize-ranges ranges)
  (if (null? ranges)
      ranges
      (let ((ranges
	     (sort ranges (lambda (x y) (< (range-first x) (range-first y))))))
	(let loop ((ranges ranges))
	  (if (not (null? (cdr ranges)))
	      (let ((x (car ranges))
		    (y (cadr ranges)))
		(if (<= (range-first y) (+ (range-last x) 1))
		    (begin
		      (set-car! ranges
				(make-range (range-first x)
					    (max (range-last x)
						 (range-last y))))
		      (set-cdr! ranges (cddr ranges))
		      (loop ranges))
		    (loop (cdr ranges))))))
	ranges)))

(define (clip-ranges! ranges first last)
  (let ((holder
	 (cons 'HOLDER
	       (let clip-first ((ranges ranges))
		 (cond ((or (null? ranges)
			    (<= first (range-first (car ranges))))
			ranges)
		       ((< (range-last (car ranges)) first)
			(clip-first (cdr ranges)))
		       (else
			(set-car! ranges
				  (make-range first (range-last (car ranges))))
			ranges))))))
    (let clip-last ((ranges (cdr holder)) (prev holder))
      (cond ((null? ranges)
	     unspecific)
	    ((< (range-last (car ranges)) last)
	     (clip-last (cdr ranges) ranges))
	    ((> (range-first (car ranges)) last)
	     (set-cdr! prev '()))
	    (else
	     (if (> (range-last (car ranges)) last)
		 (set-car! ranges
			   (make-range (range-first (car ranges))
				       last)))
	     (set-cdr! ranges '()))))
    (cdr holder)))

(define (complement-ranges ranges first last)
  (if (null? ranges)
      (list (make-range first last))
      (let loop
	  ((e (range-last (car ranges)))
	   (ranges (cdr ranges))
	   (result
	    (let ((s (range-first (car ranges))))
	      (if (< first s)
		  (list (make-range first (- s 1)))
		  '()))))
	(if (null? ranges)
	    (reverse! (if (< e last)
			  (cons (make-range (+ e 1) last) result)
			  result))
	    (loop (range-last (car ranges))
		  (cdr ranges)
		  (cons (make-range (+ e 1) (- (range-first (car ranges)) 1))
			result))))))

(define (merge-ranges ranges ranges*)
  (cond ((null? ranges)
	 ranges*)
	((null? ranges*)
	 ranges)
	((< (range-last (car ranges)) (range-first (car ranges*)))
	 (cons (car ranges) (merge-ranges (cdr ranges) ranges*)))
	((< (range-last (car ranges*)) (range-first (car ranges)))
	 (cons (car ranges*) (merge-ranges ranges (cdr ranges*))))
	(else
	 (cons (make-range (min (range-first (car ranges))
				(range-first (car ranges*)))
			   (max (range-last (car ranges))
				(range-last (car ranges*))))
	       (merge-ranges (cdr ranges) (cdr ranges*))))))

(define (add-to-ranges! ranges number)
  (let ((holder (cons 'HOLDER ranges)))
    (let loop ((ranges ranges) (prev holder))
      (if (null? ranges)
	  (set-cdr! prev (list (make-range number number)))
	  (let ((f (range-first (car ranges)))
		(l (range-last (car ranges))))
	    (cond ((> number (+ l 1))
		   (loop (cdr ranges) ranges))
		  ((< number (- f 1))
		   (set-cdr! prev (cons (make-range number number) ranges)))
		  (else
		   (let ((f (min f number))
			 (l (max l number)))
		     (if (and (not (null? (cdr ranges)))
			      (= (+ l 1) (range-first (cadr ranges))))
			 (begin
			   (set-car! ranges
				     (make-range f (range-last (cadr ranges))))
			   (set-cdr! ranges (cddr ranges)))
			 (set-car! ranges (make-range f l)))))))))
    (cdr holder)))

(define (remove-from-ranges! ranges number)
  (let ((holder (cons 'HOLDER ranges)))
    (let loop ((ranges ranges) (prev holder))
      (if (not (null? ranges))
	  (let ((f (range-first (car ranges)))
		(l (range-last (car ranges))))
	    (cond ((> number l)
		   (loop (cdr ranges) ranges))
		  ((>= number f)
		   (if (= number f)
		       (if (= number l)
			   (set-cdr! prev (cdr ranges))
			   (set-car! ranges (make-range (+ f 1) l)))
		       (if (= number l)
			   (set-car! ranges (make-range f (- l 1)))
			   (begin
			     (set-car! ranges (make-range (+ number 1) l))
			     (set-cdr! prev
				       (cons (make-range f (- number 1))
					     ranges))))))))))
    (cdr holder)))

(define (member-of-ranges? ranges number)
  (let loop ((ranges ranges))
    (and (not (null? ranges))
	 (or (<= (range-first (car ranges)) number (range-last (car ranges)))
	     (loop (cdr ranges))))))

(define (ranges->list ranges)
  (let loop ((ranges ranges) (result '()))
    (if (null? ranges)
	(reverse! result)
	(loop (cdr ranges)
	      (let ((e (range-last (car ranges))))
		(let loop ((n (range-first (car ranges))) (result result))
		  (let ((result (cons n result)))
		    (if (= n e)
			result
			(loop (+ n 1) result)))))))))

(define (for-each-range-element procedure ranges)
  (for-each (lambda (range)
	      (let ((e (+ (range-last range) 1)))
		(do ((n (range-first range) (+ n 1)))
		    ((= n e) unspecific)
		  (procedure n))))
	    ranges))

;;;; News-Group Extensions

(define-structure (news-group-extra
		   (type vector)
		   (conc-name news-group-extra:)
		   (constructor make-news-group-extra ()))
  (subscribed? #f)
  (ranges-deleted '())
  (index #f)
  (ignored-subjects 'UNKNOWN)
  (ranges-marked '())
  (ranges-browsed '()))

(define (get-news-group-extra group write?)
  (or (news-group:reader-hook group)
      (let ((extra (make-news-group-extra)))
	(if write? (set-news-group:reader-hook! group extra))
	extra)))

(define (news-group:subscribed? group)
  (news-group-extra:subscribed? (get-news-group-extra group #f)))

(define (set-news-group:subscribed?! group value)
  (set-news-group-extra:subscribed?! (get-news-group-extra group #t) value))

(define (news-group:ranges-deleted group)
  (news-group-extra:ranges-deleted (get-news-group-extra group #f)))

(define (set-news-group:ranges-deleted! group value)
  (set-news-group-extra:ranges-deleted! (get-news-group-extra group #t) value))

(define (news-group:index group)
  (news-group-extra:index (get-news-group-extra group #f)))

(define (set-news-group:index! group value)
  (set-news-group-extra:index! (get-news-group-extra group #t) value))

(define (news-group:ignored-subjects group)
  (news-group-extra:ignored-subjects (get-news-group-extra group #f)))

(define (set-news-group:ignored-subjects! group value)
  (set-news-group-extra:ignored-subjects! (get-news-group-extra group #t)
					  value))

(define (news-group:ranges-marked group)
  (news-group-extra:ranges-marked (get-news-group-extra group #f)))

(define (set-news-group:ranges-marked! group value)
  (set-news-group-extra:ranges-marked! (get-news-group-extra group #t) value))

(define (news-group:ranges-browsed group)
  (news-group-extra:ranges-browsed (get-news-group-extra group #f)))

(define (set-news-group:ranges-browsed! group value)
  (set-news-group-extra:ranges-browsed! (get-news-group-extra group #t) value))

(define (make-news-group-1 connection name subscribed? server-info
			   ranges-deleted ranges-marked ranges-browsed)
  (let ((group (make-news-group connection name)))
    (set-news-group:subscribed?! group subscribed?)
    (set-news-group:server-info! group server-info)
    (set-news-group:ranges-deleted! group (canonicalize-ranges ranges-deleted))
    (set-news-group:ranges-marked! group (canonicalize-ranges ranges-marked))
    (set-news-group:ranges-browsed! group (canonicalize-ranges ranges-browsed))
    (news-group:clip-ranges! group)
    (news-group:apply-cache-policy group)
    group))

(define (news-group:apply-cache-policy group)
  (set-news-group:use-gdbm!
   group
   (let ((nggp (ref-variable news-group-cache-policy)))
     (if (cond ((eq? 'ALL (car nggp)) #t)
	       ((eq? 'SUBSCRIBED (car nggp)) (news-group:subscribed? group))
	       (else (member (news-group:name group) (car nggp))))
	 (cadr nggp)
	 '()))))

(define (news-group:get-threads group argument buffer)
  (let ((headers (news-group:get-headers group argument buffer))
	(msg "Threading headers... "))
    (message msg)
    (let ((threads
	   (organize-headers-into-threads
	    headers
	    (ref-variable news-group-show-context-headers buffer)
	    #f
	    (ref-variable news-split-threads-on-subject-changes buffer)
	    (ref-variable news-join-threads-with-same-subject buffer))))
      (news-group:close-database group)
      (message msg "done")
      (list->vector
       (if (or (command-argument-multiplier-only? argument)
	       (ref-variable news-group-show-seen-headers buffer))
	   threads
	   (remove news-thread:all-articles-deleted?
		   threads))))))

(define (news-group:get-headers group argument buffer)
  (let ((connection (news-group:connection group))
        (all?
         (or (command-argument-multiplier-only? argument)
             (ref-variable news-group-show-seen-headers buffer)))
        (limit
         (and argument
              (not (command-argument-multiplier-only? argument))
              (command-argument-value argument))))
    (if (and (command-argument-multiplier-only? argument)
             (nntp-connection:closed? connection))
        (nntp-connection:reopen connection))
    (if (and (ref-variable news-refresh-group-when-selected
                           (news-server-buffer buffer #f))
             (not (nntp-connection:closed? connection)))
        (news-group:update-ranges! group))
    (receive (headers invalid)
        (split-list (news-group:headers* group all? limit buffer)
                    news-header?)
      (for-each (lambda (entry)
                  (if (not (eq? (car entry) 'UNREACHABLE-ARTICLE))
                      (article-number-seen! group (cdr entry))))
                invalid)
      headers)))

(define (news-group:get-unread-headers group buffer)
  (news-group:update-ranges! group)
  (news-group:pre-read-headers group (news-group:unread-header-numbers group))
  (if (not (ref-variable news-group-show-seen-headers buffer))
      ;; Read in the headers -- this finds the headers to be ignored
      ;; and marks them as such.
      (news-group:get-headers group #f buffer))
  (news-group:close-database group))

(define (news-group:headers* group all? limit context)
  (news-group:headers
   group
   (if all?
       (news-group:all-header-numbers group)
       (let ((ns (news-group:unread-header-numbers group)))
         (if limit
             (let ((lns (length ns)))
               (cond ((<= lns (abs limit)) ns)
                     ((< limit 0) (take ns (- limit)))
                     (else (drop ns (- (length ns) limit)))))
             ns)))
   (let ((ignore-header?
          (let ((filter (ref-variable news-header-filter context)))
            (or (and filter
                     (lambda (header)
                       (not (filter header))))
                (lambda (header) header #f))))
         (table
          (news-group:get-ignored-subjects group #f)))
     (if table
         (let ((t (get-universal-time))
               (show-ignored? (not all?)))
           (lambda (header)
             (and (ignore-header? header)
                  (news-header:ignore?! header table t)
                  (begin
                    (set-news-header:status! header #\I)
                    (article-number-seen! group
                                          (news-header:number header))
                    show-ignored?))))
         ignore-header?))))

;;;; Header Filter Combinators

(define (news-header-splitting-filter unit-filter)
  (lambda (header)
    (let* ((text (news-header:text header))
           (limit (string-length text))
           (start (if (and (fix:> limit 1)
                           (char=? (string-ref text 0) #\newline))
                      1
                      0)))
      (let loop ((start start) (index start))
        (cond ((substring-find-next-char text index limit #\newline)
               => (lambda (line-end)
                    (let ((next-line-start (fix:1+ line-end)))
                      (if (fix:= next-line-start limit)
                          (unit-filter text start line-end)
                          (let ((char (string-ref text next-line-start)))
                            (if (or (char=? char #\space)
                                    (char=? char #\tab))
                                (loop start next-line-start)
                                (and (unit-filter text start line-end)
                                     (loop next-line-start
                                           next-line-start))))))))
              ((fix:= start limit)
               #t)
              (else
               (unit-filter text start limit)))))))

(define (news-header-regexp-filter specifiers)
  (news-header-splitting-filter
   (let ((table (alist->string-table
                 (map (lambda (specifier)
                        (cons (car specifier)
                              (re-compile-pattern (cdr specifier)
                                                  #f)))      ; Don't case-fold.
                      specifiers)
                 #t)))      ; Case-insensitive
     (lambda (text start end)
       (cond ((substring-find-next-char text start end #\:)
              => (lambda (colon-index)
                   (cond ((string-table-get table
                                            (substring text start colon-index))
                          => (lambda (regexp)
                               (not (re-substring-match regexp text
                                                        ;; Skip colon & space.
                                                        (fix:+ colon-index 2)
                                                        end))))
                         (else #t))))
             (else #t))))))

(define (article-number-seen! group number)
  (set-news-group:ranges-deleted!
   group
   (add-to-ranges! (news-group:guarantee-ranges-deleted group) number)))

(define (news-group:unread-header-numbers group)
  (if (news-group:server-has-articles? group)
      (ranges->list
       (complement-ranges (news-group:guarantee-ranges-deleted group)
			  (news-group:first-article group)
			  (news-group:last-article group)))
      '()))

(define (news-group:all-header-numbers group)
  (if (news-group:server-has-articles? group)
      (ranges->list
       (complement-ranges '()
			  (news-group:first-article group)
			  (news-group:last-article group)))
      '()))

(define (news-group:update-ranges! group)
  (let ((msg
	 (string-append "Updating group info for "
			(news-group:name group)
			"... ")))
    (message msg)
    (news-group:update-server-info! group)
    (message msg "done"))
  (if (news-group:active? group)
      (news-group:clip-ranges! group)))

(define (news-group:purge-and-compact-headers! group buffer)
  (let ((msg
	 (string-append "Purging headers in " (news-group:name group) "... ")))
    (message msg)
    (news-group:purge-header-cache group 'ALL)
    (news-group:purge-pre-read-headers group
      (if (ref-variable news-group-keep-seen-headers buffer)
	  (if (news-group:server-has-articles? group)
	      (lambda (header)
		(let ((number (news-header:number header)))
		  (or (< number (news-group:first-article group))
		      (> number (news-group:last-article group))
		      (and (not (ref-variable news-group-keep-ignored-headers
					      buffer))
			   (news-header:ignore? header)))))
	      (lambda (header)
		header
		#t))
	  news-header:article-deleted?))
    (news-group:close-database group)
    (message msg "done")))

(define (news-group:number-of-articles group)
  (let ((estimate (news-group:estimated-n-articles group)))
    (and estimate
	 (if (and (news-group:reader-hook group)
		  (news-group:server-has-articles? group))
	     (let ((n-seen
		    (count-ranges
		     (news-group:guarantee-ranges-deleted group))))
	       (if (= n-seen 0)
		   estimate
		   (- (- (+ (news-group:last-article group) 1)
			 (news-group:first-article group))
		      n-seen)))
	     estimate))))

(define (news-group:clip-ranges! group)
  (if (news-group:server-has-articles? group)
      (let ((first (news-group:first-article group))
	    (last (news-group:last-article group)))
	(set-news-group:ranges-deleted!
	 group
	 (clip-ranges! (news-group:ranges-deleted group) first last))
	(set-news-group:ranges-marked!
	 group
	 (clip-ranges! (news-group:ranges-marked group) first last))
	(set-news-group:ranges-browsed!
	 group
	 (clip-ranges! (news-group:ranges-browsed group) first last)))
      (begin
	(set-news-group:ranges-deleted! group '())
	(set-news-group:ranges-marked! group '())
	(set-news-group:ranges-browsed! group '()))))

(define (news-group:guarantee-ranges-deleted group)
  (let ((ranges
	 (if (news-group:server-has-articles? group)
	     (clip-ranges! (news-group:ranges-deleted group)
			   (news-group:first-article group)
			   (news-group:last-article group))
	     '())))
    (set-news-group:ranges-deleted! group ranges)
    ranges))

(define ((news-group:adjust-article-status! handle-xrefs? procedure)
	 header buffer)
  (let ((do-it
	 (lambda (group number)
	   (procedure group number)
	   (news-group:maybe-defer-update buffer group))))
    (do-it (news-header:group header) (news-header:number header))
    (if handle-xrefs?
	(news-group:process-cross-posts header do-it))))

(define (news-group:process-cross-posts header process-header)
  (for-each (let ((connection
		   (news-group:connection (news-header:group header))))
	      (lambda (xref)
		(let ((group (find-news-group connection (car xref))))
		  (if (and group (news-group:subscribed? group))
		      (let ((number (token->number (cdr xref))))
			(if (not (news-group:article-browsed? group number))
			    (process-header group number)))))))
	    (news-header:xref header)))

(define (defer-marking-updates buffer thunk)
  (fluid-let ((news-group:adjust-article-status!:deferred-updates (list #t)))
    (thunk)
    (for-each (lambda (group) (update-news-groups-buffers buffer group))
	      (cdr news-group:adjust-article-status!:deferred-updates))))

(define (news-group:maybe-defer-update buffer group)
  (let ((deferred-updates news-group:adjust-article-status!:deferred-updates))
    (if deferred-updates
	(if (not (memq group (cdr deferred-updates)))
	    (set-cdr! deferred-updates (cons group (cdr deferred-updates))))
	(update-news-groups-buffers buffer group))))

(define news-group:adjust-article-status!:deferred-updates #f)

(define (news-group:articles-marked? group)
  (not (ranges-empty? (news-group:ranges-marked group))))

(define (news-group:marked-headers group)
  (map (lambda (number)
	 (let ((header (news-group:header group number)))
	   (if (news-header? header)
	       header
	       (list header group number))))
       (ranges->list (news-group:ranges-marked group))))

(define (news-header:read-marked-body header buffer)
  (news-header:guarantee-full-text! header)
  (news-header:pre-read-body header)
  (news-header:article-not-deleted! header buffer)
  (let ((buffer
	 (if (news-group-buffer? buffer)
	     buffer
	     (find-news-group-buffer buffer (news-header:group header)))))
    (if buffer
	(update-buffer-news-header-status buffer header))))

(define (news-group:order t1 t2)
  (cond ((news-group:< t1 t2) 'LESS)
	((news-group:< t2 t1) 'GREATER)
	(else 'EQUAL)))

(define ((range-predicate group-ranges) header)
  (member-of-ranges? (group-ranges (news-header:group header))
		     (news-header:number header)))

(define news-header:article-deleted?
  (range-predicate news-group:ranges-deleted))

(define news-header:article-marked?
  (range-predicate news-group:ranges-marked))

(define (news-group:article-browsed? group number)
  (member-of-ranges? (news-group:ranges-browsed group) number))

(define (ranges-marker group-ranges set-group-ranges! handle-xrefs? procedure)
  (news-group:adjust-article-status! handle-xrefs?
    (lambda (group number)
      (set-group-ranges! group (procedure (group-ranges group) number)))))

(define (ranges-deleted-marker procedure)
  (let ((marker
	 (ranges-marker news-group:ranges-deleted
			set-news-group:ranges-deleted!
			#t
			procedure)))
    (lambda (header buffer)
      (news-group:article-unmarked! header buffer)
      (marker header buffer))))

(define news-group:article-deleted!
  (ranges-deleted-marker add-to-ranges!))

(define news-group:article-not-deleted!
  (ranges-deleted-marker remove-from-ranges!))

(define news-group:article-marked!
  (let ((marker
	 (ranges-marker news-group:ranges-marked
			set-news-group:ranges-marked!
			#t
			add-to-ranges!)))
    (lambda (header buffer)
      (news-group:article-not-deleted! header buffer)
      (marker header buffer))))

(define news-group:article-unmarked!
  (ranges-marker news-group:ranges-marked
		 set-news-group:ranges-marked!
		 #t
		 remove-from-ranges!))

(define news-group:article-browsed!
  (ranges-marker news-group:ranges-browsed
		 set-news-group:ranges-browsed!
		 #f
		 add-to-ranges!))

(define (news-group:server-has-articles? group)
  (and (article-number? (news-group:first-article group))
       (article-number? (news-group:last-article group))))

;;;; Ignored-Subjects Database

(define (news-header:ignore?! header table t)
  (let ((subject (canonicalize-subject (news-header:subject header))))
    (and (not (fix:= 0 (string-length subject)))
	 (hash-table-ref/default table subject #f)
	 (let ((group (news-header:group header)))
	   (hash-table-set! table subject t)
	   (news-group:ignored-subjects-modified! group)
	   (news-group:process-cross-posts header
					   (ignore-subject-marker subject t))
	   #t))))

(define (news-header:ignore? header)
  (let ((table
	 (news-group:get-ignored-subjects (news-header:group header) #f)))
    (and table
	 (let ((subject (canonicalize-subject (news-header:subject header))))
	   (and (not (fix:= 0 (string-length subject)))
		(hash-table-ref/default table subject #f))))))

(define (news-group:article-ignored! header buffer)
  (let ((subject (canonicalize-subject (news-header:subject header))))
    (if (not (fix:= 0 (string-length subject)))
	(let ((process-header
	       (ignore-subject-marker subject (get-universal-time))))
	  (process-header (news-header:group header)
			  (news-header:number header))
	  (news-group:process-cross-posts header process-header))))
  (news-group:article-deleted! header buffer))

(define ((ignore-subject-marker subject t) group number)
  number
  (hash-table-set! (news-group:get-ignored-subjects group #t) subject t)
  (news-group:ignored-subjects-modified! group))

(define (news-group:article-not-ignored! header buffer)
  buffer
  (let ((subject (canonicalize-subject (news-header:subject header))))
    (if (not (fix:= 0 (string-length subject)))
	(let ((process-header
	       (lambda (group number)
		 number
		 (let ((table (news-group:get-ignored-subjects group #f)))
		   (if (and table (hash-table-ref/default table subject #f))
		       (begin
			 (hash-table-delete! table subject)
			 (news-group:ignored-subjects-modified! group)))))))
	  (process-header (news-header:group header)
			  (news-header:number header))
	  (news-group:process-cross-posts header process-header)))))

(define (news-group:get-ignored-subjects group intern?)
  (or (let ((table (news-group:ignored-subjects group)))
	(if (eq? table 'UNKNOWN)
	    (let ((table (read-ignored-subjects-file group)))
	      (set-news-group:ignored-subjects! group (cons table #f))
	      table)
	    (car table)))
      (and intern?
	   (let ((table (make-string-hash-table)))
	     (set-news-group:ignored-subjects! group (cons table #f))
	     table))))

(define-integrable (news-group:ignored-subjects-modified! group)
  (set-cdr! (news-group:ignored-subjects group) #t))

(define-integrable (news-group:ignored-subjects-not-modified! group)
  (set-cdr! (news-group:ignored-subjects group) #f))

(define (news-group:ignored-subjects-modified? group)
  (and (pair? (news-group:ignored-subjects group))
       (cdr (news-group:ignored-subjects group))))

;;;; News-Header Extensions

(define-structure (news-header-extra
		   (type vector)
		   (conc-name news-header-extra:)
		   (constructor make-news-header-extra (status)))
  (status #\space)
  (index #f))

(define (get-news-header-extra header write?)
  (or (news-header:reader-hook header)
      (let ((extra (make-news-header-extra (initial-header-status header))))
	(if write? (set-news-header:reader-hook! header extra))
	extra)))

(define (initial-header-status header)
  (let ((group (news-header:group header))
	(number (news-header:number header)))
    (cond ((or (not (news-header:real? header))
	       (not number))
	   #\D)
	  ((news-header:ignore? header)
	   (set-news-group:ranges-deleted!
	    group
	    (add-to-ranges! (news-group:ranges-deleted group) number))
	   #\I)
	  ((news-header:article-deleted? header) #\D)
	  ((news-header:article-marked? header) #\M)
	  (else #\space))))

(define (news-header:status header)
  (news-header-extra:status (get-news-header-extra header #f)))

(define (set-news-header:status! header value)
  (set-news-header-extra:status! (get-news-header-extra header #t) value))

(define (news-header:index header)
  (news-header-extra:index (get-news-header-extra header #f)))

(define (set-news-header:index! header value)
  (set-news-header-extra:index! (get-news-header-extra header #t) value))

(define (news-header:article-deleted! header buffer)
  (if (not (eqv? (news-header:status header) #\I))
      (set-news-header:status! header #\D))
  (news-group:article-deleted! header buffer))

(define (news-header:article-not-deleted! header buffer)
  (set-news-header:status! header #\space)
  (news-group:article-not-deleted! header buffer))

(define (news-header:article-marked! header buffer)
  (if (not (news-header:pre-read-body? header))
      (begin
	(set-news-header:status! header #\M)
	(news-group:article-marked! header buffer))))

(define (news-header:article-browsed! header buffer)
  (news-group:article-browsed! header buffer))

(define (news-header:article-ignored! header buffer)
  (set-news-header:status! header #\I)
  (news-group:article-ignored! header buffer))

(define (news-header:article-not-ignored! header buffer)
  (set-news-header:status! header #\space)
  (news-group:article-not-ignored! header buffer))

(define (news-header:unread? header)
  (and (news-header:real? header)
       (not (news-header:article-deleted? header))))

(define (news-header:next-in-thread header)
  (let scan-down ((header header))
    (let ((children (news-header:followups header)))
      (if (null? children)
	  (let scan-up ((header header))
	    (let ((parent (news-header:followup-to header)))
	      (and parent
		   (let ((tail (memq header (news-header:followups parent))))
		     (if (null? (cdr tail))
			 (scan-up parent)
			 (cadr tail))))))
	  (car children)))))

(define (news-header:previous-in-thread header)
  (let scan-up ((header header))
    (let ((parent (news-header:followup-to header)))
      (and parent
	   (let scan-across
	       ((siblings (news-header:followups parent))
		(prev #f))
	     (cond ((not (eq? (car siblings) header))
		    (scan-across (cdr siblings) (car siblings)))
		   (prev
		    (let dive-down ((header prev))
		      (let ((children (news-header:followups header)))
			(if (null? children)
			    header
			    (dive-down (car (last-pair children)))))))
		   (else parent)))))))

;;;; News-Thread Extensions

(define-integrable news-thread:expanded? news-thread:reader-hook)
(define-integrable set-news-thread:expanded?! set-news-thread:reader-hook!)

(define (news-thread:first-header thread predicate)
  (let ((root (news-thread:root thread)))
    (if (or (not predicate) (predicate root))
	root
	(news-thread:next-header root predicate))))

(define (news-thread:next-header header predicate)
  (let ((header (news-header:next-in-thread header)))
    (if (or (not header) (not predicate) (predicate header))
	header
	(news-thread:next-header header predicate))))

(define (news-thread:previous-header header predicate)
  (let ((header (news-header:previous-in-thread header)))
    (if (or (not header) (not predicate) (predicate header))
	header
	(news-thread:previous-header header predicate))))

(define (news-thread:last-header thread predicate)
  (let ((header (news-thread:first-header thread predicate)))
    (if header
	(let loop ((header (news-thread:first-header thread predicate)))
	  (let ((next (news-thread:next-header header predicate)))
	    (if next
		(loop next)
		header)))
	#f)))

(define (news-thread:for-each-real-header thread procedure)
  (news-thread:for-each-header thread
    (lambda (header)
      (if (news-header:real? header)
	  (procedure header)))))

(define (news-thread:n-articles thread predicate)
  (let loop ((header (news-thread:first-header thread predicate)) (n 0))
    (if header
	(loop (news-thread:next-header header predicate) (+ n 1))
	n)))

(define (news-thread:status thread)
  (let ((root (news-thread:first-header thread news-header:real?)))
    (let ((status (news-header:status root)))
      (let loop ((header root))
	(let ((header (news-thread:next-header header news-header:real?)))
	  (cond ((not header) status)
		((char=? (news-header:status header) status) (loop header))
		((or (char=? status #\I)
		     (char=? (news-header:status header) #\I))
		 #\i)
		((or (char=? status #\M)
		     (char=? (news-header:status header) #\M))
		 #\m)
		(else #\d)))))))

(define (news-thread:pre-read-bodies thread)
  (let loop
      ((header (news-thread:first-header thread news-header:real?))
       (bodies #f))
    (let ((bodies
	   (if (news-header:pre-read-body? header)
	       (case bodies
		 ((#f ALL) 'ALL)
		 ((SOME) 'SOME))
	       (case bodies
		 ((#f) #f)
		 ((SOME ALL) 'SOME)))))
      (let ((header (news-thread:next-header header news-header:real?)))
	(if (not header)
	    bodies
	    (loop header bodies))))))

(define (news-thread:all-articles-deleted? thread)
  (let loop ((header (news-thread:first-header thread news-header:real?)))
    (or (not header)
	(and (news-header:article-deleted? header)
	     (loop (news-thread:next-header header news-header:real?))))))

(define (news-thread:show-collapsed? thread)
  (and (not (news-thread:expanded? thread))
       (let ((header (news-thread:first-header thread news-header:real?)))
	 (and header
	      (news-thread:next-header header news-header:real?)))))

(define (news-thread:clear-indices! thread)
  (news-thread:for-each-header thread
    (lambda (header)
      (set-news-header:index! header #f))))