--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: nntp.scm,v 1.1 1995/05/03 07:51:01 cph Exp $
+;;;
+;;; Copyright (c) 1995 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; NNTP Interface
+
+;;; This program provides a high-level interface to an NNTP server.
+;;; It implements a database abstraction which gives the impression
+;;; that the news database is in memory and can be manipulated
+;;; directly. This abstraction largely hides the underlying server
+;;; communication on which it is built.
+
+;;; The abstraction provides models for the server, each of the groups
+;;; it contains, and the headers in each group. It also provides a
+;;; method for combining headers into conversation threads.
+
+(declare (usual-integrations))
+\f
+;;;; NNTP Connection
+
+(define-structure (nntp-connection
+ (conc-name nntp-connection:)
+ (constructor make-nntp-connection (server)))
+ (server #f read-only #t)
+ (process #f)
+ banner
+ (group-table (make-string-hash-table) read-only #t)
+ (%active-groups #f)
+ (reader-hook #f))
+
+(define (nntp-connection:port connection)
+ (subprocess-i/o-port (nntp-connection:process connection)))
+
+(define (open-nntp-connection server)
+ (let ((connection (make-nntp-connection server)))
+ (nntp-connection:reopen connection)
+ connection))
+
+(define (nntp-connection:reopen connection)
+ (let ((process
+ (let ((program (os/find-program "tcp" #f)))
+ (start-pipe-subprocess program
+ (vector (file-namestring program)
+ (nntp-connection:server connection)
+ "nntp")
+ #f))))
+ (set-nntp-connection:process! connection process)
+ (set-nntp-connection:banner!
+ connection
+ ;; Set up the line translation for the process, because the
+ ;; network line translation is CR-LF regardless of the operating
+ ;; system this program runs on.
+ (input-port/read-line (subprocess-i/o-port process "\r\n")))))
+
+(define (nntp-connection:closed? connection)
+ (let ((port (nntp-connection:port connection)))
+ (or (not port)
+ (input-port/eof? port))))
+
+(define (nntp-connection:close connection)
+ (if (not (nntp-connection:closed? connection))
+ (begin
+ (nntp-write-line connection "quit")
+ (nntp-drain-output connection)))
+ (nntp-flush-input connection)
+ (subprocess-delete (nntp-connection:process connection)))
+
+(define (nntp-connection:active-groups connection)
+ (or (nntp-connection:%active-groups connection)
+ (let ((lines
+ (let ((msg "Reading list of news groups... "))
+ (message msg)
+ (let ((lines (list->vector (nntp-list-command connection))))
+ (message msg "done")
+ lines))))
+ (let ((msg "Parsing list of news groups... "))
+ (message msg)
+ (let ((end (vector-length lines)))
+ (do ((index 0 (fix:+ index 1)))
+ ((fix:= index end))
+ (let ((tokens (string-tokenize (vector-ref lines index))))
+ (let ((group (make-news-group connection (car tokens))))
+ (set-news-group:server-probe!
+ group
+ (let ((last (token->number (cadr tokens)))
+ (first (token->number (caddr tokens))))
+ (vector (- (+ last 1) first)
+ first
+ last)))
+ (vector-set! lines index group)))))
+ (message msg "done")
+ (sort! lines news-group:<)
+ (set-nntp-connection:%active-groups! connection lines)
+ lines))))
+
+(define (nntp-connection:discard-active-groups-cache! connection)
+ (set-nntp-connection:%active-groups! connection #f))
+\f
+;;;; NNTP Commands
+
+(define (nntp-group-command connection group-name)
+ (prepare-nntp-connection connection)
+ (nntp-write-command connection "group" group-name)
+ (nntp-drain-output connection)
+ (let ((response (nntp-read-line connection)))
+ (case (nntp-response-number response)
+ ((211)
+ (let ((tokens (string-tokenize response)))
+ (vector (token->number (cadr tokens))
+ (token->number (caddr tokens))
+ (token->number (cadddr tokens)))))
+ ((411)
+ 'NO-SUCH-GROUP)
+ (else
+ (nntp-error response)))))
+
+;; This says how many pending HEAD requests may be sent before it's
+;; necessary to starting reading the replies, to avoid deadlock.
+(define nntp-maximum-request 400)
+
+(define (nntp-head-request connection key)
+ (nntp-write-command connection "head" key))
+
+(define (nntp-head-reply connection)
+ (let ((response (nntp-read-line connection)))
+ (case (nntp-response-number response)
+ ((221)
+ (let ((tokens (string-tokenize response)))
+ (let ((article-number (cadr tokens))
+ (message-id (caddr tokens)))
+ (if (and (valid-article-number? article-number)
+ (valid-message-id? message-id))
+ (vector article-number
+ message-id
+ (nntp-read-text-lines connection))
+ 'NO-SUCH-ARTICLE))))
+ ((423 430)
+ 'NO-SUCH-ARTICLE)
+ (else
+ (nntp-error response)))))
+
+(define (nntp-body-command connection key port)
+ (prepare-nntp-connection connection)
+ (nntp-write-command connection "body" key)
+ (nntp-drain-output connection)
+ (let ((response (nntp-read-line connection)))
+ (case (nntp-response-number response)
+ ((222)
+ (nntp-read-text-1 connection port)
+ #t)
+ ((423 430)
+ #f)
+ (else
+ (nntp-error response)))))
+
+(define (nntp-list-command connection)
+ (prepare-nntp-connection connection)
+ (nntp-write-command connection "list")
+ (nntp-drain-output connection)
+ (let ((response (nntp-read-line connection)))
+ (if (fix:= 215 (nntp-response-number response))
+ (nntp-read-text-lines connection)
+ (nntp-error response))))
+
+(define (nntp-error response)
+ (error "NNTP error:" response))
+\f
+(define (prepare-nntp-connection connection)
+ (nntp-flush-input connection)
+ (if (nntp-connection:closed? connection)
+ (nntp-connection:reopen connection)))
+
+(define (nntp-flush-input connection)
+ (let ((port (nntp-connection:port connection)))
+ (if port
+ (do ()
+ ((not (input-port/char-ready? port 100)))
+ (input-port/discard-line port)))))
+
+(define (nntp-write-command connection string . strings)
+ (let ((port (nntp-connection:port connection)))
+ (output-port/write-string port string)
+ (do ((strings strings (cdr strings)))
+ ((null? strings))
+ (output-port/write-char port #\space)
+ (output-port/write-string port (car strings)))
+ (output-port/write-char port #\newline)))
+
+(define (nntp-write-line connection string)
+ (let ((port (nntp-connection:port connection)))
+ (output-port/write-string port string)
+ (output-port/write-char port #\newline)))
+
+(define (nntp-drain-output connection)
+ (output-port/flush-output (nntp-connection:port connection)))
+
+(define (nntp-read-line connection)
+ (input-port/read-line (nntp-connection:port connection)))
+
+(define (nntp-response-number line)
+ (if (fix:< (string-length line) 3)
+ (error "Malformed NNTP response:" line))
+ (substring->nonnegative-integer line 0 3))
+
+(define (nntp-read-text connection)
+ (with-string-output-port
+ (lambda (port)
+ (nntp-read-text-1 connection port))))
+
+(define (nntp-read-text-1 connection port)
+ (let loop ()
+ (let ((line (nntp-read-line connection)))
+ (let ((length (string-length line)))
+ (cond ((fix:= 0 length)
+ (output-port/write-char port #\newline)
+ (loop))
+ ((char=? #\. (string-ref line 0))
+ (if (not (fix:= 1 length))
+ (begin
+ (output-port/write-substring port line 1 length)
+ (output-port/write-char port #\newline)
+ (loop))))
+ (else
+ (output-port/write-substring port line 0 length)
+ (output-port/write-char port #\newline)
+ (loop)))))))
+
+(define (nntp-read-text-lines connection)
+ (let loop ((lines '()))
+ (let ((line (nntp-read-line connection)))
+ (let ((length (string-length line)))
+ (cond ((or (fix:= 0 length)
+ (not (char=? #\. (string-ref line 0))))
+ (loop (cons line lines)))
+ ((fix:= 1 length)
+ (reverse! lines))
+ (else
+ (loop (cons (string-tail line 1) lines))))))))
+\f
+;;;; News-Group Data Structure
+
+(define-structure (news-group
+ (conc-name news-group:)
+ (constructor %make-news-group (connection name)))
+ (connection #f read-only #t)
+ (name #f read-only #t)
+ (header-table (make-eqv-hash-table) read-only #t)
+ (server-probe #f)
+ (reader-hook #f))
+
+(define (make-news-group connection name)
+ (let ((table (nntp-connection:group-table connection)))
+ (or (hash-table/get table name #f)
+ (let ((group (%make-news-group connection name)))
+ (hash-table/put! table name group)
+ group))))
+
+(define-integrable (news-group:server group)
+ (nntp-connection:server (news-group:connection group)))
+
+(define (news-group:< x y)
+ (string-ci<? (news-group:name x) (news-group:name y)))
+
+(define (find-news-group connection name)
+ (hash-table/get (nntp-connection:group-table connection) name #f))
+
+(define (find-active-news-group connection name)
+ (let ((table (nntp-connection:group-table connection)))
+ (let ((group (hash-table/get table name #f)))
+ (if group
+ (and (news-group:active? group) group)
+ (and (not (nntp-connection:%active-groups connection))
+ (let ((probe (nntp-group-command connection name)))
+ (and (not (eq? 'NO-SUCH-GROUP probe))
+ (let ((group (%make-news-group connection name)))
+ (set-news-group:server-probe! group probe)
+ (hash-table/put! table name group)
+ group))))))))
+
+(define (news-group:active? group)
+ (news-group:maybe-update-probe! group)
+ (not (eq? 'NO-SUCH-GROUP (news-group:server-probe group))))
+
+(define-integrable (news-group:estimated-n-articles group)
+ (vector-ref (news-group:guarantee-server-probe group) 0))
+
+(define-integrable (news-group:first-article group)
+ (vector-ref (news-group:guarantee-server-probe group) 1))
+
+(define-integrable (news-group:last-article group)
+ (vector-ref (news-group:guarantee-server-probe group) 2))
+
+(define (news-group:guarantee-server-probe group)
+ (news-group:maybe-update-probe! group)
+ (let ((probe (news-group:server-probe group)))
+ (if (eq? 'NO-SUCH-GROUP probe)
+ (error "Unknown news group:" (news-group:name group)))
+ probe))
+
+(define (news-group:maybe-update-probe! group)
+ (if (not (news-group:server-probe group))
+ (news-group:update-probe! group)))
+
+(define (news-group:update-probe! group)
+ (set-news-group:server-probe!
+ group
+ (nntp-group-command (news-group:connection group)
+ (news-group:name group))))
+\f
+;;;; Header Cache
+
+(define (news-group:header group number)
+ (let ((table (news-group:header-table group)))
+ (let ((header (hash-table/get table number #f)))
+ (and (not (eq? 'NONE header))
+ (or header
+ (let ((header (parse-header group (read-header group number))))
+ (hash-table/put! table number (or header 'NONE))
+ header))))))
+
+(define (news-group:headers group numbers)
+ (call-with-values (lambda () (cached-headers group numbers))
+ (lambda (headers numbers)
+ (if (null? numbers)
+ headers
+ (let ((table (news-group:header-table group)))
+ (let loop
+ ((headers headers)
+ (numbers numbers)
+ (responses (read-headers group numbers)))
+ (if (null? responses)
+ headers
+ (loop (let ((header (parse-header group (car responses))))
+ (hash-table/put! table
+ (car numbers)
+ (or header 'NONE))
+ (if header (cons header headers) headers))
+ (cdr numbers)
+ (cdr responses)))))))))
+
+(define (cached-headers group numbers)
+ (let ((table (news-group:header-table group)))
+ (let loop ((numbers numbers) (headers '()) (numbers* '()))
+ (if (null? numbers)
+ (values headers (reverse! numbers*))
+ (let ((header (hash-table/get table (car numbers) #f)))
+ (loop (cdr numbers)
+ (if (or (not header) (eq? 'NONE header))
+ headers
+ (cons header headers))
+ (if (not header)
+ (cons (car numbers) numbers*)
+ numbers*)))))))
+
+(define (news-group:cached-header group number)
+ (hash-table/get (news-group:header-table group) number #f))
+
+(define (news-group:discard-cached-header! group number)
+ (hash-table/remove! (news-group:header-table group) number))
+
+(define (news-group:cached-header-numbers group)
+ (hash-table/key-list (news-group:header-table group)))
+
+(define (news-group:cached-headers group)
+ (hash-table/datum-list (news-group:header-table group)))
+\f
+;;;; Read Headers
+
+(define (read-header group number)
+ (news-group:update-probe! group)
+ (let ((connection (news-group:connection group))
+ (msg "Reading news header... "))
+ (message msg)
+ (prepare-nntp-connection connection)
+ (nntp-head-request connection (number->string number))
+ (let ((response (nntp-head-reply connection)))
+ (message msg "done")
+ response)))
+
+(define (read-headers group numbers)
+ (news-group:update-probe! group)
+ (let ((n-to-read (length numbers))
+ (connection (news-group:connection group))
+ (msg "Reading news headers... ")
+ (n-received 0))
+ (let ((msg? (fix:>= n-to-read 100)))
+
+ (define (send-requests numbers n)
+ (do ((numbers numbers (cdr numbers))
+ (n n (fix:- n 1)))
+ ((fix:= n 0) numbers)
+ (nntp-head-request connection (number->string (car numbers)))))
+
+ (define (receive-replies numbers n responses)
+ (nntp-drain-output connection)
+ (do ((numbers numbers (cdr numbers))
+ (n n (fix:- n 1))
+ (responses responses
+ (cons (nntp-head-reply connection) responses)))
+ ((fix:= n 0) responses)
+ (if (and msg?
+ (begin
+ (set! n-received (fix:+ n-received 1))
+ (fix:= 0 (fix:remainder n-received 20))))
+ (message msg (integer-round (* n-received 100) n-to-read) "%"))))
+
+ (message msg)
+ (prepare-nntp-connection connection)
+ (let loop ((numbers numbers) (n-left n-to-read) (responses '()))
+ (if (null? numbers)
+ (begin
+ (message msg "done")
+ (reverse! responses))
+ (let ((n (min n-left nntp-maximum-request)))
+ (let ((numbers* (send-requests numbers n)))
+ (loop numbers*
+ (fix:- n-left n)
+ (receive-replies numbers n responses)))))))))
+\f
+;;;; Parse Headers
+
+(define (parse-header group response)
+ (and (vector? response)
+ (let ((lines (vector-ref response 2)))
+ (make-news-header group
+ (token->number (vector-ref response 0))
+ (vector-ref response 1)
+ (lines->header-text lines)
+ (parse-header-lines lines)))))
+
+(define (lines->header-text lines)
+ (let ((length
+ (do ((lines lines (cdr lines))
+ (nchars 0 (fix:+ (fix:+ nchars 1) (string-length (car lines)))))
+ ((null? lines) nchars))))
+ (let ((text (make-string length)))
+ (let loop ((lines lines) (index 0))
+ (if (not (null? lines))
+ (loop (cdr lines)
+ (let* ((line (car lines))
+ (end (string-length line)))
+ (do ((i1 0 (fix:+ i1 1))
+ (i2 index (fix:+ i2 1)))
+ ((fix:= i1 end)
+ (string-set! text i2 #\newline)
+ (fix:+ i2 1))
+ (string-set! text i2 (string-ref line i1)))))))
+ text)))
+
+(define (parse-header-lines lines)
+ (cond ((null? lines)
+ '())
+ ((header-line? (car lines))
+ (let ((unfold
+ (lambda (rest)
+ (let ((colon (string-find-next-char (car lines) #\:))
+ (end (string-length (car lines))))
+ (cons (substring-trim (car lines) 0 colon)
+ (let ((value
+ (substring-trim (car lines)
+ (fix:+ colon 1)
+ end)))
+ (if (null? rest)
+ value
+ (apply string-append
+ (cons value
+ (append-map
+ (lambda (string)
+ (list " "
+ (string-trim string)))
+ (reverse! rest)))))))))))
+ (let loop ((lines (cdr lines)) (rest '()))
+ (cond ((null? lines)
+ (list (unfold rest)))
+ ((header-continuation-line? (car lines))
+ (loop (cdr lines) (cons (car lines) rest)))
+ (else
+ (cons (unfold rest) (parse-header-lines lines)))))))
+ (else
+ (parse-header-lines (cdr lines)))))
+
+(define (header-line? line)
+ (and (not (string-null? line))
+ (not (or (char=? #\space (string-ref line 0))
+ (char=? #\tab (string-ref line 0))))
+ (string-find-next-char line #\:)))
+
+(define (header-continuation-line? line)
+ (and (not (string-null? line))
+ (or (char=? #\space (string-ref line 0))
+ (char=? #\tab (string-ref line 0)))
+ (string-find-next-char-in-set line char-set:not-whitespace)))
+\f
+;;;; News-Header Data Structure
+
+(define-structure (news-header
+ (conc-name news-header:)
+ (constructor make-news-header
+ (group number message-id text alist)))
+ (group #f read-only #t)
+ number
+ (message-id #f read-only #t)
+ (text #f read-only #t)
+ (alist #f read-only #t)
+ (followup-to #f)
+ (followups '())
+ (thread #f)
+ (reader-hook #f))
+
+(define (dummy-news-header message-id)
+ (make-news-header #f #f message-id #f '()))
+
+(define (news-header:dummy? header)
+ (not (news-header:text header)))
+
+(define (news-header:field-value header name)
+ (let ((field
+ (list-search-positive (news-header:alist header)
+ (lambda (field)
+ (string-ci=? (car field) name)))))
+ (if field
+ (cdr field)
+ "")))
+
+(define (news-header:< x y)
+ (< (news-header:number x) (news-header:number y)))
+
+(define (news-header:read-body header port)
+ (nntp-body-command (news-group:connection (news-header:group header))
+ (news-header:message-id header)
+ port))
+
+(define (news-header:xref header)
+ (parse-xref-tokens
+ (string-tokenize (news-header:field-value header "xref"))))
+
+(define (parse-xref-tokens tokens)
+ (if (null? tokens)
+ tokens
+ (let ((colon (string-find-next-char (car tokens) #\:))
+ (rest (parse-xref-tokens (cdr tokens))))
+ (if colon
+ (cons (cons (string-head (car tokens) colon)
+ (string-tail (car tokens) (fix:+ colon 1)))
+ rest)
+ rest))))
+
+(define (valid-article-number? string)
+ (let ((end (string-length string)))
+ (and (let loop ((index 0))
+ (and (not (fix:= index end))
+ (or (not (char=? #\0 (string-ref string index)))
+ (loop (fix:+ index 1)))))
+ (let loop ((index 0))
+ (or (fix:= index end)
+ (and (fix:<= (char->integer #\0)
+ (char->integer (string-ref string index)))
+ (fix:<= (char->integer (string-ref string index))
+ (char->integer #\9)))
+ (loop (fix:+ index 1)))))))
+
+(define (valid-message-id? string)
+ (let ((end (string-length string)))
+ (and (fix:> end 2)
+ (char=? #\< (string-ref string 0))
+ (let loop ((index 1))
+ (and (not (fix:= index end))
+ (if (char=? #\> (string-ref string index))
+ (fix:= (fix:+ index 1) end)
+ (and (not (char=? #\space (string-ref string index)))
+ (not (char=? #\< (string-ref string index)))
+ (loop (fix:+ index 1)))))))))
+\f
+;;;; Conversation Threads
+
+;;; This is by far the hairiest part of this implementation. Headers
+;;; are first organized into trees based on their "references" fields.
+;;; The tree structure is reflected in their FOLLOWUP-TO and FOLLOWUPS
+;;; fields. These trees are then gathered into threads by means of
+;;; subject matching. Each resulting thread consists of a list of
+;;; these trees, represented by the tree roots. The list is sorted by
+;;; the header order of the roots.
+
+(define-structure (news-thread
+ (conc-name news-thread:)
+ (constructor make-news-thread (root-headers)))
+ (root-headers #f read-only #t)
+ (reader-hook #f))
+
+(define (news-thread:< x y)
+ (news-header:< (car (news-thread:root-headers x))
+ (car (news-thread:root-headers y))))
+
+(define (news-thread:for-each-header thread procedure)
+ (for-each (letrec ((loop
+ (lambda (header)
+ (procedure header)
+ (for-each loop (news-header:followups header)))))
+ loop)
+ (news-thread:root-headers thread)))
+
+(define (organize-headers-into-threads headers)
+ (build-followup-trees! headers)
+ (sort (map make-threads-equivalent!
+ (let ((threads (associate-threads-with-trees headers)))
+ (for-each (lambda (thread)
+ (for-each guarantee-header-number
+ (news-thread:root-headers thread)))
+ threads)
+ (build-equivalence-classes
+ threads
+ (find-subject-associations threads))))
+ news-thread:<))
+\f
+(define (build-followup-trees! headers)
+ (let ((references (make-eq-hash-table))
+ (dummy-headers '()))
+ (let ((get-refs (lambda (h) (hash-table/get references h '())))
+ (set-refs (lambda (h r) (hash-table/put! references h r))))
+ (let ((id-table (make-string-hash-table)))
+ (for-each (lambda (header)
+ (set-news-header:followup-to! header #f)
+ (set-news-header:followups! header '())
+ (set-news-header:thread! header #f)
+ (set-refs header (news-header:references header))
+ (hash-table/put! id-table
+ (news-header:message-id header)
+ header))
+ headers)
+ (for-each (lambda (header)
+ (do ((refs (get-refs header) (cdr refs)))
+ ((null? refs))
+ (set-car! refs
+ (let ((id (car refs)))
+ (or (hash-table/get id-table id #f)
+ (let ((header (dummy-news-header id)))
+ (hash-table/put! id-table id header)
+ (set! dummy-headers
+ (cons header dummy-headers))
+ header))))))
+ headers))
+ (for-each (lambda (header)
+ (do ((refs (get-refs header) (cdr refs)))
+ ((null? refs))
+ (if (news-header:dummy? (car refs))
+ (let ((drefs (get-refs (car refs))))
+ (if (not (eq? 'BROKEN drefs))
+ (let loop ((x (cdr refs)) (y drefs))
+ (cond ((null? x)
+ unspecific)
+ ((null? y)
+ (set-refs (car refs) (cdr refs)))
+ ((eq? (car x) (car y))
+ (loop (cdr x) (cdr y)))
+ (else
+ (set-refs (car refs) 'BROKEN)))))))))
+ headers)
+ (for-each (lambda (dummy-header)
+ (if (eq? 'BROKEN (get-refs dummy-header))
+ (set-refs dummy-header '())))
+ dummy-headers)
+ (let ((set-followups
+ (lambda (header)
+ (let ((refs (get-refs header)))
+ (if (not (null? refs))
+ (let ((header* (car refs)))
+ (set-news-header:followup-to! header header*)
+ (set-news-header:followups!
+ header*
+ (cons header (news-header:followups header*)))))))))
+ (for-each set-followups headers)
+ (for-each set-followups dummy-headers)))))
+
+(define (news-header:references header)
+ ;; Check the references header field to guarantee that it's
+ ;; well-formed, and discard it entirely if it isn't. This paranoia
+ ;; is reasonable since I've already seen bad references during the
+ ;; first few days of testing.
+ (let ((tokens
+ (reverse-string-tokenize
+ (news-header:field-value header "references"))))
+ (if (let loop ((tokens tokens))
+ (or (null? tokens)
+ (and (valid-message-id? (car tokens))
+ (not (member (car tokens) (cdr tokens)))
+ (loop (cdr tokens)))))
+ tokens
+ '())))
+\f
+(define (associate-threads-with-trees headers)
+ (let ((threads '()))
+ (for-each (lambda (header)
+ (if (not (news-header:thread header))
+ (let ((root
+ (let loop ((header header))
+ (if (news-header:followup-to header)
+ (loop (news-header:followup-to header))
+ header))))
+ (let ((thread (make-news-thread (list root))))
+ (set! threads (cons thread threads))
+ (news-thread:for-each-header thread
+ (lambda (header)
+ (set-news-header:thread! header thread)))))))
+ headers)
+ threads))
+
+(define (guarantee-header-number header)
+ (let ((followups (news-header:followups header)))
+ (for-each guarantee-header-number followups)
+ (set-news-header:followups! header (sort followups news-header:<)))
+ (if (not (news-header:number header))
+ (let ((followups (news-header:followups header)))
+ (if (null? followups)
+ (error "Dummy header has no followups:" header))
+ (set-news-header:number! header
+ (news-header:number (car followups))))))
+\f
+(define (find-subject-associations threads)
+ (let ((subject-alist '()))
+ (for-each (lambda (thread)
+ (news-thread:for-each-header thread
+ (lambda (header)
+ (let ((subject
+ (canonicalize-subject
+ (news-header:field-value header "subject"))))
+ (if (not (string-null? subject))
+ (let ((entry (assoc-subject subject subject-alist)))
+ (cond ((not entry)
+ (set! subject-alist
+ (cons (list subject thread)
+ subject-alist))
+ unspecific)
+ ((not (memq thread (cdr entry)))
+ (set-cdr! entry
+ (cons thread (cdr entry)))))))))))
+ threads)
+ subject-alist))
+
+(define (canonicalize-subject subject)
+ ;; This is optimized by assuming that the subject lines have no
+ ;; leading or trailing white space. The news-header parser makes
+ ;; that guarantee.
+ (let ((end (string-length subject)))
+ (substring subject
+ (let loop ((start 0))
+ (if (substring-prefix-ci? "re:" 0 3 subject start end)
+ (loop (substring-skip-leading-space subject
+ (fix:+ start 3)
+ end))
+ start))
+ end)))
+
+(define (assoc-subject subject alist)
+ (let loop ((alist alist))
+ (and (not (null? alist))
+ (let ((comparison (compare-subjects subject (caar alist))))
+ (if comparison
+ (begin
+ (if (eq? 'LEFT-PREFIX comparison)
+ (set-car! (car alist) subject))
+ (car alist))
+ (loop (cdr alist)))))))
+
+(define (compare-subjects x y)
+ (let ((xe (string-length x))
+ (ye (string-length y)))
+ (let ((i (substring-match-forward-ci x 0 xe y 0 ye)))
+ (if (fix:= i xe)
+ (if (fix:= i ye) 'EQUAL 'LEFT-PREFIX)
+ (if (fix:= i ye) 'RIGHT-PREFIX #f)))))
+\f
+(define (build-equivalence-classes threads subject-alist)
+ (let ((equivalences (make-eq-hash-table)))
+ (for-each (lambda (thread)
+ (hash-table/put! equivalences
+ thread
+ (let ((t (list thread)))
+ (set-cdr! t (list t))
+ t)))
+ threads)
+ (let ((equivalence!
+ (lambda (x y)
+ (let ((x (hash-table/get equivalences x #f))
+ (y (hash-table/get equivalences y #f)))
+ (if (not (eq? (cdr x) (cdr y)))
+ (let ((k
+ (lambda (x y)
+ (for-each (lambda (y) (set-cdr! y x)) y)
+ (set-cdr! (last-pair x) y))))
+ (if (news-thread:< (car x) (car y))
+ (k (cdr x) (cdr y))
+ (k (cdr y) (cdr x)))))))))
+ (for-each (lambda (entry)
+ (let ((thread (cadr entry)))
+ (for-each (lambda (thread*) (equivalence! thread thread*))
+ (cddr entry))))
+ subject-alist))
+ (map (lambda (class) (map car class))
+ (eliminate-duplicates
+ (map cdr (hash-table/datum-list equivalences))))))
+
+(define (eliminate-duplicates items)
+ (let loop ((items items) (result '()))
+ (if (null? items)
+ result
+ (loop (cdr items)
+ (if (memq (car items) result)
+ result
+ (cons (car items) result))))))
+
+(define (make-threads-equivalent! threads)
+ (let ((threads (sort threads news-thread:<)))
+ (let ((thread (car threads))
+ (threads (cdr threads)))
+ (for-each (lambda (thread*)
+ (news-thread:for-each-header thread*
+ (lambda (header)
+ (set-news-header:thread! header thread))))
+ threads)
+ (set-cdr! (news-thread:root-headers thread)
+ (map (lambda (thread)
+ (car (news-thread:root-headers thread)))
+ threads))
+ thread)))
+\f
+;;;; Miscellaneous
+
+(define (input-port/read-line port)
+ (let ((line (input-port/read-string port char-set:newline)))
+ ;; Discard delimiter, if any -- this is a no-op at EOF.
+ (input-port/discard-char port)
+ line))
+
+(define (input-port/discard-line port)
+ (input-port/discard-chars port char-set:newline)
+ (input-port/discard-char port))
+
+(define char-set:newline (char-set #\newline))
+
+(define (input-port/eof? port)
+ ((or (port/operation port 'EOF?) (error "Port missing EOF? operation:" port))
+ port))
+
+(define (string-tokenize string)
+ (substring-tokenize string 0 (string-length string)))
+
+(define (substring-tokenize string start end)
+ (reverse! (reverse-substring-tokenize string start end)))
+
+(define (reverse-string-tokenize string)
+ (reverse-substring-tokenize string 0 (string-length string)))
+
+(define (reverse-substring-tokenize string start end)
+ (let loop ((start start) (tokens '()))
+ (if (fix:= start end)
+ tokens
+ (let ((delimiter
+ (or (substring-find-next-char-in-set
+ string start end char-set:whitespace)
+ end)))
+ (loop (or (substring-find-next-char-in-set
+ string delimiter end char-set:not-whitespace)
+ end)
+ (cons (substring string start delimiter) tokens))))))
+
+(define (token->number token)
+ (substring->nonnegative-integer token 0 (string-length token)))
+
+(define (substring->nonnegative-integer line start end)
+ (let ((get-digit
+ (lambda (index)
+ (let ((n
+ (fix:- (char->integer (string-ref line index))
+ (char->integer #\0))))
+ (if (or (fix:< n 0) (fix:> n 9))
+ (error:bad-range-argument line #f))
+ n))))
+ (let loop ((index start) (n 0))
+ (if (fix:= index end)
+ n
+ (loop (fix:+ index 1)
+ (+ (* n 10) (get-digit index)))))))
+
+(define (substring-skip-leading-space string start end)
+ (let loop ((index start))
+ (if (and (fix:< index end)
+ (or (char=? #\space (string-ref string index))
+ (char=? #\tab (string-ref string index))))
+ (loop (fix:+ index 1))
+ index)))
+
+(define (substring-skip-trailing-space string start end)
+ (let loop ((index end))
+ (if (fix:< start index)
+ (let ((index* (fix:- index 1)))
+ (if (or (char=? #\space (string-ref string index*))
+ (char=? #\tab (string-ref string index*)))
+ (loop index*)
+ index))
+ index)))
+
+(define (substring-trim string start end)
+ (let ((start (substring-skip-leading-space string start end)))
+ (substring string start (substring-skip-trailing-space string start end))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: snr.scm,v 1.1 1995/05/03 07:50:49 cph Exp $
+;;;
+;;; Copyright (c) 1995 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Scheme News Reader
+
+(declare (usual-integrations))
+
+(load-option 'ORDERED-VECTOR)
+\f
+(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-show-domain
+ "Switch controlling appearance of server name in news buffers.
+The buffers used by the News reader contain the server name. If this
+switch is false (the default), the server's domain is suppressed
+before forming the buffer name. Otherwise, the full server name is
+used."
+ #f
+ boolean?)
+
+(define-variable show-unsubscribed-news-groups
+ "Switch controlling whether unsubscribed news groups appear in news buffers.
+If false (the default), only currently subscribed groups are shown.
+If true, previously subscribed buffers are also shown."
+ #f
+ boolean?)
+
+(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 the that server, its buffer is selected."
+ "P"
+ (lambda (prompt?)
+ (select-buffer
+ (let ((server
+ (let ((server (ref-variable news-server #f)))
+ (if (or prompt? (string-null? server))
+ (prompt-for-news-server "News server")
+ server))))
+ (or (find-news-server-buffer server)
+ (make-news-server-buffer 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-command news-kill-current-buffer
+ "Kill the current buffer."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (let ((parent (buffer-tree:parent buffer #f)))
+ (if parent
+ (select-buffer parent)))
+ (kill-buffer buffer))))
+
+(define-command news-next-line
+ "Move down one or more lines and put point at start of line."
+ "P"
+ (lambda (argument)
+ (set-current-point! (line-start (current-point) 0))
+ ((ref-command next-line) argument)))
+
+(define-command news-previous-line
+ "Move up one or more lines and put point at start of line."
+ "p"
+ (lambda (argument)
+ (set-current-point! (line-start (current-point) 0))
+ ((ref-command previous-line) argument)))
+\f
+;;;; News-Server Buffer
+
+(define (find-news-server-buffer server)
+ (let ((buffer
+ (list-search-positive (buffer-list)
+ (lambda (buffer)
+ (and (news-server-buffer? buffer)
+ (string-ci=? (news-server-buffer:server buffer) server))))))
+ (and buffer
+ (begin
+ (news-server-buffer:guarantee-connection buffer)
+ buffer))))
+
+(define (make-news-server-buffer server)
+ (let ((buffer (new-buffer (news-server-buffer-name server))))
+ (set-buffer-major-mode! buffer (ref-mode-object news-server))
+ (disable-group-undo! (buffer-group buffer))
+ (add-kill-buffer-hook buffer news-server-buffer:kill)
+ (news-server-buffer:open-connection buffer server)
+ (let ((groups
+ (sort (get-ini-file-groups (news-server-buffer:connection buffer))
+ news-group:<)))
+ (for-each news-group:update-ranges! groups)
+ (initialize-buffer-news-groups buffer groups))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)
+ (set-buffer-read-only! buffer)
+ buffer))
+
+(define (news-server-buffer-name server)
+ (string-append (if (ref-variable news-server-show-domain #f)
+ server
+ (let ((dot (string-find-next-char server #\.)))
+ (if dot
+ (string-head server dot)
+ server)))
+ ":news"))
+
+(define (news-server-buffer:kill buffer)
+ (news-server-buffer:save-groups buffer)
+ (news-server-buffer:close-connection buffer)
+ (for-each kill-buffer (buffer-tree:children buffer)))
+
+(define (news-server-buffer:save-groups buffer)
+ (put-ini-file-groups (news-server-buffer:connection buffer)
+ (buffer-news-groups buffer)))
+\f
+(define (news-server-buffer? buffer)
+ (buffer-get buffer 'NNTP-CONNECTION #f))
+
+(define (news-server-buffer:open-connection buffer server)
+ (let ((msg (string-append "Opening connection to " server "... ")))
+ (message msg)
+ (buffer-put! buffer 'NNTP-CONNECTION (open-nntp-connection server))
+ (message msg "done")))
+
+(define (news-server-buffer:guarantee-connection buffer)
+ (let ((connection (news-server-buffer:connection buffer)))
+ (if (nntp-connection:closed? connection)
+ (let ((msg
+ (string-append "Reopening connection to "
+ (nntp-connection:server connection)
+ "... ")))
+ (message msg)
+ (nntp-connection:reopen connection)
+ (message msg "done")))))
+
+(define (news-server-buffer:close-connection buffer)
+ (let ((connection (buffer-get buffer 'NNTP-CONNECTION)))
+ (if connection
+ (let ((msg
+ (string-append "Closing connection to "
+ (nntp-connection:server connection)
+ "... ")))
+ (message msg)
+ (nntp-connection:close connection)
+ (message msg "done")))))
+
+(define (news-server-buffer:connection buffer)
+ (let ((connection (buffer-get buffer 'NNTP-CONNECTION #f)))
+ (if (not connection)
+ (error "Buffer has no NNTP connection:" (buffer-name buffer)))
+ connection))
+
+(define (news-server-buffer:server buffer)
+ (nntp-connection:server (news-server-buffer:connection buffer)))
+\f
+(define (initialize-buffer-news-groups buffer groups)
+ (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
+ (for-each (lambda (group)
+ (if (show-buffer-news-group? buffer group)
+ (begin
+ (insert-news-group-line group mark)
+ (insert-newline mark))))
+ groups)
+ (mark-temporary! mark))
+ (let loop ((start (buffer-start buffer)) (groups groups))
+ (if (not (null? groups))
+ (if (show-buffer-news-group? buffer (car groups))
+ (let ((end (line-start start 1 'ERROR))
+ (group (car groups)))
+ (region-put! start end 'NEWS-GROUP group)
+ (loop end (cdr groups)))
+ (loop start (cdr groups)))))
+ (buffer-put! buffer 'NEWS-GROUPS groups))
+
+(define (buffer-news-groups buffer)
+ (buffer-get buffer 'NEWS-GROUPS '()))
+
+(define (buffer-news-group-mark buffer group error?)
+ (or (find-buffer-line buffer group 'NEWS-GROUP news-group:<)
+ (and error?
+ (error "Buffer has no line for this group:" group buffer))))
+
+(define (add-buffer-news-group buffer group)
+ (let loop ((groups (buffer-news-groups buffer)) (prev #f))
+ (cond ((or (null? groups)
+ (news-group:< group (car groups)))
+ (let ((groups (cons group groups)))
+ (if prev
+ (set-cdr! prev groups)
+ (buffer-put! buffer 'NEWS-GROUPS groups))))
+ ((not (eq? group (car groups)))
+ (loop (cdr groups) groups)))))
+\f
+(define (maybe-update-buffer-news-group buffer group)
+ (if (memq group (buffer-news-groups buffer))
+ (update-buffer-news-group buffer group)))
+
+(define (update-buffer-news-group buffer group)
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((mark (buffer-news-group-mark buffer group #f)))
+ (if mark
+ (if (show-buffer-news-group? buffer group)
+ (let ((start (mark-right-inserting-copy mark))
+ (end (mark-left-inserting-copy mark))
+ (point (buffer-point buffer)))
+ (let ((le (line-end end 0)))
+ (let ((column
+ (and (mark<= end point)
+ (mark<= point le)
+ (mark-column point))))
+ (delete-string end le)
+ (insert-news-group-line group end)
+ (if column
+ (set-buffer-point! buffer
+ (move-to-column start column)))))
+ (region-put! start (mark1+ end) 'NEWS-GROUP group)
+ (mark-temporary! end)
+ (mark-temporary! start))
+ (delete-string mark (line-start mark 1 'ERROR)))
+ (if (show-buffer-news-group? buffer group)
+ (let ((mark
+ (let ((tail (memq group (buffer-news-groups buffer))))
+ (if (null? (cdr tail))
+ (buffer-end buffer)
+ (buffer-news-group-mark buffer (cadr tail) #t)))))
+ (let ((start (mark-right-inserting-copy mark))
+ (end (mark-left-inserting-copy mark)))
+ (insert-news-group-line group end)
+ (insert-newline end)
+ (region-put! start end 'NEWS-GROUP group)
+ (mark-temporary! end)
+ (mark-temporary! start)))))))))
+
+(define (show-buffer-news-group? buffer group)
+ (and (news-group:active? group)
+ (or (news-group:subscribed? group)
+ (ref-variable show-unsubscribed-news-groups buffer))))
+
+(define (insert-news-group-line group mark)
+ (insert-string (if (news-group:subscribed? group) " " "U ") mark)
+ (insert-string-pad-left
+ (number->string (news-group:number-of-articles group))
+ 5 #\space mark)
+ (insert-string ": " mark)
+ (insert-string (news-group:name group) mark))
+\f
+;;;; News-Server Mode
+
+(define-major-mode news-server read-only "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.
+
+This mode's commands include:
+
+\\[all-news-groups] select a buffer showing all of the server's News groups
+\\[select-news-group] browse articles in the News group indicated by point
+\\[subscribe-news-group] subscribe to the News group indicated by point
+\\[unsubscribe-news-group] unsubscribe from the News group indicated by point")
+
+(define-key 'news-server #\space 'select-news-group)
+(define-key 'news-server #\a 'all-news-groups)
+(define-key 'news-server #\g 'refresh-news-groups)
+(define-key 'news-server #\q 'news-kill-current-buffer)
+(define-key 'news-server #\r 'refresh-news-group)
+(define-key 'news-server #\s 'subscribe-news-group)
+(define-key 'news-server #\S 'subscribe-news-group-by-name)
+(define-key 'news-server #\u 'unsubscribe-news-group)
+(define-key 'news-server #\c-n 'news-next-line)
+(define-key 'news-server #\c-p 'news-previous-line)
+(define-key 'news-server '(#\c-x #\c-s) 'save-news-server-data)
+
+(define-command select-news-group
+ "Browse the News group indicated by point.
+Selects a buffer showing the subject lines of the articles in the News group."
+ ()
+ (lambda ()
+ (let ((buffer
+ (let ((server-buffer (current-news-server-buffer))
+ (group (current-news-group)))
+ (or (find-news-group-buffer server-buffer group)
+ (make-news-group-buffer server-buffer group)))))
+ (select-buffer buffer)
+ (news-group-buffer:update-server-buffer buffer))))
+
+(define-command refresh-news-groups
+ "Update the unread-message estimates for all of the News groups shown.
+This will take a long time if done in the all-groups buffer."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (for-each
+ (lambda (group)
+ (if (show-buffer-news-group? buffer group)
+ (begin
+ (news-group:update-ranges! group)
+ (update-buffer-news-group buffer group))))
+ (buffer-news-groups buffer)))))
+
+(define-command refresh-news-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)
+ (news-group-command argument
+ (let ((buffer (current-buffer)))
+ (lambda (group)
+ (news-group:update-ranges! group)
+ (update-buffer-news-group buffer group))))))
+\f
+(define-command subscribe-news-group
+ "Subscribe to the News group indicated by point.
+Normally useful only in the all-groups buffer, since the server buffer
+doesn't show unsubscribed groups.
+With prefix argument, subscribes to the next several News groups."
+ "P"
+ (lambda (argument)
+ (news-group-command argument
+ (make-news-group-subscriber (current-buffer)))))
+
+(define-command subscribe-news-group-by-name
+ "Subscribe to a News group by name.
+Prompts for the News-group name, with completion."
+ ()
+ (lambda ()
+ ((make-news-group-subscriber (current-buffer))
+ (prompt-for-active-news-group "Subscribe to news group"
+ #f
+ (current-news-server-buffer)))))
+
+(define (make-news-group-subscriber buffer)
+ (let ((server-buffer (news-server-buffer buffer)))
+ (let ((all-groups (find-all-news-groups-buffer server-buffer)))
+ (lambda (group)
+ (set-news-group:subscribed?! group #t)
+ (add-buffer-news-group server-buffer group)
+ (update-buffer-news-group buffer group)
+ (cond ((not (eq? buffer server-buffer))
+ (update-buffer-news-group server-buffer group))
+ ((and all-groups (not (eq? buffer all-groups)))
+ (update-buffer-news-group all-groups group)))))))
+
+(define-command unsubscribe-news-group
+ "Unsubscribe from the News group indicated by point.
+With prefix argument, unsubscribes from the next several News groups."
+ "P"
+ (lambda (argument)
+ (news-group-command argument
+ (let ((buffer (current-buffer)))
+ (let ((server-buffer (news-server-buffer buffer)))
+ (let ((all-groups (find-all-news-groups-buffer server-buffer)))
+ (lambda (group)
+ (set-news-group:subscribed?! group #f)
+ (update-buffer-news-group buffer group)
+ (cond ((not (eq? buffer server-buffer))
+ (maybe-update-buffer-news-group server-buffer group))
+ ((and all-groups (not (eq? buffer all-groups)))
+ (update-buffer-news-group all-groups group))))))))))
+
+(define-command all-news-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.
+
+Making this buffer for the first time can be slow."
+ ()
+ (lambda ()
+ (select-buffer
+ (let ((server-buffer (current-news-server-buffer)))
+ (or (find-all-news-groups-buffer server-buffer)
+ (make-all-news-groups-buffer server-buffer))))))
+
+(define-command save-news-server-data
+ "Update the \"snr.ini\" file with current data."
+ ()
+ (lambda ()
+ (news-server-buffer:save-groups (current-news-server-buffer))))
+\f
+(define (current-news-server-buffer)
+ (news-server-buffer (current-buffer)))
+
+(define (news-server-buffer buffer)
+ (if (news-server-buffer? buffer)
+ buffer
+ (buffer-tree:parent buffer #t)))
+
+(define (current-news-group)
+ (current-property-item 'NEWS-GROUP "news-group"))
+
+(define (news-group-command argument procedure)
+ (repeating-command argument procedure 'NEWS-GROUP "news-group"))
+
+(define (prompt-for-active-news-group prompt default server-buffer)
+ (let ((connection (news-server-buffer:connection server-buffer)))
+ (let ((groups (lambda () (nntp-connection:active-groups connection)))
+ (string->group
+ (lambda (string) (find-active-news-group connection string))))
+ (string->group
+ (let ((convert
+ (lambda (vector) (map news-group:name (vector->list vector)))))
+ (prompt-for-completed-string prompt default 'VISIBLE-DEFAULT
+ (lambda (string if-unique if-not-unique if-not-found)
+ (ordered-vector-minimum-match (groups) string news-group:name
+ string-order (prefix-matcher string)
+ (lambda (group)
+ (if-unique (news-group:name group)))
+ (lambda (group gcm all-matches)
+ (if-not-unique (string-head (news-group:name group) gcm)
+ (lambda () (convert (all-matches)))))
+ if-not-found))
+ (lambda (string)
+ (convert
+ (ordered-vector-matches (groups) string news-group:name
+ string-order (prefix-matcher string))))
+ string->group
+ #t))))))
+
+(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)))))
+\f
+;;;; All-Groups Buffer
+
+(define (find-all-news-groups-buffer server-buffer)
+ (buffer-tree:child server-buffer 'ALL-NEWS-GROUPS #f))
+
+(define (make-all-news-groups-buffer server-buffer)
+ (let ((buffer
+ (new-buffer
+ (string-append "all-groups:"
+ (news-server-buffer-name
+ (news-server-buffer:server server-buffer))))))
+ (set-buffer-major-mode! buffer (ref-mode-object news-server))
+ (local-set-variable! show-unsubscribed-news-groups #t buffer)
+ (disable-group-undo! (buffer-group buffer))
+ (let ((groups
+ (nntp-connection:active-groups
+ (news-server-buffer:connection server-buffer))))
+ (let ((msg "Building all-groups buffer... "))
+ (message msg)
+ (initialize-buffer-news-groups buffer (vector->list groups))
+ (message msg "done")))
+ (buffer-tree:attach-child! server-buffer 'ALL-NEWS-GROUPS buffer)
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)
+ (set-buffer-read-only! buffer)
+ buffer))
+\f
+;;;; 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)
+ (let ((buffer (new-buffer (news-group-buffer-name group))))
+ (set-buffer-major-mode! buffer (ref-mode-object news-group))
+ (disable-group-undo! (buffer-group 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 #f)
+ (set-buffer-read-only! buffer)
+ buffer))
+
+(define (news-group-buffer-name group)
+ (string-append (news-group:name group)
+ ":"
+ (news-server-buffer-name (news-group:server group))))
+
+(define (news-group-buffer:kill buffer)
+ (news-group-buffer:update-server-buffer buffer)
+ (let ((group (get-buffer-property buffer 'NEWS-GROUP)))
+ (for-each
+ (lambda (header)
+ (if (not (news-header:article-unseen? header))
+ (news-group:discard-cached-header! group
+ (news-header:number header))))
+ (news-group:cached-headers group))))
+
+(define (news-group-buffer:select group-buffer window)
+ (news-group-buffer:delete-context-window group-buffer window))
+
+(define (initialize-news-group-buffer buffer all?)
+ (fill-news-group-buffer
+ buffer
+ (let ((group (get-buffer-property buffer 'NEWS-GROUP)))
+ (news-group:headers
+ group
+ (ranges->list
+ (complement-ranges (if all? '() (news-group:ranges-seen group))
+ (news-group:first-article group)
+ (news-group:last-article group))))))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer))
+\f
+(define (fill-news-group-buffer buffer headers)
+ (let ((mark (mark-left-inserting-copy (buffer-end buffer)))
+ (subject #f)
+ (line 0)
+ (lines '()))
+ (for-each
+ (lambda (thread)
+ (let insert-headers
+ ((headers (news-thread:root-headers thread))
+ (indentation 0))
+ (for-each
+ (lambda (header)
+ (if (news-header:dummy? header)
+ (insert-headers (news-header:followups header) indentation)
+ (let* ((subject*
+ (canonicalize-subject
+ (news-header:field-value header "subject"))))
+ (let ((comparison
+ (and subject (compare-subjects subject subject*))))
+ (insert-news-header-line header
+ indentation
+ (not comparison)
+ mark)
+ (if (or (not comparison)
+ (eq? 'RIGHT-PREFIX comparison))
+ (set! subject subject*)))
+ (set-news-header:line-number! header line)
+ (set! line (fix:+ line 1))
+ (set! lines (cons header lines))
+ (insert-headers (news-header:followups header)
+ (+ indentation 4)))))
+ headers)))
+ (organize-headers-into-threads headers))
+ (mark-temporary! mark)
+ (buffer-put! buffer 'NEWS-HEADERS (list->vector (reverse! lines)))))
+
+(define (insert-news-header-line header indentation subject? mark)
+ (let ((start (mark-right-inserting-copy mark)))
+ (insert-char (news-header:status header) mark)
+ (insert-char #\space mark)
+ (insert-string-pad-left (news-header:field-value header "lines")
+ 4 #\space mark)
+ (insert-char #\: mark)
+ (insert-chars #\space indentation mark)
+ (if subject?
+ (begin
+ (insert-char #\space mark)
+ (insert-string (news-header:field-value header "subject") mark)))
+ (insert-string " (" mark)
+ (insert-string (let ((from (news-header:field-value header "from")))
+ (or (rfc822-first-address from)
+ from))
+ mark)
+ (insert-char #\) mark)
+ (insert-newline mark)
+ (region-put! start mark 'NEWS-HEADER header)
+ (mark-temporary! start)))
+
+(define (buffer-news-headers buffer)
+ (buffer-get buffer 'NEWS-HEADERS '#()))
+
+(define (buffer-news-header-mark buffer header error?)
+ (or (find-buffer-line buffer header 'NEWS-HEADER
+ (lambda (x y)
+ (fix:< (news-header:line-number x)
+ (news-header:line-number y))))
+ (and error?
+ (error "Buffer has no line for this header:" header buffer))))
+\f
+(define (update-buffer-news-header-status buffer header)
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((mark
+ (mark-right-inserting-copy
+ (buffer-news-header-mark buffer header #t))))
+ (let ((preserve-point? (mark= (buffer-point buffer) mark)))
+ (delete-right-char mark)
+ (insert-char (news-header:status header) mark)
+ ;; Grumble: must rewrite 'NEWS-HEADER property because
+ ;; inserted characters have no properties.
+ (region-put! mark (mark1+ mark) 'NEWS-HEADER header)
+ (if preserve-point? (set-buffer-point! buffer mark))
+ (mark-temporary! mark))))))
+
+(define (news-group-buffer:update-server-buffer buffer)
+ (let ((group (get-buffer-property buffer 'NEWS-GROUP)))
+ (news-group:update-ranges! group)
+ (let ((server-buffer (buffer-tree:parent buffer #f)))
+ (if server-buffer
+ (update-buffer-news-group server-buffer group)))))
+
+(define (show-news-article-context article-window context-lines)
+ (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-in-window group-buffer context-window #t)
+ (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)))
+ (begin
+ (window-delete! context-window window)
+ (buffer-remove! group-buffer 'CONTEXT-WINDOW)))))
+
+(define (news-group-buffer:set-point! group-buffer mark)
+ (set-buffer-point! 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-visible? window)
+ (or (not require-buffer?)
+ (eq? buffer (window-buffer window)))
+ window))))
+ (if (not window)
+ (buffer-remove! buffer 'CONTEXT-WINDOW))
+ window))))
+\f
+;;;; News-Group Mode
+
+(define-major-mode news-group read-only "News Group"
+ "Major mode for browsing subjects of articles in a News group.
+Each line shows one of the articles in the group. The number near the
+left is an estimate of the number of lines in the article. 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. In
+such threads, the subjects of followup articles are suppressed, and
+the parenthesized author's name appears indented. The indentation
+shows structure of the conversation, with followups being indented a
+bit more than the articles they follow-up to.
+
+This mode's commands include:
+
+\\[select-news-article] select a buffer containing the article indicated by point
+\\[delete-news-article] mark the article indicated by point as read
+\\[delete-news-thread] mark the whole thread as read
+\\[undelete-news-article] unmark the article indicated by point
+\\[undelete-news-thread] unmark the whole thread
+\\[expunge-news-group] remove from the buffer all marked lines"
+ (lambda (buffer)
+ (local-set-variable! truncate-lines #t buffer)))
+
+(define-key 'news-group #\space 'select-news-article)
+(define-key 'news-group #\c 'catch-up-news-group)
+(define-key 'news-group #\d 'delete-news-article)
+(define-key 'news-group #\D 'delete-news-thread)
+(define-key 'news-group #\g 'revert-news-group)
+(define-key 'news-group #\q 'news-kill-current-buffer)
+(define-key 'news-group #\u 'undelete-news-article)
+(define-key 'news-group #\U 'undelete-news-thread)
+(define-key 'news-group #\x 'expunge-news-group)
+(define-key 'news-group #\c-n 'news-next-line)
+(define-key 'news-group #\c-p 'news-previous-line)
+(define-key 'news-server '(#\c-x #\c-s) 'save-news-server-data)
+
+(define-command select-news-article
+ "Select a buffer containing the News article indicated by point."
+ ()
+ (lambda ()
+ (select-news-article (current-buffer) (current-news-header))))
+
+(define (select-news-article group-buffer header)
+ (select-buffer
+ (or (find-news-article-buffer group-buffer header)
+ (make-news-article-buffer group-buffer header)
+ (editor-error "Article no longer available from server."))))
+\f
+(define-command delete-news-article
+ "Mark as `read' the News article indicated by point.
+With prefix argument, marks the next several articles."
+ "P"
+ (lambda (argument)
+ (news-header-command argument (header-deletion-procedure))))
+
+(define-command delete-news-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."
+ ()
+ (lambda ()
+ (let ((root (news-header:thread (current-news-header))))
+ (news-thread:for-each-header root (header-deletion-procedure))
+ (set-current-point!
+ (find-next-header-line (line-start (current-point) 0)
+ (lambda (header)
+ (not (eq? root (news-header:thread header)))))))))
+
+(define (header-deletion-procedure)
+ (let ((buffer (current-buffer)))
+ (lambda (header)
+ (if (not (news-header:dummy? header))
+ (begin
+ (news-header:article-seen! header)
+ (update-buffer-news-header-status buffer header))))))
+
+(define-command undelete-news-article
+ "Unmark the News article indicated by point.
+With prefix argument, unmarks the next several articles."
+ "P"
+ (lambda (argument)
+ (news-header-command argument (header-undeletion-procedure))))
+
+(define-command undelete-news-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."
+ ()
+ (lambda ()
+ (let ((root (news-header:thread (current-news-header))))
+ (news-thread:for-each-header root (header-undeletion-procedure))
+ (set-current-point!
+ (find-next-header-line (line-start (current-point) 0)
+ (lambda (header)
+ (not (eq? root (news-header:thread header)))))))))
+
+(define (header-undeletion-procedure)
+ (let ((buffer (current-buffer)))
+ (lambda (header)
+ (if (not (news-header:dummy? header))
+ (begin
+ (news-header:article-unseen! header)
+ (update-buffer-news-header-status buffer header))))))
+
+(define-command expunge-news-group
+ "Remove all marked lines from the current buffer."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (with-buffer-open buffer
+ (lambda ()
+ (let loop ((mark (buffer-absolute-start buffer)))
+ (if (not (group-end? mark))
+ (if (news-header:article-unseen? (get-news-header mark))
+ (loop (line-start mark 1 'ERROR))
+ (let ((mark (mark-right-inserting-copy mark)))
+ (delete-string mark (line-start mark 1 'ERROR))
+ (mark-temporary! mark)
+ (loop mark))))))))))
+\f
+(define-command catch-up-news-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 (current-buffer)))
+ (for-each-vector-element (buffer-news-headers buffer)
+ news-header:article-seen!))
+ ((ref-command news-kill-current-buffer))))))
+
+(define-command revert-news-group
+ "Refresh the article list from the News server.
+This gets any new article headers from the News server, adding their
+lines to the current buffer. With a prefix argument, this shows all
+of the articles in the News group, including those that were
+previously marked as `read'."
+ "P"
+ (lambda (argument)
+ (let ((buffer (current-buffer)))
+ (with-buffer-open buffer
+ (lambda ()
+ (region-delete! (buffer-region buffer))
+ (initialize-news-group-buffer buffer argument))))))
+
+(define (find-next-header-line ls predicate)
+ (if (group-end? ls)
+ ls
+ (let loop ((ls (line-start ls 1 'ERROR)))
+ (if (or (let ((header (region-get ls 'NEWS-HEADER #f)))
+ (or (not header)
+ (predicate header)))
+ (group-end? ls))
+ ls
+ (loop (line-start ls 1 'ERROR))))))
+
+(define (find-previous-header-line ls predicate)
+ (if (group-start? ls)
+ ls
+ (let loop ((ls (line-start ls -1 'ERROR)))
+ (if (or (let ((header (region-get ls 'NEWS-HEADER #f)))
+ (or (not header)
+ (predicate header)))
+ (group-start? ls))
+ ls
+ (loop (line-start ls -1 'ERROR))))))
+
+(define (next-unseen-header-line ls)
+ (find-next-header-line ls news-header:article-unseen?))
+
+(define (previous-unseen-header-line ls)
+ (find-previous-header-line ls news-header:article-unseen?))
+
+(define (current-news-header)
+ (current-property-item 'NEWS-HEADER "article header"))
+
+(define (news-header-command argument procedure)
+ (repeating-command argument procedure 'NEWS-HEADER "article header"))
+
+(define (get-news-header mark)
+ (property-item mark 'NEWS-HEADER "news header"))
+\f
+;;;; 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)
+ (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)
+ (buffer-tree:attach-child! group-buffer header buffer)
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)
+ (set-buffer-read-only! buffer)
+ (news-header:article-seen! header)
+ (update-buffer-news-header-status group-buffer header)
+ buffer)
+ (begin
+ (kill-buffer buffer)
+ (news-header:article-seen! header)
+ (update-buffer-news-header-status group-buffer header)
+ #f))))
+
+(define (insert-news-header header buffer truncate?)
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((hend (mark-left-inserting-copy (buffer-start buffer))))
+ (insert-string (news-header:text header) 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 (delete-ignored-headers hstart hend)
+ (let ((regexp (ref-variable rmail-ignored-headers hstart)))
+ (if regexp
+ (let ((point (mark-right-inserting-copy hstart))
+ (group (mark-group hstart))
+ (p1 (re-compile-pattern regexp #t))
+ (p2 (re-compile-pattern "\n[^ \t]" #f)))
+ (do ()
+ ((not (re-search-buffer-forward p1 #t #f
+ group
+ (mark-index point)
+ (mark-index hend))))
+ (move-mark-to! point (line-start (re-match-start 0) 0))
+ (delete-string
+ point
+ (make-mark group
+ (fix:- (re-search-buffer-forward p2 #f #f
+ group
+ (mark-index point)
+ (mark-index hend))
+ 1))))
+ (mark-temporary! point)))))
+
+(define (delete-news-header buffer)
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((mark (search-forward "\n\n" (buffer-start buffer))))
+ (if (not mark)
+ (error "Can't find end of news article header:" buffer))
+ (delete-string (buffer-start buffer) mark)))))
+
+(define (news-article-buffer-name header)
+ (string-append (number->string (news-header:number header))
+ ":"
+ (news-group-buffer-name (news-header:group header))))
+\f
+;;;; News-Article Mode
+
+(define-major-mode news-article read-only "News Article"
+ "Major mode for reading a News article.
+This mode's commands include:
+
+\\[next-news-article] read the next unread article
+\\[previous-news-article] read the previous unread article
+\\[toggle-news-article-header] show/don't show all of the articles header lines
+\\[toggle-news-article-context] show/don't show window of the News group buffer
+\\[reply-to-news-article] reply by email to this article
+\\[output-news-article] output this article to a mail file
+\\[output-news-article-to-rmail-file] output this article to an RMAIL file")
+
+(define-key 'news-article #\space '(news-article . #\c-v))
+(define-key 'news-article #\rubout '(news-article . #\m-v))
+(define-key 'news-article #\c 'toggle-news-article-context)
+(define-key 'news-article #\n 'next-news-article)
+(define-key 'news-article #\o 'output-news-article-to-rmail-file)
+(define-key 'news-article #\p 'previous-news-article)
+(define-key 'news-article #\q 'news-kill-current-buffer)
+(define-key 'news-article #\r 'reply-to-news-article)
+(define-key 'news-article #\t 'toggle-news-article-header)
+(define-key 'news-article #\c-o 'output-news-article)
+\f
+(define-command next-news-article
+ "Select a buffer containing the next unread article in the News group.
+If there is no such article, returns to the News group buffer.
+Kills the current buffer in either case."
+ ()
+ (lambda ()
+ (news-article-motion-command
+ (lambda (group-buffer header)
+ (let ((headers (buffer-news-headers group-buffer)))
+ (let ((index (vector-find-next-element headers header))
+ (length (vector-length headers)))
+ (if (not index)
+ (error "News header missing from headers list:" header))
+ (let loop ((index (fix:+ index 1)))
+ (if (fix:= index length)
+ "No next message in group."
+ (let ((header (vector-ref headers index)))
+ (if (buffer-news-header-mark group-buffer header #f)
+ header
+ (loop (fix:+ index 1))))))))))))
+
+(define-command previous-news-article
+ "Select a buffer containing the previous unread article in the News group.
+If there is no such article, returns to the News group buffer.
+Kills the current buffer in either case."
+ ()
+ (lambda ()
+ (news-article-motion-command
+ (lambda (group-buffer header)
+ (let ((headers (buffer-news-headers group-buffer)))
+ (let ((index (vector-find-next-element headers header)))
+ (if (not index)
+ (error "News header missing from headers list:" header))
+ (let loop ((index (fix:- index 1)))
+ (if (fix:< index 0)
+ "No previous message in group."
+ (let ((header (vector-ref headers index)))
+ (if (buffer-news-header-mark group-buffer header #f)
+ header
+ (loop (fix:- index 1))))))))))))
+
+(define (news-article-motion-command procedure)
+ (let ((buffer (current-buffer)))
+ (let ((group-buffer (buffer-tree:parent buffer #t)))
+ (let ((header (procedure group-buffer (buffer-news-header buffer))))
+ (if (news-header? header)
+ (begin
+ (select-news-article group-buffer header)
+ (news-group-buffer:set-point!
+ group-buffer
+ (buffer-news-header-mark group-buffer header #t)))
+ (begin
+ (select-buffer group-buffer)
+ (message header)))))
+ (kill-buffer buffer)))
+\f
+(define-command toggle-news-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 (current-buffer)))
+ (let ((header (buffer-news-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 toggle-news-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))))
+ (cond ((not context-window)
+ (show-news-article-context article-window context-lines))
+ ((not (eq? group-buffer (window-buffer context-window)))
+ (select-buffer-in-window group-buffer context-window #f)
+ (set-height))
+ (argument
+ (set-height))
+ (else
+ (window-delete! context-window article-window)
+ (buffer-remove! group-buffer 'CONTEXT-WINDOW))))))))))
+
+(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))))
+\f
+(define-command output-news-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."
+ (lambda ()
+ (list (prompt-for-rmail-output-filename
+ "Output article to Rmail file"
+ (ref-variable rmail-last-rmail-file))))
+ (lambda (pathname)
+ (set-variable! rmail-last-rmail-file (->namestring pathname))
+ (let ((buffer (get-article-output-buffer (current-buffer))))
+ (rfc822-region->babyl (buffer-region buffer))
+ (rmail-output-to-rmail-file (buffer-region buffer) pathname)
+ (kill-buffer buffer))))
+
+(define-command output-news-article
+ "Append this article to Unix mail file named FILE-NAME."
+ (lambda ()
+ (list (prompt-for-rmail-output-filename "Output article to Unix mail file"
+ (ref-variable rmail-last-file))))
+ (lambda (pathname)
+ (set-variable! rmail-last-file (->namestring pathname))
+ (let ((buffer (get-article-output-buffer (current-buffer))))
+ (rmail-output-to-unix-mail-file (buffer-region buffer) pathname)
+ (kill-buffer buffer))))
+
+(define (get-article-output-buffer buffer)
+ (let ((buffer* (temporary-buffer " news conversion")))
+ (insert-region (buffer-absolute-start buffer)
+ (buffer-absolute-end buffer)
+ (buffer-start buffer*))
+ (delete-news-header buffer*)
+ (insert-news-header (buffer-news-header buffer) buffer* #f)
+ buffer*))
+
+(define-command reply-to-news-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 ()
+ (let ((reply-buffer (current-buffer)))
+ (make-mail-buffer
+ (let ((buffer (temporary-buffer " news conversion")))
+ (insert-news-header (buffer-news-header reply-buffer) buffer #f)
+ (let ((headers
+ (rfc822-region-reply-headers (buffer-region buffer) #t)))
+ (kill-buffer buffer)
+ headers))
+ reply-buffer
+ select-buffer-other-window))))
+
+(define (buffer-news-header buffer)
+ (let ((header (buffer-get buffer 'NEWS-HEADER #f)))
+ (if (not header)
+ (error "Not in a news-article buffer."))
+ header))
+\f
+;;;; INI File
+
+(define (get-ini-file-groups connection)
+ (let ((buffer (ini-file-buffer))
+ (server (nntp-connection:server connection)))
+ (let ((mark (ini-file-buffer:server-groups-entry buffer server)))
+ (if mark
+ (map (lambda (entry)
+ (make-news-group-1 connection
+ (car entry)
+ (cadr entry)
+ (cddr entry)))
+ (ini-file-buffer:read-server-groups-entry mark server))
+ '()))))
+
+(define (put-ini-file-groups connection groups)
+ (let ((buffer (ini-file-buffer))
+ (server (nntp-connection:server connection)))
+ (let ((mark (ini-file-buffer:server-groups-entry buffer server))
+ (insert-groups
+ (lambda (mark)
+ (call-with-output-mark mark
+ (lambda (port)
+ (write-string "(server-groups " port)
+ (write server port)
+ (for-each (lambda (group)
+ (write-string "\n\t" port)
+ (write (cons* (news-group:name group)
+ (news-group:subscribed? group)
+ (news-group:ranges-seen group))
+ port))
+ groups)
+ (write-string "\n\t)" port))))))
+ (cond (mark
+ (let ((mark (mark-right-inserting-copy mark)))
+ (set-buffer-major-mode! buffer (ref-mode-object scheme))
+ (delete-string mark (forward-sexp mark 1 'ERROR))
+ (if (not (null? groups))
+ (insert-groups mark))
+ (mark-temporary! mark))
+ (save-buffer buffer #f))
+ ((not (null? groups))
+ (let ((mark (mark-left-inserting-copy (buffer-end buffer))))
+ (if (mark= (buffer-start buffer) mark)
+ (insert-string ";;; -*-Scheme-*- News Reader INI file"
+ mark))
+ (guarantee-newlines 2 mark)
+ (insert-groups mark)
+ (mark-temporary! mark))
+ (save-buffer buffer #f))))))
+\f
+(define (ini-file-buffer)
+ (find-file-noselect (merge-pathnames "snr.ini" (current-home-directory)) #t))
+
+(define (ini-file-buffer:server-groups-entry buffer server)
+ (let ((end (buffer-end buffer)))
+ (let loop ((start (buffer-start buffer)))
+ (and (re-search-forward "^(server-groups[ \t]+\"\\([^\"]+\\)\""
+ start end #t)
+ (if (string-ci=? (extract-string (re-match-start 1)
+ (re-match-end 1))
+ server)
+ (re-match-start 0)
+ (loop (re-match-end 0)))))))
+
+(define (ini-file-buffer:read-server-groups-entry mark server)
+ (bind-condition-handler (list condition-type:error)
+ (lambda (condition)
+ condition
+ (editor-error "Entry for "
+ server
+ " in "
+ (->namestring (buffer-pathname (mark-buffer mark)))
+ " is damaged."))
+ (lambda ()
+ (let ((entry (with-input-from-mark mark read)))
+ (if (not (ini-file-buffer:valid-server-groups-entry? entry))
+ (error "Invalid server entry:" entry))
+ (cddr entry)))))
+
+(define (ini-file-buffer:valid-server-groups-entry? entry)
+ (and (list? entry)
+ (>= (length entry) 2)
+ (eq? 'SERVER-GROUPS (car entry))
+ (string? (cadr entry))
+ (for-all? (cddr entry)
+ (lambda (entry)
+ (and (list? entry)
+ (>= (length entry) 2)
+ (string? (car entry))
+ (boolean? (cadr entry))
+ (for-all? (cddr entry) range?))))))
+\f
+;;;; .newsrc File
+
+(define (get-newsrc-file-groups connection)
+ (parse-newsrc-buffer connection (newsrc-file-buffer connection)))
+
+(define (parse-newsrc-buffer connection buffer)
+ (let loop ((start (buffer-start buffer)) (groups '()))
+ (let ((end (line-end start 0)))
+ (let ((groups
+ (let ((mark (re-match-forward "^[^:! \t\n]+[:!]" start end)))
+ (if mark
+ (cons (make-news-group-1
+ connection
+ (extract-string start (mark-1+ mark))
+ (char=? #\: (extract-left-char mark))
+ (parse-newsrc-group-ranges mark end))
+ groups)
+ groups))))
+ (if (group-end? end)
+ (reverse! groups)
+ (loop (mark1+ end) groups))))))
+
+(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
+ (cond ((re-match-forward "[0-9]+" s e)
+ (cons (let ((n (extract-nonnegative-integer s e)))
+ (make-range n n))
+ ranges))
+ ((re-match-forward "\\([0-9]+\\)-\\([0-9]+\\)" s e)
+ (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))))
+ (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)))))))
+\f
+(define (update-newsrc-group group)
+ (let ((buffer (newsrc-file-buffer (news-group:connection 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)
+ (insert-char #\space mark)
+ (for-each
+ (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)))))
+ (news-group:ranges-seen group))
+ (mark-temporary! mark))))
+ (if mark
+ (let ((mark (mark-left-inserting-copy (mark-1+ mark))))
+ (delete-string mark (line-end mark 0))
+ (finish mark))
+ (let ((mark (mark-left-inserting-copy (buffer-end buffer))))
+ (guarantee-newline mark)
+ (insert-string (news-group:name group) mark)
+ (finish mark))))))
+
+(define (newsrc-file-buffer connection)
+ (find-file-noselect (os/newsrc-file-name (nntp-connection:server connection))
+ #f))
+
+(define (os/newsrc-file-name server)
+ (let ((homedir (user-homedir-pathname)))
+ (if (os2/fs-long-filenames? homedir)
+ (let ((specific
+ (merge-pathnames (string-append ".newsrc-" server)
+ homedir)))
+ (if (file-exists? specific)
+ specific
+ (merge-pathnames ".newsrc" homedir)))
+ (merge-pathnames "newsrc.ini" homedir))))
+\f
+;;;; Miscellaneous
+
+(define (repeating-command argument procedure key adjective)
+ (let ((procedure
+ (lambda (group)
+ (procedure group)
+ (set-current-point! (line-start (current-point) 1 'ERROR)))))
+ (if argument
+ (for-each procedure
+ (next-n-property-items (command-argument-value argument)
+ key))
+ (procedure (current-property-item key adjective)))))
+
+(define (current-property-item key adjective)
+ (let ((item (region-get (current-point) key #f)))
+ (if (not item)
+ (editor-error "Point isn't on a"
+ (if (memv (string-ref adjective 0)
+ '(#\a #\e #\i #\o #\u))
+ "n"
+ "")
+ " "
+ adjective
+ " line."))
+ item))
+
+(define (next-n-property-items n key)
+ (let loop ((start (line-start (current-point) 0)) (n n))
+ (if (<= n 0)
+ '()
+ (cons (let ((item (region-get start key #f)))
+ (if (not item)
+ (error "Missing property item:" key))
+ item)
+ (let ((next (line-start start 1 #f)))
+ (if next
+ (loop next (- n 1))
+ '()))))))
+
+(define (property-item mark key adjective)
+ (let ((item (region-get mark key #f)))
+ (if (not item)
+ (editor-error "Missing " adjective " property."))
+ item))
+
+(define (find-buffer-line buffer item key <)
+ (let ((group (mark-group (buffer-absolute-start buffer))))
+ (let loop
+ ((low (mark-index (buffer-absolute-start buffer)))
+ (high (mark-index (buffer-absolute-end buffer))))
+ (and (fix:< low high)
+ (let ((index (fix:quotient (fix:+ low high) 2)))
+ (let ((item* (get-text-property group index key #f)))
+ (if (not item*)
+ (error "Missing text property:" key (buffer-name buffer)))
+ (cond ((eq? item item*)
+ (line-start (make-mark group index) 0))
+ ((< item item*)
+ (loop low index))
+ (else
+ (loop (fix:+ index 1) high)))))))))
+
+(define (get-buffer-property buffer key)
+ (let ((item (buffer-get buffer key #f)))
+ (if (not item)
+ (error "Missing buffer property:" key (buffer-name buffer)))
+ item))
+\f
+;;;; 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)
+ (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 '())))
+ (buffer-put! buffer 'BUFFER-TREE node)
+ (add-kill-buffer-hook buffer buffer-tree:kill)
+ node))))
+
+(define (buffer-tree:kill buffer)
+ (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)))))))
+\f
+;;;; News-Group Extensions
+
+(define-structure (news-group-extra
+ (conc-name news-group-extra:)
+ (constructor make-news-group-extra ()))
+ (subscribed? #f)
+ (ranges-seen '()))
+
+(define (get-news-group-extra group)
+ (or (news-group:reader-hook group)
+ (let ((extra (make-news-group-extra)))
+ (set-news-group:reader-hook! group extra)
+ extra)))
+
+(define-integrable (news-group:subscribed? group)
+ (news-group-extra:subscribed? (get-news-group-extra group)))
+
+(define-integrable (set-news-group:subscribed?! group value)
+ (set-news-group-extra:subscribed?! (get-news-group-extra group) value))
+
+(define-integrable (news-group:ranges-seen group)
+ (news-group-extra:ranges-seen (get-news-group-extra group)))
+
+(define-integrable (set-news-group:ranges-seen! group value)
+ (set-news-group-extra:ranges-seen! (get-news-group-extra group) value))
+
+(define (make-news-group-1 connection name subscribed? ranges-seen)
+ (let ((group (make-news-group connection name)))
+ (set-news-group:subscribed?! group subscribed?)
+ (set-news-group:ranges-seen! group (canonicalize-ranges ranges-seen))
+ group))
+
+(define (news-group:update-ranges! group)
+ (news-group:update-probe! group)
+ (if (news-group:active? group)
+ (set-news-group:ranges-seen!
+ group
+ (clip-ranges! (news-group:ranges-seen group)
+ (news-group:first-article group)
+ (news-group:last-article group)))))
+
+(define (news-group:number-of-articles group)
+ (let ((n-seen (count-ranges (news-group:ranges-seen group))))
+ (if (= n-seen 0)
+ (news-group:estimated-n-articles group)
+ (- (- (+ (news-group:last-article group) 1)
+ (news-group:first-article group))
+ n-seen))))
+
+(define (news-group:article-seen! group header)
+ (let ((do-it
+ (lambda (group number)
+ (set-news-group:ranges-seen!
+ group
+ (add-to-ranges! (news-group:ranges-seen group) number)))))
+ (do-it group (news-header:number header))
+ (for-each (let ((connection (news-group:connection group)))
+ (lambda (xref)
+ (let ((group (find-news-group connection (car xref))))
+ (if (and group (news-group:subscribed? group))
+ (do-it group (token->number (cdr xref)))))))
+ (news-header:xref header))))
+
+(define (news-group:article-unseen! group header)
+ (set-news-group:ranges-seen!
+ group
+ (remove-from-ranges! (news-group:ranges-seen group)
+ (news-header:number header))))
+\f
+;;;; 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 (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)))
+\f
+(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 (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)))
+\f
+(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))
+\f
+;;;; News-Header Extensions
+
+(define-structure (news-header-extra
+ (conc-name news-header-extra:)
+ (constructor make-news-header-extra ()))
+ (status #\space)
+ (line-number '()))
+
+(define (get-news-header-extra header)
+ (or (news-header:reader-hook header)
+ (let ((extra (make-news-header-extra)))
+ (set-news-header:reader-hook! header extra)
+ extra)))
+
+(define news-header-extra-table
+ (make-eq-hash-table))
+
+(define-integrable (news-header:status header)
+ (news-header-extra:status (get-news-header-extra header)))
+
+(define-integrable (set-news-header:status! header value)
+ (set-news-header-extra:status! (get-news-header-extra header) value))
+
+(define-integrable (news-header:line-number header)
+ (news-header-extra:line-number (get-news-header-extra header)))
+
+(define-integrable (set-news-header:line-number! header value)
+ (set-news-header-extra:line-number! (get-news-header-extra header) value))
+
+(define (news-header:article-seen! header)
+ (set-news-header:status! header #\D)
+ (news-group:article-seen! (news-header:group header) header))
+
+(define (news-header:article-unseen! header)
+ (set-news-header:status! header #\space)
+ (news-group:article-unseen! (news-header:group header) header))
+
+(define (news-header:article-unseen? header)
+ (char=? #\space (news-header:status header)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff