From: Chris Hanson Date: Wed, 17 May 2000 15:46:57 +0000 (+0000) Subject: Implement MESSAGE-ATTACHED? and MESSAGE-DETACHED?, to abstract the X-Git-Tag: 20090517-FFI~3850 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=de95b45179fc575ded72582dbfa3efdc0f34933b;p=mit-scheme.git Implement MESSAGE-ATTACHED? and MESSAGE-DETACHED?, to abstract the details of this query. Refine the method used to obtain the selected message, by saving the message index when a message is detached, and using that index to choose a new message. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 2c2355834..d9a008cd5 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.62 2000/05/17 15:03:49 cph Exp $ +;;; $Id: imail-core.scm,v 1.63 2000/05/17 15:46:45 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -185,7 +185,7 @@ (write-instance-helper 'FOLDER folder port (lambda () (write-char #\space port) - (write (url->string (folder-url folder)) port)))) + (write (url-presentation-name (folder-url folder)) port)))) (define (guarantee-folder folder procedure) (if (not (folder? folder)) @@ -317,31 +317,21 @@ initial-value 0) (folder define standard initial-value #f) - (index define standard)) + (index define standard + initial-value #f)) (define-method write-instance ((message ) port) (write-instance-helper 'MESSAGE message port (lambda () - (if (message-folder message) - (begin - (write-char #\space port) - (write (message-folder message) port)))))) + (write-char #\space port) + (write (message-folder message) port) + (write-char #\space port) + (write (message-index message) port)))) (define (guarantee-message message procedure) (if (not (message? message)) (error:wrong-type-argument message "IMAIL message" procedure))) -(define (attach-message! message folder index) - (guarantee-folder folder 'ATTACH-MESSAGE!) - (set-message-folder! message folder) - (set-message-index! message index) - (message-modified! message)) - -(define (detach-message! message) - (set-message-folder! message #f) - (set-message-index! message #f) - (message-modified! message)) - (define (message-modified! message) (without-interrupts (lambda () @@ -352,8 +342,26 @@ (if folder (folder-modified! folder)))))) -(define-generic message-internal-time (message)) +(define (message-attached? message #!optional folder) + (let ((folder (if (default-object? folder) #f folder))) + (if folder + (eq? folder (message-folder message)) + (message-folder message)))) +(define (message-detached? message) + (not (message-folder message))) + +(define (attach-message! message folder index) + (guarantee-folder folder 'ATTACH-MESSAGE!) + (set-message-folder! message folder) + (set-message-index! message index) + (message-modified! message)) + +(define (detach-message! message) + (set-message-folder! message #f) + (message-modified! message)) + +(define-generic message-internal-time (message)) (define-method message-internal-time ((message )) (let loop ((headers (get-all-header-fields message "received")) (winner #f)) (if (pair? headers) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index bad9e0a2e..c262e84b1 100644 --- a/v7/src/imail/imail-top.scm +++ b/v7/src/imail/imail-top.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-top.scm,v 1.47 2000/05/17 13:41:08 cph Exp $ +;;; $Id: imail-top.scm,v 1.48 2000/05/17 15:46:57 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -300,33 +300,36 @@ DEL Scroll to previous screen of this message. (define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?) dont-use-auto-save? - (let ((folder (selected-folder #f buffer)) + (let ((folder (selected-folder #t buffer)) (message (selected-message #f buffer))) - (let ((index (and message (message-index message)))) - (if (let ((status (folder-sync-status folder))) - (case status - ((UNSYNCHRONIZED) - #t) - ((SYNCHRONIZED PERSISTENT-MODIFIED) - (or dont-confirm? - (prompt-for-yes-or-no? "Revert buffer from folder"))) - ((FOLDER-MODIFIED) - (prompt-for-yes-or-no? "Discard your changes to folder")) - ((BOTH-MODIFIED) - (prompt-for-yes-or-no? - "Persistent copy of folder changed; discard your changes")) - ((PERSISTENT-DELETED) - (editor-error "Persistent copy of folder deleted.")) - (else - (error "Unknown folder-sync status:" status)))) - (begin - (discard-folder-cache folder) - (select-message - folder - (cond ((eq? folder (message-folder message)) message) - ((and (<= 0 index) (< index (folder-length folder))) index) - (else (first-unseen-message folder))) - #t)))))) + (if (let ((status (folder-sync-status folder))) + (case status + ((UNSYNCHRONIZED) + #t) + ((SYNCHRONIZED PERSISTENT-MODIFIED) + (or dont-confirm? + (prompt-for-yes-or-no? "Revert buffer from folder"))) + ((FOLDER-MODIFIED) + (prompt-for-yes-or-no? "Discard your changes to folder")) + ((BOTH-MODIFIED) + (prompt-for-yes-or-no? + "Persistent copy of folder changed; discard your changes")) + ((PERSISTENT-DELETED) + (editor-error "Persistent copy of folder deleted.")) + (else + (error "Unknown folder-sync status:" status)))) + (begin + (discard-folder-cache folder) + (select-message + folder + (cond ((not message) (first-unseen-message folder)) + ((message-attached? message folder) message) + ((let ((index (message-index message))) + (and index + (< index (folder-length folder)) + index))) + (else (first-unseen-message folder))) + #t))))) (define (imail-kill-buffer buffer) (let ((folder (selected-folder #f buffer))) @@ -428,7 +431,7 @@ With prefix argument N moves backward N messages with these flags." 'DEFAULT-TYPE 'INSERTED-DEFAULT 'HISTORY 'IMAIL-NEXT-FLAGGED-MESSAGE 'HISTORY-INDEX 0))) - + (define (move-relative delta predicate noun) (if (not (= 0 delta)) (call-with-values @@ -449,19 +452,24 @@ With prefix argument N moves backward N messages with these flags." (select-message (selected-folder) next)) (else (loop (- delta 1) next next))))))))) - + (define (select-message folder selector #!optional force? full-headers?) (let ((buffer (imail-folder->buffer folder #t)) (message - (cond ((or (not selector) (message? selector)) - selector) - ((and (exact-integer? selector) - (<= 0 selector) - (< selector (folder-length folder))) - (get-message folder selector)) - (else - (error:wrong-type-argument selector "message selector" - 'SELECT-MESSAGE)))) + (let loop ((selector selector)) + (cond ((message? selector) + (and (message-attached? selector folder) + selector + (loop (message-index selector)))) + ((not selector) + selector) + ((and (exact-integer? selector) + (<= 0 selector) + (< selector (folder-length folder))) + (get-message folder selector)) + (else + (error:wrong-type-argument selector "message selector" + 'SELECT-MESSAGE))))) (full-headers? (if (default-object? full-headers?) #f full-headers?))) (if (or (if (default-object? force?) #f force?) (not (eq? message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN)))) @@ -491,19 +499,29 @@ With prefix argument N moves backward N messages with these flags." (imail-update-mode-line! buffer))) (define (selected-message #!optional error? buffer) - (let ((buffer - (if (or (default-object? buffer) (not buffer)) - (selected-buffer) - buffer)) - (error? (if (default-object? error?) #t error?))) - (let ((message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN))) - (if (eq? message 'UNKNOWN) - (error "IMAIL-MESSAGE property not bound:" buffer)) - (or (and message - (message-folder message) - message) - (and error? - (error "No selected IMAIL message.")))))) + (or (let ((buffer + (if (or (default-object? buffer) (not buffer)) + (selected-buffer) + buffer))) + (let ((message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN))) + (if (eq? message 'UNKNOWN) + (error "IMAIL-MESSAGE property not bound:" buffer)) + (and message + (let ((folder (selected-folder #f buffer))) + (if (message-attached? message folder) + message + (let ((message + (let ((index + (and folder + (message-detached? message) + (message-index message)))) + (and index + (< index (folder-length folder)) + (get-message folder index))))) + (buffer-put! buffer 'IMAIL-MESSAGE message) + message)))))) + (and (if (default-object? error?) #t error?) + (error "No selected IMAIL message.")))) (define (imail-update-mode-line! buffer) (local-set-variable! mode-line-process