Change the way folder modification events are signalled. Now there

are several different types of events, and each type has specific
parameters associated with it.  The intent of this change is to allow
the front end to figure out what is happening in the back end and
reflect that to the user.

Also: eliminate MESSAGE-MODIFICATION-COUNT and eliminate a handful of
modification events that were not visible at the folder abstraction
boundary (events are now part of the abstraction boundary, and should
not reflect irrelevant internal state).

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 06780da575b0825e0036dbba8fc77937a51c4382..ab7bbc6c29d56d9f5011c5f3ac1a79165119b1bb 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.68 2000/05/17 20:52:21 cph Exp $
+;;; $Id: imail-core.scm,v 1.69 2000/05/18 03:42:55 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -207,13 +207,16 @@
 (define-method ->url ((folder <folder>))
   (folder-url folder))
 
-(define (folder-modified! folder)
+(define (folder-modified! folder type . parameters)
   (without-interrupts
    (lambda ()
      (set-folder-modification-count!
       folder
       (+ (folder-modification-count folder) 1))))
-  (event-distributor/invoke! (folder-modification-event folder) folder))
+  (event-distributor/invoke! (folder-modification-event folder)
+                            folder
+                            type
+                            parameters))
 
 (define (get-memoized-folder url)
   (let ((folder (hash-table/get memoized-folders url #f)))
@@ -322,9 +325,8 @@
     (<imail-object>)
   (header-fields define accessor)
   (body define accessor)
-  (flags define standard)
-  (modification-count define standard
-                     initial-value 0)
+  (flags define standard
+        modifier %set-message-flags!)
   (folder define standard
          initial-value #f)
   (index define standard
@@ -342,16 +344,6 @@
   (if (not (message? message))
       (error:wrong-type-argument message "IMAIL message" procedure)))
 
-(define (message-modified! message)
-  (without-interrupts
-   (lambda ()
-     (set-message-modification-count!
-      message
-      (+ (message-modification-count message) 1))
-     (let ((folder (message-folder message)))
-       (if folder
-          (folder-modified! folder))))))
-
 (define (message-attached? message #!optional folder)
   (let ((folder (if (default-object? folder) #f folder)))
     (if folder
@@ -363,13 +355,13 @@
 
 (define (attach-message! message folder index)
   (guarantee-folder folder 'ATTACH-MESSAGE!)
-  (set-message-folder! message folder)
-  (set-message-index! message index)
-  (message-modified! message))
+  (without-interrupts
+   (lambda ()
+     (set-message-folder! message folder)
+     (set-message-index! message index))))
 
 (define (detach-message! message)
-  (set-message-folder! message #f)
-  (message-modified! message))
+  (set-message-folder! message #f))
 \f
 (define-generic message-internal-time (message))
 (define-method message-internal-time ((message <message>))
@@ -468,8 +460,7 @@
    (lambda ()
      (let ((flags (message-flags message)))
        (if (not (flags-member? flag flags))
-          (set-message-flags! message (cons flag flags))))
-     (message-modified! message))))
+          (set-message-flags! message (cons flag flags)))))))
 
 (define (clear-message-flag message flag)
   (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
@@ -477,8 +468,13 @@
    (lambda ()
      (let ((flags (message-flags message)))
        (if (flags-member? flag flags)
-          (set-message-flags! message (flags-delete! flag flags))))
-     (message-modified! message))))
+          (set-message-flags! message (flags-delete! flag flags)))))))
+
+(define (set-message-flags! message flags)
+  (%set-message-flags! message flags)
+  (let ((folder (message-folder message)))
+    (if folder
+       (folder-modified! folder 'FLAGS message))))
 
 (define (folder-flags folder)
   (let ((n (folder-length folder)))

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index f0b41bbc1689fc1a7bdccd3835bd75a77f6112f4..1e9a294642dd3c55f8ab9ad5c1105706c7acd0c5 100644 (file)
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.27 2000/05/17 17:30:58 cph Exp $
+;;; $Id: imail-file.scm,v 1.28 2000/05/18 03:42:59 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -121,24 +121,27 @@
 (define-method expunge-deleted-messages ((folder <file-folder>))
   (without-interrupts
    (lambda ()
-     (let loop
-        ((messages (file-folder-messages folder))
-         (index 0)
-         (messages* '()))
-       (cond ((not (pair? messages))
-             (set-file-folder-messages! folder (reverse! messages*)))
-            ((message-deleted? (car messages))
-             (detach-message! (car messages))
-             (folder-modified! folder)
-             (loop (cdr messages) index messages*))
-            (else
-             (if (not (eqv? index (message-index (car messages))))
-                 (begin
-                   (set-message-index! (car messages) index)
-                   (message-modified! (car messages))))
-             (loop (cdr messages)
-                   (fix:+ index 1)
-                   (cons (car messages) messages*))))))))
+     (let find-first ((messages (file-folder-messages folder)) (prev #f))
+       (if (pair? messages)
+          (if (message-deleted? (car messages))
+              (let loop
+                  ((messages messages)
+                   (prev prev)
+                   (index (message-index (car messages))))
+                (if (pair? messages)
+                    (let ((next (cdr messages)))
+                      (if (message-deleted? (car messages))
+                          (begin
+                            (detach-message! (car messages))
+                            (if prev
+                                (set-cdr! prev next)
+                                (set-file-folder-messages! folder next))
+                            (folder-modified! folder 'EXPUNGE index)
+                            (loop next prev index))
+                          (begin
+                            (set-message-index! (car messages) index)
+                            (loop (cdr messages) messages (+ index 1)))))))
+              (find-first (cdr messages) messages)))))))
 
 (define-method search-folder ((folder <file-folder>) criteria)
   (cond ((string? criteria)

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 660346a6a40c231d084a74dce20c74368c9253fd..f008a3e99f8afadbb5081532ca6bd00b592ebeb9 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.52 2000/05/17 18:40:09 cph Exp $
+;;; $Id: imail-imap.scm,v 1.53 2000/05/18 03:43:01 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -307,8 +307,7 @@
      (fill-messages-vector! folder 0)
      (if (imap-folder-uidvalidity folder)
         (set-imap-folder-unseen! folder #f))
-     (set-imap-folder-uidvalidity! folder uidvalidity)
-     (folder-modified! folder)))
+     (set-imap-folder-uidvalidity! folder uidvalidity)))
   (read-message-headers! folder 0))
 
 (define (detach-all-messages! folder)
@@ -349,8 +348,8 @@
        (let ((new-length (compute-messages-length v n)))
         (if new-length
             (set-imap-folder-messages! folder
-                                       (vector-head v new-length)))))))
-  (folder-modified! folder))
+                                       (vector-head v new-length))))
+       (folder-modified! folder 'EXPUNGE (- index 1))))))
 
 (define (initial-messages)
   (make-vector 64 #f))
@@ -414,18 +413,14 @@
                         (set-imap-folder-n-messages! folder count)
                         (fill-messages-vector! folder n)
                         (set-imap-folder-messages-synchronized?! folder #t)
-                        (folder-modified! folder)
+                        (folder-modified! folder 'INCREASE-LENGTH)
                         n)
-                       ((< count n)
-                        (error "EXISTS response decreased folder length:"
-                               folder))
+                       ((= count n)
+                        (set-imap-folder-messages-synchronized?! folder #t)
+                        #f)
                        (else
-                        (if (not (imap-folder-messages-synchronized? folder))
-                            (begin
-                              (set-imap-folder-messages-synchronized?!
-                               folder #t)
-                              (folder-modified! folder)))
-                        #f)))))))
+                        (error "EXISTS response decreased folder length:"
+                               folder))))))))
        (if n
            (read-message-headers! folder n)))
       (let ((v.n
@@ -442,7 +437,7 @@
                                #f))
                  (fill-messages-vector! folder 0)
                  (set-imap-folder-messages-synchronized?! folder #t)
-                 (folder-modified! folder)
+                 (folder-modified! folder 'SET-LENGTH)
                  (cons v n))))))
        ((imail-message-wrapper "Reading message UIDs")
         (lambda ()
@@ -462,7 +457,7 @@
                           ;; Flags might have been updated while
                           ;; reading the UIDs.
                           (if (%message-flags-initialized? m*)
-                              (%set-message-flags! m (message-flags m*)))
+                              (%%set-message-flags! m (message-flags m*)))
                           (detach-message! m*)
                           (attach-message! m folder i*)
                           (vector-set! v* i* m)
@@ -470,8 +465,7 @@
                         (begin
                           (if (> (imap-message-uid m) (imap-message-uid m*))
                               (error "Message inserted into folder:" m*))
-                          (loop (fix:+ i 1) i*)))))))
-          (folder-modified! folder))))))
+                          (loop (fix:+ i 1) i*))))))))))))
 \f
 ;;;; Message datatype
 
