From: Chris Hanson Date: Wed, 25 Dec 1996 06:50:07 +0000 (+0000) Subject: * Change terminology to refer to "seen" articles as "deleted". X-Git-Tag: 20090517-FFI~5290 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4174b17e0485d58baa64e25733d8cb301f4af155;p=mit-scheme.git * Change terminology to refer to "seen" articles as "deleted". * Introduce new marking, "browsed", to indicate articles whose headers have been shown in a news-group buffer. These "browsed" markings are used to prevent a common problem with cross posts: after having marked an article in one group, re-marking the cross-posted article differently in another group clobbers the original markings. The news reader now examines the "browsed" marking, and does not re-mark any cross post that has already been "browsed". * Change code that selects initial header when opening a news-group buffer for the first time. New code does not automatically expand a thread whose first message is "deleted". --- diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 25d4cc03d..3ebf592c5 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.24 1996/12/24 08:50:32 cph Exp $ +;;; $Id: snr.scm,v 1.25 1996/12/25 06:50:07 cph Exp $ ;;; ;;; Copyright (c) 1995-96 Massachusetts Institute of Technology ;;; @@ -822,7 +822,7 @@ With prefix argument, clears the list for the next several News groups." (lambda (argument) (group-iteration argument (lambda (buffer group) - (set-news-group:ranges-seen! group '()) + (set-news-group:ranges-deleted! group '()) (update-news-groups-buffers buffer group))))) (define-command news-subscribe-group @@ -1065,7 +1065,7 @@ This shows News groups that have been created since the last time that (and name (let ((connection (buffer-nntp-connection (mark-buffer mark)))) (or (find-news-group connection name) - (make-news-group-1 connection name #f #f '() '())))))) + (make-news-group-1 connection name #f #f '() '() '())))))) (define (ang-buffer:mark-group-name mark) (and (re-match-forward @@ -1092,12 +1092,16 @@ This shows News groups that have been created since the last time that (let ((ls (find-first-property-line buffer 'NEWS-HEADER #f))) (and ls (let ((header (region-get ls 'NEWS-HEADER #f))) - (cond ((not (news-header:article-seen? header)) ls) + (cond ((not (news-header:article-deleted? header)) ls) ((news-group-buffer:next-header buffer header news-header:unread?) => (lambda (header) - (news-group-buffer:header-mark-1 buffer header))) + (or (news-group-buffer:header-mark buffer header) + (news-group-buffer:thread-start-mark + buffer + (news-header:thread header)) + ls))) (else ls)))))))) (define (news-group-buffer-name group) @@ -1193,12 +1197,9 @@ This shows News groups that have been created since the last time that (mark-left-inserting-copy (or (delete-news-thread-lines buffer thread) (let loop ((thread thread)) - (let ((next - (news-group-buffer:next-thread buffer thread))) + (let ((next (news-group-buffer:next-thread buffer thread))) (if next - (or (news-group-buffer:thread-start-mark - buffer - next) + (or (news-group-buffer:thread-start-mark buffer next) (loop next)) (begin (guarantee-newline (buffer-end buffer)) @@ -1207,11 +1208,38 @@ This shows News groups that have been created since the last time that (insert-news-thread-lines thread ls) (mark-temporary! ls) (update-subsequent-news-header-lines ls))))) + +(define (delete-news-thread-lines buffer thread) + (let ((region (news-thread-lines-region buffer thread))) + (and region + (let ((start (mark-right-inserting-copy (region-start region)))) + (news-thread:clear-indices! thread) + (delete-string start (region-end region)) + (mark-temporary! start) + start)))) + +(define (news-thread-lines-region buffer thread) + (let ((ls (news-group-buffer:thread-start-mark buffer thread))) + (and ls + (let ((start (mark-temporary-copy ls)) + (end (mark-temporary-copy (line-start ls 1 'LIMIT)))) + (news-thread:for-each-header thread + (lambda (header) + (let ((ls (news-group-buffer:header-mark buffer header))) + (if ls + (let ((nls (line-start ls 1 'LIMIT))) + (if (mark< ls start) (move-mark-to! start ls)) + (if (mark> nls end) (move-mark-to! end nls))))))) + (make-region start end))))) (define (insert-news-thread-lines thread mark) (if (news-thread:show-collapsed? thread) (insert-collapsed-news-thread-line thread mark) - (insert-expanded-news-thread-lines thread mark))) + (insert-expanded-news-thread-lines thread mark)) + (news-thread:for-each-real-header thread + (let ((buffer (mark-buffer mark))) + (lambda (header) + (news-header:article-browsed! header buffer))))) (define (insert-expanded-news-thread-lines thread mark) (let ((subject @@ -1265,28 +1293,13 @@ This shows News groups that have been created since the last time that header mark))) -(define (delete-news-thread-lines buffer thread) - (let ((region (news-thread-lines-region buffer thread))) - (and region - (let ((start (mark-right-inserting-copy (region-start region)))) - (news-thread:clear-indices! thread) - (delete-string start (region-end region)) - (mark-temporary! start) - start)))) - -(define (news-thread-lines-region buffer thread) - (let ((ls (news-group-buffer:thread-start-mark buffer thread))) - (and ls - (let ((start (mark-temporary-copy ls)) - (end (mark-temporary-copy (line-start ls 1 'LIMIT)))) - (news-thread:for-each-header thread - (lambda (header) - (let ((ls (news-group-buffer:header-mark buffer header))) - (if ls - (let ((nls (line-start ls 1 'LIMIT))) - (if (mark< ls start) (move-mark-to! start ls)) - (if (mark> nls end) (move-mark-to! end nls))))))) - (make-region start end))))) +(define (update-subsequent-news-header-lines ls) + (let ((header (region-get ls 'NEWS-HEADER #f))) + (if header + (set-news-header:index! header (mark-index ls)))) + (let ((ls (line-start ls 1 #f))) + (if ls + (update-subsequent-news-header-lines ls)))) (define (insert-news-header-line header indentation subject mark) (insert-subject-line (news-header:status header) @@ -1356,14 +1369,6 @@ This shows News groups that have been created since the last time that (re-match-start-index 1) (re-match-end-index 1))) (or (rfc822-first-address from) from))) - -(define (update-subsequent-news-header-lines ls) - (let ((header (region-get ls 'NEWS-HEADER #f))) - (if header - (set-news-header:index! header (mark-index ls)))) - (let ((ls (line-start ls 1 #f))) - (if ls - (update-subsequent-news-header-lines ls)))) (define (news-group-buffer:header-mark buffer header) (let ((index (news-header:index header))) @@ -1765,7 +1770,7 @@ With prefix argument, moves down several threads." (partial-win t n))))) (define (next-loop-1 t n) - (next-loop t (if (news-thread:all-articles-seen? t) n (- n 1)))) + (next-loop t (if (news-thread:all-articles-deleted? t) n (- n 1)))) (define (prev-loop t n) (if (= n 0) @@ -1776,7 +1781,7 @@ With prefix argument, moves down several threads." (partial-win t n))))) (define (prev-loop-1 t n) - (prev-loop t (if (news-thread:all-articles-seen? t) n (+ n 1)))) + (prev-loop t (if (news-thread:all-articles-deleted? t) n (+ n 1)))) (define (win t) (news-group-buffer:move-to-header @@ -1901,9 +1906,9 @@ With prefix argument, unmarks the previous several articles." (define (name->article-marker name) (case name - ((SEEN) news-header:article-seen!) + ((SEEN) news-header:article-deleted!) ((MARKED) news-header:article-marked!) - ((UNSEEN) news-header:article-unseen!) + ((UNSEEN) news-header:article-not-deleted!) ((IGNORED) news-header:article-ignored!) (else (error "Unknown marker name:" name)))) @@ -2117,7 +2122,7 @@ This command has no effect if the variable (let ((regions '())) (for-each (lambda (thread) - (if (news-thread:all-articles-seen? thread) + (if (news-thread:all-articles-deleted? thread) (let ((region (news-thread-lines-region buffer thread))) (if region @@ -2143,7 +2148,7 @@ This command has no effect if the variable (buffer-put! buffer 'NEWS-THREADS (list->vector (list-transform-negative threads - news-thread:all-articles-seen?))) + news-thread:all-articles-deleted?))) (if (and on-header? (not (region-get (current-point) 'NEWS-HEADER #f))) (let ((ls @@ -2165,7 +2170,7 @@ This kills the current buffer." (lambda (thread) (news-thread:for-each-real-header thread (lambda (header) - (news-header:article-seen! header buffer)))))) + (news-header:article-deleted! header buffer)))))) ((ref-command news-kill-current-buffer)))))) (define-command news-group-quit @@ -2215,12 +2220,12 @@ This kills the current buffer." (set-buffer-point! buffer (buffer-start buffer)) (buffer-not-modified! buffer) (set-buffer-read-only! buffer) - (news-header:article-seen! header group-buffer) + (news-header:article-deleted! header group-buffer) (update-buffer-news-header-status group-buffer header) buffer) (begin (kill-buffer buffer) - (news-header:article-seen! header group-buffer) + (news-header:article-deleted! header group-buffer) (update-buffer-news-header-status group-buffer header) #f)))) @@ -2961,6 +2966,9 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." ((3) (set! convert-entry convert-groups-init-file-entry-type-3) validate-groups-init-file-entry-type-3) + ((4) + (set! convert-entry convert-groups-init-file-entry-type-4) + validate-groups-init-file-entry-type-4) (else #f))))))) (map (convert-entry connection) entries))))) @@ -2969,21 +2977,23 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (write-init-file (groups-init-file-pathname server) buffer - 3 + 4 (let loop ((groups (vector->list groups)) (entries '())) (if (null? groups) entries (loop (cdr groups) (let ((group (car groups))) (if (and (not (news-group:subscribed? group)) - (ranges-empty? (news-group:ranges-seen group)) - (ranges-empty? (news-group:ranges-marked group))) + (ranges-empty? (news-group:ranges-deleted group)) + (ranges-empty? (news-group:ranges-marked group)) + (ranges-empty? (news-group:ranges-browsed group))) entries (cons (vector (news-group:name group) (news-group:subscribed? group) (news-group:server-info group) - (news-group:ranges-seen group) - (news-group:ranges-marked group)) + (news-group:ranges-deleted group) + (news-group:ranges-marked group) + (news-group:ranges-browsed group)) entries))))))))) (define (groups-init-file-pathname server) @@ -3000,7 +3010,8 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (for-all? (cddr entry) range?))) (define ((convert-groups-init-file-entry-type-1 connection) entry) - (make-news-group-1 connection (car entry) (cadr entry) #f (cddr entry) '())) + (make-news-group-1 connection (car entry) (cadr entry) #f (cddr entry) + '() '())) (define (validate-groups-init-file-entry-type-2 entry) (and (list? entry) @@ -3016,6 +3027,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (cadr entry) (caddr entry) (cdddr entry) + '() '())) (define (validate-groups-init-file-entry-type-3 entry) @@ -3033,7 +3045,27 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (vector-ref entry 1) (vector-ref entry 2) (vector-ref entry 3) - (vector-ref entry 4))) + (vector-ref entry 4) + '())) + +(define (validate-groups-init-file-entry-type-4 entry) + (and (vector? entry) + (= (vector-length entry) 6) + (string? (vector-ref entry 0)) + (boolean? (vector-ref entry 1)) + (valid-group-server-info? (vector-ref entry 2)) + (for-all? (vector-ref entry 3) range?) + (for-all? (vector-ref entry 4) range?) + (for-all? (vector-ref entry 5) range?))) + +(define ((convert-groups-init-file-entry-type-4 connection) entry) + (make-news-group-1 connection + (vector-ref entry 0) + (vector-ref entry 1) + (vector-ref entry 2) + (vector-ref entry 3) + (vector-ref entry 4) + (vector-ref entry 5))) (define (valid-group-server-info? server-info) (and (vector? server-info) @@ -3142,16 +3174,17 @@ With prefix arg, replaces the groups list with the .newsrc entries." (let ((group (find-news-group connection name))) (if group (begin - (set-news-group:ranges-seen! + (set-news-group:ranges-deleted! group (if replace? ranges - (merge-ranges (news-group:ranges-seen group) - ranges))) - (news-group:guarantee-ranges-seen group) + (merge-ranges + (news-group:ranges-deleted group) + ranges))) + (news-group:guarantee-ranges-deleted group) group) - (make-news-group-1 connection - name #f #f ranges '()))))) + (make-news-group-1 connection name #f #f ranges + '() '()))))) (if subscribed? (subscribe-news-group buffer group) (unsubscribe-news-group buffer group))))) @@ -3239,7 +3272,7 @@ With prefix arg, replaces the file with the list information." (lambda (mark) (insert-char (if (news-group:subscribed? group) #\: #\!) mark) (let ((ranges - (let ((ranges (news-group:guarantee-ranges-seen group)) + (let ((ranges (news-group:guarantee-ranges-deleted group)) (first (news-group:first-article group))) (if (> first 1) (canonicalize-ranges @@ -3589,6 +3622,186 @@ With prefix arg, replaces the file with the list information." (set-car! node #f)))) (map cdr (cdr node))))))))))) +;;;; Article Ranges + +(define (range? object) + (or (article-number? object) + (and (pair? object) + (article-number? (car object)) + (article-number? (cdr object)) + (<= (car object) (cdr object))))) + +(define (article-number? object) + (and (exact-integer? object) + (> object 0))) + +(define (make-range f l) (if (= f l) f (cons f l))) +(define (range-first r) (if (pair? r) (car r) r)) +(define (range-last r) (if (pair? r) (cdr r) r)) +(define (range-length r) (if (pair? r) (+ (- (cdr r) (car r)) 1) 1)) +(define ranges-empty? null?) + +(define (count-ranges ranges) + (let loop ((ranges ranges) (count 0)) + (if (null? ranges) + count + (loop (cdr ranges) (+ count (range-length (car ranges))))))) + +(define (canonicalize-ranges ranges) + (if (null? ranges) + ranges + (let ((ranges + (sort ranges (lambda (x y) (< (range-first x) (range-first y)))))) + (let loop ((ranges ranges)) + (if (not (null? (cdr ranges))) + (let ((x (car ranges)) + (y (cadr ranges))) + (if (<= (range-first y) (+ (range-last x) 1)) + (begin + (set-car! ranges + (make-range (range-first x) + (max (range-last x) + (range-last y)))) + (set-cdr! ranges (cddr ranges)) + (loop ranges)) + (loop (cdr ranges)))))) + ranges))) + +(define (clip-ranges! ranges first last) + (let ((holder + (cons 'HOLDER + (let clip-first ((ranges ranges)) + (cond ((or (null? ranges) + (<= first (range-first (car ranges)))) + ranges) + ((< (range-last (car ranges)) first) + (clip-first (cdr ranges))) + (else + (set-car! ranges + (make-range first (range-last (car ranges)))) + ranges)))))) + (let clip-last ((ranges (cdr holder)) (prev holder)) + (cond ((null? ranges) + unspecific) + ((< (range-last (car ranges)) last) + (clip-last (cdr ranges) ranges)) + ((> (range-first (car ranges)) last) + (set-cdr! prev '())) + (else + (if (> (range-last (car ranges)) last) + (set-car! ranges + (make-range (range-first (car ranges)) + last))) + (set-cdr! ranges '())))) + (cdr holder))) + +(define (complement-ranges ranges first last) + (if (null? ranges) + (list (make-range first last)) + (let loop + ((e (range-last (car ranges))) + (ranges (cdr ranges)) + (result + (let ((s (range-first (car ranges)))) + (if (< first s) + (list (make-range first (- s 1))) + '())))) + (if (null? ranges) + (reverse! (if (< e last) + (cons (make-range (+ e 1) last) result) + result)) + (loop (range-last (car ranges)) + (cdr ranges) + (cons (make-range (+ e 1) (- (range-first (car ranges)) 1)) + result)))))) + +(define (merge-ranges ranges ranges*) + (cond ((null? ranges) + ranges*) + ((null? ranges*) + ranges) + ((< (range-last (car ranges)) (range-first (car ranges*))) + (cons (car ranges) (merge-ranges (cdr ranges) ranges*))) + ((< (range-last (car ranges*)) (range-first (car ranges))) + (cons (car ranges*) (merge-ranges ranges (cdr ranges*)))) + (else + (cons (make-range (min (range-first (car ranges)) + (range-first (car ranges*))) + (max (range-last (car ranges)) + (range-last (car ranges*)))) + (merge-ranges (cdr ranges) (cdr ranges*)))))) + +(define (add-to-ranges! ranges number) + (let ((holder (cons 'HOLDER ranges))) + (let loop ((ranges ranges) (prev holder)) + (if (null? ranges) + (set-cdr! prev (list (make-range number number))) + (let ((f (range-first (car ranges))) + (l (range-last (car ranges)))) + (cond ((> number (+ l 1)) + (loop (cdr ranges) ranges)) + ((< number (- f 1)) + (set-cdr! prev (cons (make-range number number) ranges))) + (else + (let ((f (min f number)) + (l (max l number))) + (if (and (not (null? (cdr ranges))) + (= (+ l 1) (range-first (cadr ranges)))) + (begin + (set-car! ranges + (make-range f (range-last (cadr ranges)))) + (set-cdr! ranges (cddr ranges))) + (set-car! ranges (make-range f l))))))))) + (cdr holder))) + +(define (remove-from-ranges! ranges number) + (let ((holder (cons 'HOLDER ranges))) + (let loop ((ranges ranges) (prev holder)) + (if (not (null? ranges)) + (let ((f (range-first (car ranges))) + (l (range-last (car ranges)))) + (cond ((> number l) + (loop (cdr ranges) ranges)) + ((>= number f) + (if (= number f) + (if (= number l) + (set-cdr! prev (cdr ranges)) + (set-car! ranges (make-range (+ f 1) l))) + (if (= number l) + (set-car! ranges (make-range f (- l 1))) + (begin + (set-car! ranges (make-range (+ number 1) l)) + (set-cdr! prev + (cons (make-range f (- number 1)) + ranges)))))))))) + (cdr holder))) + +(define (member-of-ranges? ranges number) + (let loop ((ranges ranges)) + (and (not (null? ranges)) + (or (<= (range-first (car ranges)) number (range-last (car ranges))) + (loop (cdr ranges)))))) + +(define (ranges->list ranges) + (let loop ((ranges ranges) (result '())) + (if (null? ranges) + (reverse! result) + (loop (cdr ranges) + (let ((e (range-last (car ranges)))) + (let loop ((n (range-first (car ranges))) (result result)) + (let ((result (cons n result))) + (if (= n e) + result + (loop (+ n 1) result))))))))) + +(define (for-each-range-element procedure ranges) + (for-each (lambda (range) + (let ((e (+ (range-last range) 1))) + (do ((n (range-first range) (+ n 1))) + ((= n e) unspecific) + (procedure n)))) + ranges)) + ;;;; News-Group Extensions (define-structure (news-group-extra @@ -3596,10 +3809,11 @@ With prefix arg, replaces the file with the list information." (conc-name news-group-extra:) (constructor make-news-group-extra ())) (subscribed? #f) - (ranges-seen '()) + (ranges-deleted '()) (index #f) (ignored-subjects 'UNKNOWN) - (ranges-marked '())) + (ranges-marked '()) + (ranges-browsed '())) (define (get-news-group-extra group write?) (or (news-group:reader-hook group) @@ -3613,11 +3827,11 @@ With prefix arg, replaces the file with the list information." (define (set-news-group:subscribed?! group value) (set-news-group-extra:subscribed?! (get-news-group-extra group #t) value)) -(define (news-group:ranges-seen group) - (news-group-extra:ranges-seen (get-news-group-extra group #f))) +(define (news-group:ranges-deleted group) + (news-group-extra:ranges-deleted (get-news-group-extra group #f))) -(define (set-news-group:ranges-seen! group value) - (set-news-group-extra:ranges-seen! (get-news-group-extra group #t) value)) +(define (set-news-group:ranges-deleted! group value) + (set-news-group-extra:ranges-deleted! (get-news-group-extra group #t) value)) (define (news-group:index group) (news-group-extra:index (get-news-group-extra group #f))) @@ -3638,13 +3852,20 @@ With prefix arg, replaces the file with the list information." (define (set-news-group:ranges-marked! group value) (set-news-group-extra:ranges-marked! (get-news-group-extra group #t) value)) +(define (news-group:ranges-browsed group) + (news-group-extra:ranges-browsed (get-news-group-extra group #f))) + +(define (set-news-group:ranges-browsed! group value) + (set-news-group-extra:ranges-browsed! (get-news-group-extra group #t) value)) + (define (make-news-group-1 connection name subscribed? server-info - ranges-seen ranges-marked) + ranges-deleted ranges-marked ranges-browsed) (let ((group (make-news-group connection name))) (set-news-group:subscribed?! group subscribed?) (set-news-group:server-info! group server-info) - (set-news-group:ranges-seen! group (canonicalize-ranges ranges-seen)) + (set-news-group:ranges-deleted! group (canonicalize-ranges ranges-deleted)) (set-news-group:ranges-marked! group (canonicalize-ranges ranges-marked)) + (set-news-group:ranges-browsed! group (canonicalize-ranges ranges-browsed)) group)) (define (news-group:get-threads group argument buffer) @@ -3664,7 +3885,7 @@ With prefix arg, replaces the file with the list information." (ref-variable news-group-show-seen-headers buffer)) threads (list-transform-negative threads - news-thread:all-articles-seen?)))))) + news-thread:all-articles-deleted?)))))) (define (news-group:get-headers group argument buffer) (let ((connection (news-group:connection group)) @@ -3725,13 +3946,13 @@ With prefix arg, replaces the file with the list information." (news-group:get-headers group #f buffer))) (define (article-number-seen! group number) - (set-news-group:ranges-seen! + (set-news-group:ranges-deleted! group - (add-to-ranges! (news-group:guarantee-ranges-seen group) number))) + (add-to-ranges! (news-group:guarantee-ranges-deleted group) number))) (define (news-group:unread-header-numbers group) (ranges->list - (complement-ranges (news-group:guarantee-ranges-seen group) + (complement-ranges (news-group:guarantee-ranges-deleted group) (news-group:first-article group) (news-group:last-article group)))) @@ -3750,7 +3971,7 @@ With prefix arg, replaces the file with the list information." (news-group:update-server-info! group) (message msg "done")) (if (news-group:active? group) - (news-group:guarantee-ranges-seen group))) + (news-group:guarantee-ranges-deleted group))) (define (news-group:purge-and-compact-headers! group buffer) (let ((msg @@ -3766,7 +3987,7 @@ With prefix arg, replaces the file with the list information." (and (not (ref-variable news-group-keep-ignored-headers buffer)) (news-header:ignore? header))))) - news-header:article-seen?)) + news-header:article-deleted?)) (message msg "done"))) (define (news-group:number-of-articles group) @@ -3774,7 +3995,8 @@ With prefix arg, replaces the file with the list information." (and estimate (if (news-group:reader-hook group) (let ((n-seen - (count-ranges (news-group:guarantee-ranges-seen group)))) + (count-ranges + (news-group:guarantee-ranges-deleted group)))) (if (= n-seen 0) estimate (- (- (+ (news-group:last-article group) 1) @@ -3782,66 +4004,90 @@ With prefix arg, replaces the file with the list information." n-seen))) estimate)))) -(define (news-group:guarantee-ranges-seen group) +(define (news-group:guarantee-ranges-deleted group) (let ((ranges - (clip-ranges! (news-group:ranges-seen group) + (clip-ranges! (news-group:ranges-deleted group) (news-group:first-article group) (news-group:last-article group)))) - (set-news-group:ranges-seen! group ranges) + (set-news-group:ranges-deleted! group ranges) ranges)) -(define (news-header:article-seen? header) - (member-of-ranges? (news-group:ranges-seen (news-header:group header)) +(define ((range-predicate group-ranges) header) + (member-of-ranges? (group-ranges (news-header:group header)) (news-header:number header))) -(define (news-group:article-seen! group header buffer) - (news-group:article-unmarked! group header buffer) - (news-group:adjust-article-status! - group header buffer #t - (news-group:seen-article-updater add-to-ranges!))) - -(define (news-group:article-unseen! group header buffer) - (news-group:article-unmarked! group header buffer) - (news-group:adjust-article-status! - group header buffer #t - (news-group:seen-article-updater remove-from-ranges!))) - -(define ((news-group:seen-article-updater procedure) group number) - (set-news-group:ranges-seen! group - (procedure (news-group:ranges-seen group) - number))) - -(define (news-header:article-marked? header) - (member-of-ranges? (news-group:ranges-marked (news-header:group header)) - (news-header:number header))) - -(define (news-group:article-marked! group header buffer) - (news-group:article-unseen! group header buffer) - (news-group:adjust-article-status! - group header buffer #f - (news-group:marked-article-updater add-to-ranges!))) - -(define (news-group:article-unmarked! group header buffer) - (news-group:adjust-article-status! - group header buffer #f - (news-group:marked-article-updater remove-from-ranges!))) - -(define ((news-group:marked-article-updater procedure) group number) - (set-news-group:ranges-marked! group - (procedure (news-group:ranges-marked group) - number))) - -(define (news-group:adjust-article-status! group header buffer handle-xrefs? - procedure) +(define news-header:article-deleted? + (range-predicate news-group:ranges-deleted)) + +(define news-header:article-marked? + (range-predicate news-group:ranges-marked)) + +(define (news-group:article-browsed? group number) + (member-of-ranges? (news-group:ranges-browsed group) number)) + +(define (ranges-marker group-ranges set-group-ranges! handle-xrefs? procedure) + (news-group:adjust-article-status! handle-xrefs? + (lambda (group number) + (set-group-ranges! group (procedure (group-ranges group) number))))) + +(define (ranges-deleted-marker procedure) + (let ((marker + (ranges-marker news-group:ranges-deleted + set-news-group:ranges-deleted! + #t + procedure))) + (lambda (header buffer) + (news-group:article-unmarked! header buffer) + (marker header buffer)))) + +(define news-group:article-deleted! + (ranges-deleted-marker add-to-ranges!)) + +(define news-group:article-not-deleted! + (ranges-deleted-marker remove-from-ranges!)) + +(define news-group:article-marked! + (let ((marker + (ranges-marker news-group:ranges-marked + set-news-group:ranges-marked! + #t + add-to-ranges!))) + (lambda (header buffer) + (news-group:article-not-deleted! header buffer) + (marker header buffer)))) + +(define news-group:article-unmarked! + (ranges-marker news-group:ranges-marked + set-news-group:ranges-marked! + #t + remove-from-ranges!)) + +(define news-group:article-browsed! + (ranges-marker news-group:ranges-browsed + set-news-group:ranges-browsed! + #f + add-to-ranges!)) + +(define ((news-group:adjust-article-status! handle-xrefs? procedure) + header buffer) (let ((do-it (lambda (group number) (procedure group number) (news-group:maybe-defer-update buffer group)))) - (do-it group (news-header:number header)) + (do-it (news-header:group header) (news-header:number header)) (if handle-xrefs? - (news-group:process-cross-posts group header - (lambda (group xref) - (do-it group (token->number (cdr xref)))))))) + (news-group:process-cross-posts header do-it)))) + +(define (news-group:process-cross-posts header process-header) + (for-each (let ((connection + (news-group:connection (news-header:group header)))) + (lambda (xref) + (let ((group (find-news-group connection (car xref)))) + (if (and group (news-group:subscribed? group)) + (let ((number (token->number (cdr xref)))) + (if (not (news-group:article-browsed? group number)) + (process-header group number))))))) + (news-header:xref header))) (define (defer-marking-updates buffer thunk) (fluid-let ((news-group:adjust-article-status!:deferred-updates (list #t))) @@ -3857,7 +4103,7 @@ With prefix arg, replaces the file with the list information." (update-news-groups-buffers buffer group)))) (define news-group:adjust-article-status!:deferred-updates #f) - + (define (news-group:articles-marked? group) (not (ranges-empty? (news-group:ranges-marked group)))) @@ -3868,7 +4114,7 @@ With prefix arg, replaces the file with the list information." (define (news-header:read-marked-body header buffer) (news-header:guarantee-full-text! header) (news-header:pre-read-body header) - (news-header:article-unseen! header buffer) + (news-header:article-not-deleted! header buffer) (let ((buffer (if (news-group-buffer? buffer) buffer @@ -3890,7 +4136,7 @@ With prefix arg, replaces the file with the list information." (let ((group (news-header:group header))) (hash-table/put! table subject t) (news-group:ignored-subjects-modified! group) - (news-group:process-cross-posts group header + (news-group:process-cross-posts header (ignore-subject-marker subject t)) #t)))) @@ -3902,42 +4148,36 @@ With prefix arg, replaces the file with the list information." (and (not (fix:= 0 (string-length subject))) (hash-table/get table subject #f)))))) -(define (news-group:article-ignored! group header buffer) +(define (news-group:article-ignored! header buffer) (let ((subject (canonicalize-subject (news-header:subject header)))) (if (not (fix:= 0 (string-length subject))) - (let ((process-group + (let ((process-header (ignore-subject-marker subject (get-universal-time)))) - (process-group group #f) - (news-group:process-cross-posts group header process-group)))) - (news-group:article-seen! group header buffer)) + (process-header (news-header:group header) + (news-header:number header)) + (news-group:process-cross-posts header process-header)))) + (news-group:article-deleted! header buffer)) -(define ((ignore-subject-marker subject t) group xref) - xref +(define ((ignore-subject-marker subject t) group number) + number (hash-table/put! (news-group:get-ignored-subjects group #t) subject t) (news-group:ignored-subjects-modified! group)) -(define (news-group:article-not-ignored! group header buffer) +(define (news-group:article-not-ignored! header buffer) buffer (let ((subject (canonicalize-subject (news-header:subject header)))) (if (not (fix:= 0 (string-length subject))) - (let ((process-group - (lambda (group xref) - xref + (let ((process-header + (lambda (group number) + number (let ((table (news-group:get-ignored-subjects group #f))) (if (and table (hash-table/get table subject #f)) (begin (hash-table/remove! table subject) (news-group:ignored-subjects-modified! group))))))) - (process-group group #f) - (news-group:process-cross-posts group header process-group))))) - -(define (news-group:process-cross-posts group header process-group) - (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)) - (process-group group xref))))) - (news-header:xref header))) + (process-header (news-header:group header) + (news-header:number header)) + (news-group:process-cross-posts header process-header))))) (define (news-group:get-ignored-subjects group intern?) (or (let ((table (news-group:ignored-subjects group))) @@ -3961,186 +4201,6 @@ With prefix arg, replaces the file with the list information." (and (pair? (news-group:ignored-subjects group)) (cdr (news-group:ignored-subjects group)))) -;;;; Article Ranges - -(define (range? object) - (or (article-number? object) - (and (pair? object) - (article-number? (car object)) - (article-number? (cdr object)) - (<= (car object) (cdr object))))) - -(define (article-number? object) - (and (exact-integer? object) - (> object 0))) - -(define (make-range f l) (if (= f l) f (cons f l))) -(define (range-first r) (if (pair? r) (car r) r)) -(define (range-last r) (if (pair? r) (cdr r) r)) -(define (range-length r) (if (pair? r) (+ (- (cdr r) (car r)) 1) 1)) -(define ranges-empty? null?) - -(define (count-ranges ranges) - (let loop ((ranges ranges) (count 0)) - (if (null? ranges) - count - (loop (cdr ranges) (+ count (range-length (car ranges))))))) - -(define (canonicalize-ranges ranges) - (if (null? ranges) - ranges - (let ((ranges - (sort ranges (lambda (x y) (< (range-first x) (range-first y)))))) - (let loop ((ranges ranges)) - (if (not (null? (cdr ranges))) - (let ((x (car ranges)) - (y (cadr ranges))) - (if (<= (range-first y) (+ (range-last x) 1)) - (begin - (set-car! ranges - (make-range (range-first x) - (max (range-last x) - (range-last y)))) - (set-cdr! ranges (cddr ranges)) - (loop ranges)) - (loop (cdr ranges)))))) - ranges))) - -(define (clip-ranges! ranges first last) - (let ((holder - (cons 'HOLDER - (let clip-first ((ranges ranges)) - (cond ((or (null? ranges) - (<= first (range-first (car ranges)))) - ranges) - ((< (range-last (car ranges)) first) - (clip-first (cdr ranges))) - (else - (set-car! ranges - (make-range first (range-last (car ranges)))) - ranges)))))) - (let clip-last ((ranges (cdr holder)) (prev holder)) - (cond ((null? ranges) - unspecific) - ((< (range-last (car ranges)) last) - (clip-last (cdr ranges) ranges)) - ((> (range-first (car ranges)) last) - (set-cdr! prev '())) - (else - (if (> (range-last (car ranges)) last) - (set-car! ranges - (make-range (range-first (car ranges)) - last))) - (set-cdr! ranges '())))) - (cdr holder))) - -(define (complement-ranges ranges first last) - (if (null? ranges) - (list (make-range first last)) - (let loop - ((e (range-last (car ranges))) - (ranges (cdr ranges)) - (result - (let ((s (range-first (car ranges)))) - (if (< first s) - (list (make-range first (- s 1))) - '())))) - (if (null? ranges) - (reverse! (if (< e last) - (cons (make-range (+ e 1) last) result) - result)) - (loop (range-last (car ranges)) - (cdr ranges) - (cons (make-range (+ e 1) (- (range-first (car ranges)) 1)) - result)))))) - -(define (merge-ranges ranges ranges*) - (cond ((null? ranges) - ranges*) - ((null? ranges*) - ranges) - ((< (range-last (car ranges)) (range-first (car ranges*))) - (cons (car ranges) (merge-ranges (cdr ranges) ranges*))) - ((< (range-last (car ranges*)) (range-first (car ranges))) - (cons (car ranges*) (merge-ranges ranges (cdr ranges*)))) - (else - (cons (make-range (min (range-first (car ranges)) - (range-first (car ranges*))) - (max (range-last (car ranges)) - (range-last (car ranges*)))) - (merge-ranges (cdr ranges) (cdr ranges*)))))) - -(define (add-to-ranges! ranges number) - (let ((holder (cons 'HOLDER ranges))) - (let loop ((ranges ranges) (prev holder)) - (if (null? ranges) - (set-cdr! prev (list (make-range number number))) - (let ((f (range-first (car ranges))) - (l (range-last (car ranges)))) - (cond ((> number (+ l 1)) - (loop (cdr ranges) ranges)) - ((< number (- f 1)) - (set-cdr! prev (cons (make-range number number) ranges))) - (else - (let ((f (min f number)) - (l (max l number))) - (if (and (not (null? (cdr ranges))) - (= (+ l 1) (range-first (cadr ranges)))) - (begin - (set-car! ranges - (make-range f (range-last (cadr ranges)))) - (set-cdr! ranges (cddr ranges))) - (set-car! ranges (make-range f l))))))))) - (cdr holder))) - -(define (remove-from-ranges! ranges number) - (let ((holder (cons 'HOLDER ranges))) - (let loop ((ranges ranges) (prev holder)) - (if (not (null? ranges)) - (let ((f (range-first (car ranges))) - (l (range-last (car ranges)))) - (cond ((> number l) - (loop (cdr ranges) ranges)) - ((>= number f) - (if (= number f) - (if (= number l) - (set-cdr! prev (cdr ranges)) - (set-car! ranges (make-range (+ f 1) l))) - (if (= number l) - (set-car! ranges (make-range f (- l 1))) - (begin - (set-car! ranges (make-range (+ number 1) l)) - (set-cdr! prev - (cons (make-range f (- number 1)) - ranges)))))))))) - (cdr holder))) - -(define (member-of-ranges? ranges number) - (let loop ((ranges ranges)) - (and (not (null? ranges)) - (or (<= (range-first (car ranges)) number (range-last (car ranges))) - (loop (cdr ranges)))))) - -(define (ranges->list ranges) - (let loop ((ranges ranges) (result '())) - (if (null? ranges) - (reverse! result) - (loop (cdr ranges) - (let ((e (range-last (car ranges)))) - (let loop ((n (range-first (car ranges))) (result result)) - (let ((result (cons n result))) - (if (= n e) - result - (loop (+ n 1) result))))))))) - -(define (for-each-range-element procedure ranges) - (for-each (lambda (range) - (let ((e (+ (range-last range) 1))) - (do ((n (range-first range) (+ n 1))) - ((= n e) unspecific) - (procedure n)))) - ranges)) - ;;;; News-Header Extensions (define-structure (news-header-extra @@ -4163,11 +4223,11 @@ With prefix arg, replaces the file with the list information." (not number)) #\D) ((news-header:ignore? header) - (set-news-group:ranges-seen! + (set-news-group:ranges-deleted! group - (add-to-ranges! (news-group:ranges-seen group) number)) + (add-to-ranges! (news-group:ranges-deleted group) number)) #\I) - ((news-header:article-seen? header) #\D) + ((news-header:article-deleted? header) #\D) ((news-header:article-marked? header) #\M) (else #\space)))) @@ -4183,33 +4243,35 @@ With prefix arg, replaces the file with the list information." (define (set-news-header:index! header value) (set-news-header-extra:index! (get-news-header-extra header #t) value)) -(define (news-header:article-seen! header buffer) +(define (news-header:article-deleted! header buffer) (if (not (eqv? (news-header:status header) #\I)) (set-news-header:status! header #\D)) - (news-group:article-seen! (news-header:group header) header buffer)) + (news-group:article-deleted! header buffer)) -(define (news-header:article-unseen! header buffer) +(define (news-header:article-not-deleted! header buffer) (set-news-header:status! header #\space) - (news-group:article-unseen! (news-header:group header) header buffer)) + (news-group:article-not-deleted! header buffer)) (define (news-header:article-marked! header buffer) (if (not (news-header:pre-read-body? header)) (begin (set-news-header:status! header #\M) - (news-group:article-marked! (news-header:group header) - header buffer)))) + (news-group:article-marked! header buffer)))) + +(define (news-header:article-browsed! header buffer) + (news-group:article-browsed! header buffer)) (define (news-header:article-ignored! header buffer) (set-news-header:status! header #\I) - (news-group:article-ignored! (news-header:group header) header buffer)) + (news-group:article-ignored! header buffer)) (define (news-header:article-not-ignored! header buffer) (set-news-header:status! header #\space) - (news-group:article-not-ignored! (news-header:group header) header buffer)) + (news-group:article-not-ignored! header buffer)) (define (news-header:unread? header) (and (news-header:real? header) - (not (news-header:article-seen? header)))) + (not (news-header:article-deleted? header)))) (define (news-header:next-in-thread header) (let scan-down ((header header)) @@ -4318,10 +4380,10 @@ With prefix arg, replaces the file with the list information." bodies (loop header bodies)))))) -(define (news-thread:all-articles-seen? thread) +(define (news-thread:all-articles-deleted? thread) (let loop ((header (news-thread:first-header thread news-header:real?))) (or (not header) - (and (news-header:article-seen? header) + (and (news-header:article-deleted? header) (loop (news-thread:next-header header news-header:real?)))))) (define (news-thread:show-collapsed? thread)