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 2c2355834e5892f4723e39773bd5d620726a5554..d9a008cd564756a056bec58fe882865c3989ce55 100644 (file)
--- 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 <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 <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 bad9e0a2e3038174f38f280528d6bb45c262a7ed..c262e84b11c86c433fb87f9b107ee589097d07bc 100644 (file)
--- 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)))
-\f
+
 (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)))))))))
-
+\f
 (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."))))
 \f
 (define (imail-update-mode-line! buffer)
   (local-set-variable! mode-line-process