@@ -485,7 +479,7 @@
 (define (imap-message-connection message)
   (imap-folder-connection (message-folder message)))
 
-(define-method set-message-flags! ((message <imap-message>) flags)
+(define-method %set-message-flags! ((message <imap-message>) flags)
   (imap:command:store-flags (imap-message-connection message)
                            (message-index message)
                            (map imail-flag->imap-flag
@@ -979,18 +973,14 @@
                                  (imap:response:exists-count response))
         #f)
        ((imap:response:expunge? response)
-        (let ((folder (imap-connection-folder connection)))
-          (remove-imap-folder-message
-           folder
-           (- (imap:response:expunge-index response) 1))
-          (folder-modified! folder))
+        (remove-imap-folder-message
+         (imap-connection-folder connection)
+         (- (imap:response:expunge-index response) 1))
         #f)
        ((imap:response:flags? response)
-        (let ((folder (imap-connection-folder connection)))
-          (set-imap-folder-allowed-flags!
-           folder
-           (map imap-flag->imail-flag (imap:response:flags response)))
-          (folder-modified! folder))
+        (set-imap-folder-allowed-flags!
+         (imap-connection-folder connection)
+         (map imap-flag->imail-flag (imap:response:flags response)))
         #f)
        ((imap:response:recent? response)
         #f)
@@ -1030,31 +1020,23 @@
            (if (memq '\* pflags) #t #f))
           (set-imap-folder-permanent-flags!
            folder
-           (map imap-flag->imail-flag (delq '\* pflags)))
-          (folder-modified! folder)))
+           (map imap-flag->imail-flag (delq '\* pflags)))))
        ((imap:response-code:read-only? code)
-        (let ((folder (imap-connection-folder connection)))
-          (set-imap-folder-read-only?! folder #t)
-          (folder-modified! folder)))
+        (set-imap-folder-read-only?! (imap-connection-folder connection) #t))
        ((imap:response-code:read-write? code)
-        (let ((folder (imap-connection-folder connection)))
-          (set-imap-folder-read-only?! folder #f)
-          (folder-modified! folder)))
+        (set-imap-folder-read-only?! (imap-connection-folder connection) #f))
        ((imap:response-code:uidnext? code)
-        (let ((folder (imap-connection-folder connection)))
-          (set-imap-folder-uidnext! folder (imap:response-code:uidnext code))
-          (folder-modified! folder)))
+        (set-imap-folder-uidnext! (imap-connection-folder connection)
+                                  (imap:response-code:uidnext code)))
        ((imap:response-code:uidvalidity? code)
         (let ((folder (imap-connection-folder connection))
               (uidvalidity (imap:response-code:uidvalidity code)))
           (if (not (eqv? uidvalidity (imap-folder-uidvalidity folder)))
               (new-imap-folder-uidvalidity! folder uidvalidity))))
        ((imap:response-code:unseen? code)
-        (let ((folder (imap-connection-folder connection)))
-          (set-imap-folder-unseen!
-           folder
-           (- (imap:response-code:unseen code) 1))
-          (folder-modified! folder)))
+        (set-imap-folder-unseen!
+         (imap-connection-folder connection)
+         (- (imap:response-code:unseen code) 1)))
        #|
        ((or (imap:response-code:badcharset? code)
             (imap:response-code:newname? code)
@@ -1065,23 +1047,18 @@
        ))
 \f
 (define (process-fetch-attributes message response)
-  (let loop
-      ((keywords (imap:response:fetch-attribute-keywords response))
-       (any-modifications? #f))
-    (if (pair? keywords)
-       (loop (cdr keywords)
-             (or (process-fetch-attribute
-                  message
-                  (car keywords)
-                  (imap:response:fetch-attribute response (car keywords)))
-                 any-modifications?))
-       (if any-modifications?
-           (message-modified! message)))))
+  (for-each
+   (lambda (keyword)
+     (process-fetch-attribute message
+                             keyword
+                             (imap:response:fetch-attribute response
+                                                            keyword)))
+   (imap:response:fetch-attribute-keywords response)))
 
 (define (process-fetch-attribute message keyword datum)
   (case keyword
     ((FLAGS)
-     (%set-message-flags! message (map imap-flag->imail-flag datum))
+     (%%set-message-flags! message (map imap-flag->imail-flag datum))
      #t)
     ((RFC822.HEADER)
      (%set-message-header-fields! message
@@ -1104,7 +1081,7 @@
 (define %set-message-body!
   (slot-modifier <imap-message> 'BODY))
 
-(define %set-message-flags!
+(define %%set-message-flags!
   (slot-modifier <imap-message> 'FLAGS))
 
 (define %message-flags-initialized?

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 26c525cc643fd6762ac821b61a5637db18a3af9b..608c4450b349f495269d482371f78ea8cd957605 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.58 2000/05/17 20:52:59 cph Exp $
+;;; $Id: imail-top.scm,v 1.59 2000/05/18 03:43:06 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -481,7 +481,8 @@ With prefix argument N moves backward N messages with these flags."
          (directory-pathname (file-folder-pathname folder))
          (user-homedir-pathname)))
      (add-event-receiver! (folder-modification-event folder)
-       (lambda (folder)
+       (lambda (folder type parameters)
+        type parameters
         (maybe-add-command-suffix! notice-folder-modifications folder)))
      (add-kill-buffer-hook buffer delete-associated-buffers))))