#| -*-Scheme-*-
-$Id: imail-summary.scm,v 1.59 2008/08/31 19:32:09 riastradh Exp $
+$Id: imail-summary.scm,v 1.60 2008/09/04 21:55:20 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
"Display a summary of the search results for a string of text."
"sSearch string"
(lambda (pattern)
- (imail-summary (string-append "Search: " pattern)
- (lambda (folder)
- ((imail-ui:message-wrapper "Searching for " pattern)
- (lambda ()
- (map (lambda (index)
- (get-message folder index))
- (search-folder folder pattern))))))))
+ (imail-summary
+ (string-append "Search: " pattern)
+ (lambda (folder start end)
+ ((imail-ui:message-wrapper "Searching for " pattern)
+ (lambda ()
+ (filter-map (lambda (index)
+ (and (<= start index)
+ (< index end)
+ (%get-message folder index)))
+ (%search-folder folder pattern))))))))
\f
(define (imail-summary description procedure)
(let* ((folder (selected-folder))
(if (pair? windows)
(select-window (car windows))
(select-buffer buffer))))
- (preload-folder-outlines folder)
(rebuild-imail-summary-buffer buffer)))
(define (imail-summary-by-predicate description predicate)
(imail-summary
description
- (lambda (folder)
- (let ((end (folder-length folder)))
- (let loop ((i 0) (messages '()))
- (if (< i end)
- (loop (+ i 1)
- (let ((message (get-message folder i)))
- (if (predicate message)
- (cons message messages)
- messages)))
- (reverse! messages)))))))
+ (lambda (folder start end)
+ (let loop ((i start) (messages '()))
+ (if (< i end)
+ (loop (+ i 1)
+ (let ((message (get-message folder i)))
+ (if (predicate message)
+ (cons message messages)
+ messages)))
+ (reverse! messages))))))
\f
(define (imail-summary-detach buffer)
(let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)))
(let ((buffer (imail-folder->summary-buffer folder #f)))
(if buffer
(case type
+ ((STATUS)
+ (maybe-add-command-suffix! buffer-modeline-event!
+ buffer
+ 'PROCESS-STATUS))
((FLAGS)
(let ((message (car parameters)))
- (call-with-values
- (lambda () (imail-summary-find-message buffer message))
- (lambda (mark approximate?)
- (if (and mark (not approximate?))
- (begin
- (let ((mark (mark+ mark 1 'ERROR)))
- (with-read-only-defeated mark
- (lambda ()
- (group-replace-string!
- (mark-group mark)
- (mark-index mark)
- (message-flag-markers message)))))
- (buffer-not-modified! buffer)))))))
+ (maybe-add-command-suffix! adjust-imail-summary-flags
+ buffer
+ message)))
((SELECT-MESSAGE)
(let ((message (car parameters)))
(if message
- (imail-summary-select-message buffer message))))
- ((EXPUNGE INCREASE-LENGTH SET-LENGTH REORDERED)
+ (maybe-add-command-suffix! imail-summary-select-message
+ buffer
+ message))))
+ ((INCREASE-LENGTH)
+ (let ((index (car parameters))
+ (count (cadr parameters))
+ (procedure (buffer-get buffer 'IMAIL-SUMMARY-PROCEDURE)))
+ (expand-imail-summary-buffer buffer
+ (procedure folder index count))))
+ ((EXPUNGE)
+ (let ((message (car parameters))
+ (%index (cadr parameters))
+ (index (caddr parameters))
+ (key (cadddr parameters)))
+ %index key ;ignore
+ (expunge-from-imail-summary-buffer buffer message index)))
+ ((SET-LENGTH REORDERED)
(maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))))))
\f
;;;; Summary content generation
(define (rebuild-imail-summary-buffer buffer)
(let ((folder (selected-folder #f buffer)))
(if folder
- (let ((msg "Generating summary buffer..."))
- (message msg)
+ (let ((msg "Generating summary buffer"))
+ (preload-folder-outlines folder)
+ (message msg "...")
(buffer-widen! buffer)
(with-read-only-defeated (buffer-start buffer)
(lambda ()
folder
(buffer-get buffer
'IMAIL-SUMMARY-PROCEDURE
- #f))))
+ #f)
+ msg)))
(set-buffer-major-mode! buffer (ref-mode-object imail-summary))
(buffer-not-modified! buffer)
(set-buffer-point! buffer (imail-summary-first-line buffer))
- (message msg "done")
+ (message msg "...done")
(let ((message
(selected-message #f
(buffer-get buffer
(if message
(imail-summary-select-message buffer message)))))))
-(define (fill-imail-summary-buffer! buffer folder procedure)
+(define (fill-imail-summary-buffer! buffer folder procedure msg)
(buffer-remove! buffer 'IMAIL-SUMMARY-MESSAGES)
(let ((end (folder-length folder)))
- (let ((messages (procedure folder))
+ (let ((messages (procedure folder 0 end))
(index-digits (exact-nonnegative-integer-digits end))
(show-date? (ref-variable imail-summary-show-date buffer)))
+ (buffer-put! buffer 'IMAIL-SUMMARY-INDEX-DIGITS index-digits)
(let ((mark (mark-left-inserting-copy (buffer-start buffer))))
(insert-string " Flags" mark)
(insert-string " " mark)
(max 4 (- (mark-x-size mark) (+ (mark-column mark) 1)))
mark)
(insert-newline mark)
- ((imail-ui:message-wrapper "Generating summary buffer")
+ ((imail-ui:message-wrapper msg)
(lambda ()
(do ((total (length messages))
(messages messages (cdr messages))
(mark-temporary! mark))
(buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES (list->vector messages)))))
\f
+(define (expand-imail-summary-buffer buffer new-messages)
+ (let ((old-messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f))
+ (index-digits (buffer-get buffer 'IMAIL-SUMMARY-INDEX-DIGITS #f))
+ (folder (imail-summary-buffer->folder buffer #t))
+ (msg "Expanding IMAIL summary buffer"))
+ (define (lose)
+ (message msg "...failed")
+ (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))
+ (define (win messages)
+ (buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES
+ (list->vector (reverse! messages)))
+ (message msg "...done"))
+ (define (insert new-message mark)
+ (message msg "...message " (number->string (message-index new-message)))
+ (with-read-only-defeated buffer
+ (lambda ()
+ (write-imail-summary-line! new-message index-digits mark))))
+ (define (merge new-messages old-messages mark messages)
+ (cond ((not (pair? new-messages))
+ (win (append-reverse old-messages messages)))
+ ((not (pair? old-messages))
+ (let ((mark (mark-permanent-copy mark)))
+ (for-each (lambda (new-message)
+ (insert new-message mark))
+ new-messages))
+ (win (append-reverse new-messages messages)))
+ (else
+ (let ((new-message (car new-messages))
+ (old-message (car old-messages)))
+ (cond ((< (message-index new-message)
+ (message-index old-message))
+ (let ((mark* (mark-permanent-copy mark)))
+ (insert new-message mark*)
+ (mark-temporary! mark*)
+ (merge (cdr new-messages)
+ old-messages
+ mark*
+ (cons new-message messages))))
+ ((eqv? (imail-summary-selected-message-index mark)
+ (message-index old-message))
+ (merge new-messages
+ (cdr old-messages)
+ (line-start mark 1)
+ (cons old-message messages)))
+ (else
+ (lose)))))))
+ (message msg "...")
+ (preload-folder-outlines folder)
+ (if (and old-messages
+ (positive? (vector-length old-messages))
+ (eqv? index-digits
+ (exact-nonnegative-integer-digits (folder-length folder))))
+ (receive (mark approximate?)
+ (imail-summary-find-message buffer (vector-ref old-messages 0) #f)
+ (if (or (not mark) approximate?)
+ (lose)
+ (merge new-messages
+ (vector->list old-messages)
+ mark
+ '())))
+ (lose))))
+\f
+(define (expunge-from-imail-summary-buffer buffer expunged-message index)
+ (let ((messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f))
+ (msg
+ (string-append "Expunging message "
+ (number->string index)
+ " from IMAIL summary buffer")))
+ (define (lose)
+ (message msg "...failed")
+ (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))
+ (define (win index)
+ (let* ((end (vector-length messages))
+ (copy (make-vector (- end 1))))
+ (subvector-move-right! messages 0 index copy 0)
+ (subvector-move-right! messages (+ index 1) end copy index)
+ (buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES copy))
+ (message msg "...done"))
+ (message msg "...")
+ (if messages
+ (let ((summary-index
+ (vector-find-next-element messages expunged-message)))
+ (if summary-index
+ (let ((mark
+ (line-start (imail-summary-first-line buffer)
+ summary-index
+ #f)))
+ (if (and mark
+ (eqv? (imail-summary-selected-message-index mark)
+ index))
+ (begin
+ (with-read-only-defeated buffer
+ (lambda ()
+ (delete-string mark (line-start mark 1 'LIMIT))))
+ (if (maybe-decrement-imail-summary-indices buffer index)
+ (win summary-index)
+ (lose)))
+ (lose)))
+ (lose)))
+ (lose))))
+
+(define (maybe-decrement-imail-summary-indices buffer index)
+ (let ((index-digits (buffer-get buffer 'IMAIL-SUMMARY-INDEX-DIGITS #f)))
+ (and index-digits
+ (let loop ((mark (imail-summary-first-line buffer)))
+ (or (group-end? mark)
+ ;; One space, five flags, and one more space: seven columns.
+ (let* ((mark (mark+ mark 7))
+ (mark* (mark+ mark index-digits))
+ (index*
+ (string->number
+ (string-trim (extract-string mark mark*)))))
+ (and index*
+ (begin
+ (if (> index* index)
+ (let ((mark (mark-permanent-copy mark)))
+ (with-read-only-defeated buffer
+ (lambda ()
+ (delete-string mark mark*)
+ (insert-message-index (- index* 1)
+ index-digits
+ mark)))
+ (mark-temporary! mark)))
+ (loop (line-start mark 1 'LIMIT))))))))))
+
+(define (adjust-imail-summary-flags buffer message)
+ (receive (mark approximate?) (imail-summary-find-message buffer message #f)
+ (if (and mark (not approximate?))
+ (begin
+ (let ((mark (mark+ mark 1 'ERROR)))
+ (with-read-only-defeated mark
+ (lambda ()
+ (group-replace-string! (mark-group mark)
+ (mark-index mark)
+ (message-flag-markers message))))
+ (buffer-not-modified! buffer))))))
+\f
(define (write-imail-summary-line! message index-digits mark)
(insert-char #\space mark)
(insert-string (message-flag-markers message) mark)
(insert-char #\space mark)
- (insert-string-pad-left (number->string (+ (message-index message) 1))
- index-digits #\space mark)
+ (insert-message-index (+ (message-index message) 1) index-digits mark)
(insert-string " " mark)
(insert-string (message-summary-length-string message) mark)
(if (ref-variable imail-summary-show-date mark)
(insert-string (message-summary-from-string message) mark)
(insert-newline mark))
+(define (insert-message-index index index-digits mark)
+ (insert-string-pad-left (number->string index) index-digits #\space mark))
+
(define (imail-summary-subject-width mark)
(max (let ((w (ref-variable imail-summary-subject-width mark)))
(if (< w 0)
(month/short-string (decoded-time/month dt))))
(make-string 6 #\space))))
+;++ When the RFC (2)822 parser works better so that we can rely on it
+;++ in all folders, we'll use the message's MIME envelope rather than
+;++ this pile of cruft.
+
(define (message-summary-from-string message)
(let* ((s
(decorated-string-append
(define (imail-summary-navigators buffer)
(define (first-unseen-message folder)
- (let loop ((message (first-message folder)))
- (and message
- (if (message-unseen? message)
- message
- (loop (next-message message #f))))))
+ folder ;ignore
+ (let ((messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f)))
+ (and messages
+ (let ((length (vector-length messages)))
+ (let loop ((index 0))
+ (and (< index length)
+ (let ((message (vector-ref messages index)))
+ (if (message-unseen? message)
+ message
+ (loop (+ index 1))))))))))
(define (first-message folder)
(imail-summary-navigator/edge buffer folder
(eq? folder (imail-summary-buffer->folder buffer #f))
(let loop
((m
- (call-with-values
- (lambda () (imail-summary-find-message buffer message))
- (lambda (m approximate?)
- (if (and approximate?
- ((if (< delta 0) < >)
- (imail-summary-selected-message-index m)
- (message-index message)))
- m
- (and m (line-start m delta #f)))))))
+ (receive (m approximate?)
+ (imail-summary-find-message buffer message #t)
+ (if (and approximate?
+ ((if (< delta 0) < >)
+ (imail-summary-selected-message-index m)
+ (message-index message)))
+ m
+ (and m (line-start m delta #f))))))
(and m
(let ((index (imail-summary-selected-message-index m)))
(and index
(define (imail-summary-select-message buffer message)
(highlight-region (buffer-unclipped-region buffer) #f)
- (call-with-values (lambda () (imail-summary-find-message buffer message))
- (lambda (mark approximate?)
- (if mark
- (begin
- (set-buffer-point! buffer mark)
- (if (and (not approximate?)
- (ref-variable imail-summary-highlight-message buffer))
- (begin
- (highlight-region
- (make-region (if (imail-summary-match-line mark)
- (or (re-match-start 3)
- (re-match-end 0))
- mark)
- (line-end mark 0))
- #t)
- (buffer-not-modified! buffer)))))))
+ (receive (mark approximate?) (imail-summary-find-message buffer message #t)
+ (if mark
+ (begin
+ (set-buffer-point! buffer mark)
+ (if (and (not approximate?)
+ (ref-variable imail-summary-highlight-message buffer))
+ (begin
+ (highlight-region
+ (make-region (if (imail-summary-match-line mark)
+ (or (re-match-start 3)
+ (re-match-end 0))
+ mark)
+ (line-end mark 0))
+ #t)
+ (buffer-not-modified! buffer))))))
(if (ref-variable imail-summary-pop-up-message buffer)
(imail-summary-pop-up-message-buffer buffer)))
height
(round->exact (* (window-y-size window) height)))))
\f
-(define (imail-summary-find-message buffer message)
+(define (imail-summary-find-message buffer message approximate?)
(let ((mark
(let ((index
(let ((mv (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES)))
(message-index message)))
(values mark #f)
(let ((index (message-index message)))
- (if index
+ (if (and index approximate?)
(let ((m (imail-summary-first-line buffer)))
(let ((index* (imail-summary-selected-message-index m)))
(cond ((not index*)
projects / mit-scheme.git / commitdiff