;;; -*-Scheme-*-
;;;
-;;; $Id: imail-summary.scm,v 1.3 2000/05/18 05:19:00 cph Exp $
+;;; $Id: imail-summary.scm,v 1.4 2000/05/18 17:16:28 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+(define-variable imail-summary-pop-up-message
+ "If true, selecting a message in the IMAIL summary buffer pops up the
+ message buffer in a separate window.
+If false, the message buffer is updated but not popped up."
+ #t
+ boolean?)
+
(define-command imail-summary
"Display a summary of the selected folder, one line per message."
()
"-summary"))))
(without-interrupts
(lambda ()
+ (add-kill-buffer-hook buffer imail-summary-detach)
(add-event-receiver! (folder-modification-event folder)
imail-summary-modification-event)
+ (buffer-put! folder-buffer 'IMAIL-SUMMARY-BUFFER buffer)
(associate-buffer-with-imail-buffer folder-buffer buffer)
(buffer-put! buffer 'IMAIL-MESSAGE-METHOD
- imail-summary-selected-message)
- (buffer-put! folder-buffer 'IMAIL-SUMMARY-BUFFER buffer)
- (add-kill-buffer-hook buffer imail-summary-detach)))
+ imail-summary-selected-message)))
buffer)))))
(buffer-put! buffer 'IMAIL-SUMMARY-DESCRIPTION description)
(buffer-put! buffer 'IMAIL-SUMMARY-PREDICATE predicate)
(rebuild-imail-summary-buffer buffer)
- (select-buffer buffer)))
+ (if (not (selected-buffer? buffer))
+ (let ((windows (buffer-windows buffer)))
+ (if (pair? windows)
+ (select-window (car windows))
+ (select-buffer buffer))))
+ (if (ref-variable imail-summary-pop-up-message buffer)
+ (imail-summary-pop-up-message-buffer buffer))))
(define (imail-summary-detach buffer)
(let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)))
(if folder-buffer
- (buffer-remove! folder-buffer 'IMAIL-SUMMARY-BUFFER))))
+ (begin
+ (buffer-remove! folder-buffer 'IMAIL-SUMMARY-BUFFER)
+ (let ((folder (buffer-get folder-buffer 'IMAIL-FOLDER #f)))
+ (if folder
+ (add-event-receiver! (folder-modification-event folder)
+ imail-summary-modification-event)))))))
(define (imail-summary-modification-event folder type parameters)
(let ((buffer (imail-folder->summary-buffer folder #f)))
((FLAGS)
(let ((mark (imail-summary-message-mark buffer (car parameters))))
(if mark
- (with-read-only-defeated mark
- (lambda ()
- (group-replace-char!
- (mark-group mark)
- (mark-index mark)
- (if (message-deleted? (car parameters))
- #\D
- #\space)))))))
+ (begin
+ (with-read-only-defeated mark
+ (lambda ()
+ (group-replace-char!
+ (mark-group mark)
+ (mark-index mark)
+ (if (message-deleted? (car parameters))
+ #\D
+ #\space))))
+ (buffer-not-modified! buffer)))))
((SELECT-MESSAGE)
(let ((mark (imail-summary-message-mark buffer (car parameters))))
(if mark
- (set-buffer-point! buffer mark))))
- ((EXPUNGE)
- (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))
- ((INCREASE-LENGTH SET-LENGTH)
- (rebuild-imail-summary-buffer buffer))))))
-
+ (set-buffer-point! buffer mark)))
+ (if (ref-variable imail-summary-pop-up-message buffer)
+ (imail-summary-pop-up-message-buffer buffer)))
+ ((EXPUNGE INCREASE-LENGTH SET-LENGTH)
+ (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))))))
+\f
(define (imail-folder->summary-buffer folder error?)
(let ((buffer (imail-folder->buffer folder error?)))
(and buffer
(and error?
(error:bad-range-argument folder
'IMAIL-FOLDER->SUMMARY-BUFFER))))))
-\f
+
(define (imail-summary-message-mark buffer message)
(let ((index (message-index message)))
(and index
(line-start (buffer-start buffer) index))))
+(define (imail-summary-pop-up-message-buffer buffer)
+ (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)))
+ (if (and folder-buffer (selected-buffer? buffer))
+ (pop-up-buffer folder-buffer))))
+
(define (rebuild-imail-summary-buffer buffer)
- (set-buffer-writeable! buffer)
(buffer-widen! buffer)
- (region-delete! (buffer-region buffer))
- (fill-imail-summary-buffer! buffer
- (selected-folder #f buffer)
- (buffer-get buffer
- 'IMAIL-SUMMARY-PREDICATE
- #f))
- (set-buffer-major-mode! buffer (ref-mode-object imail))
- (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-summary-revert-buffer)
- (remove-kill-buffer-hook buffer imail-kill-buffer)
+ (with-read-only-defeated (buffer-start buffer)
+ (lambda ()
+ (region-delete! (buffer-region buffer))
+ (fill-imail-summary-buffer! buffer
+ (selected-folder #f buffer)
+ (buffer-get buffer
+ 'IMAIL-SUMMARY-PREDICATE
+ #f))))
+ (set-buffer-major-mode! buffer (ref-mode-object imail-summary))
(buffer-not-modified! buffer)
(set-buffer-point! buffer (buffer-start buffer))
- (local-set-variable! truncate-lines #t buffer)
- (local-set-variable! mode-line-process
- (list ": "
- (buffer-get buffer
- 'IMAIL-SUMMARY-DESCRIPTION
- "All"))
- buffer)
(let ((message
(selected-message #f (buffer-get buffer 'IMAIL-FOLDER-BUFFER))))
(if message
(imail-summary-select-message buffer message))))
-(define (imail-summary-revert-buffer buffer dont-use-auto-save? dont-confirm?)
- dont-use-auto-save? dont-confirm?
- (if (or dont-confirm?
- (prompt-for-yes-or-no? "Revert summary buffer"))
- (rebuild-imail-summary-buffer buffer)))
-
(define (imail-summary-selected-message buffer)
(let ((folder (selected-folder #f buffer))
(index
4 #\space mark)
(insert-string " " mark)
(insert-string-pad-right (message-summary-date-string message)
- 11 #\space mark)
+ 6 #\space mark)
+ (insert-string " " mark)
+ (let ((target-column (+ (mark-column mark) 40)))
+ (insert-string (message-summary-subject-string message) mark)
+ (if (> (mark-column mark) target-column)
+ (delete-string (move-to-column mark target-column) mark))
+ (if (< (mark-column mark) target-column)
+ (insert-chars #\space (- target-column (mark-column mark)) mark)))
(insert-string " " mark)
- (insert-string-pad-right (let ((s (message-summary-from-string message)))
- (if (> (string-length s) 24)
- (string-head s 24)
- s))
- 24 #\space mark)
- (insert-string " " mark)
- (insert-string (message-summary-subject-string message) mark)
+ (insert-string (message-summary-from-string message) mark)
(insert-newline mark))
(define (message-summary-date-string message)
(string-append
(string-pad-left (number->string (decoded-time/day dt)) 2)
" "
- (month/short-string (decoded-time/month dt))
- " "
- (number->string (decoded-time/year dt))))
+ (month/short-string (decoded-time/month dt))))
"")))
(define (message-summary-from-string message)
(let ((i (string-find-next-char s #\newline)))
(if i
(string-head s i)
- s))))
\ No newline at end of file
+ s))))
+\f
+(define-major-mode imail-summary imail "IMAIL Summary"
+ "Major mode in effect in IMAIL summary buffer.
+This mode is like IMAIL mode, with the addition of some specialized commands.
+
+\\{imail-summary}"
+ (lambda (buffer)
+ (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-summary-revert-buffer)
+ (remove-kill-buffer-hook buffer imail-kill-buffer)
+ (local-set-variable! truncate-lines #t buffer)
+ (local-set-variable! mode-line-process
+ (list ": "
+ (buffer-get buffer
+ 'IMAIL-SUMMARY-DESCRIPTION
+ "All"))
+ buffer)))
+
+(define (imail-summary-revert-buffer buffer dont-use-auto-save? dont-confirm?)
+ dont-use-auto-save? dont-confirm?
+ (if (or dont-confirm?
+ (prompt-for-yes-or-no? "Revert summary buffer"))
+ (rebuild-imail-summary-buffer buffer)))
+
+(define-key 'imail-summary #\space 'imail-summary-select-message)
+(define-key 'imail-summary #\rubout 'imail-undelete-previous-message)
+(define-key 'imail-summary #\c-n 'imail-summary-next-message)
+(define-key 'imail-summary #\c-p 'imail-summary-previous-message)
+(define-key 'imail-summary #\. 'undefined)
+(define-key 'imail-summary #\q 'imail-summary-quit)
+(define-key 'imail-summary #\m-< 'imail-select-message)
+(define-key 'imail-summary #\m-> 'imail-last-message)
+
+(define-command imail-summary-select-message
+ "Select the message that point is on and show it in another window."
+ ()
+ (lambda ()
+ (select-message (selected-folder) (selected-message) #t)
+ (imail-summary-pop-up-message-buffer (selected-buffer))))
+
+(define-command imail-summary-next-message
+ "Show following message whether deleted or not.
+With prefix argument N, moves forward N messages,
+or backward if N is negative."
+ "p"
+ (lambda (delta)
+ (if (selected-message #f)
+ ((ref-command imail-next-message) delta)
+ (begin
+ ((ref-command next-line) delta)
+ (let ((message (selected-message #f)))
+ (if message
+ (select-message (selected-folder) message)))))))
+
+(define-command imail-summary-previous-message
+ "Show previous message whether deleted or not.
+With prefix argument N, moves backward N messages,
+or forward if N is negative."
+ "p"
+ (lambda (delta)
+ ((ref-command imail-summary-next-message) (- delta))))
+
+(define-command imail-summary-quit
+ "Quit out of IMAIL."
+ ()
+ (lambda ()
+ (let ((folder-buffer
+ (buffer-get (selected-buffer) 'IMAIL-FOLDER-BUFFER #f)))
+ (if folder-buffer
+ (for-each window-delete! (buffer-windows folder-buffer))))
+ ((ref-command imail-quit))
+ ((ref-command bury-buffer))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff