From: Chris Hanson Date: Wed, 3 May 1995 07:51:01 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6350 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=73a394e5101703a863716b1ce02b0c11296c8c69;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/nntp.scm b/v7/src/edwin/nntp.scm new file mode 100644 index 000000000..b6ea7cadb --- /dev/null +++ b/v7/src/edwin/nntp.scm @@ -0,0 +1,944 @@ +;;; -*-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)) + +;;;; 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)) + +;;;; 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)) + +(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)))))))) + +;;;; 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-cistring 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))))))))) + +;;;; 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))) + +;;;; 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))))))))) + +;;;; 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:<)) + +(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 + '()))) + +(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)))))) + +(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))))) + +(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))) + +;;;; 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 diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm new file mode 100644 index 000000000..4915d27ab --- /dev/null +++ b/v7/src/edwin/snr.scm @@ -0,0 +1,1754 @@ +;;; -*-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) + +(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))) + +;;;; 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))) + +(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))) + +(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))))) + +(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)) + +;;;; 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)))))) + +(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)))) + +(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))))) + +;;;; 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)) + +;;;; 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)) + +(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)))) + +(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)))) + +;;;; 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.")))) + +(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)))))))))) + +(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")) + +;;;; 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)))) + +;;;; 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) + +(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))) + +(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)))) + +(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)) + +;;;; 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)))))) + +(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?)))))) + +;;;; .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))))))) + +(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)))) + +;;;; 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)) + +;;;; 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))))))) + +;;;; 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)))) + +;;;; 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))) + +(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))) + +(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-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