From 7ea02517db5e84ce0a0c8ce1fbc7a780824e8a88 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 18 May 2000 03:43:06 +0000 Subject: [PATCH] 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). --- v7/src/imail/imail-core.scm | 46 ++++++++---------- v7/src/imail/imail-file.scm | 41 ++++++++-------- v7/src/imail/imail-imap.scm | 97 ++++++++++++++----------------------- v7/src/imail/imail-top.scm | 5 +- 4 files changed, 83 insertions(+), 106 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 06780da57..ab7bbc6c2 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.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-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 @@ () (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)) (define-generic message-internal-time (message)) (define-method message-internal-time ((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 f0b41bbc1..1e9a29464 100644 --- 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 )) (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 ) criteria) (cond ((string? criteria) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 660346a6a..f008a3e99 100644 --- 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*)))))))))))) ;;;; Message datatype @@ -485,7 +479,7 @@ (define (imap-message-connection message) (imap-folder-connection (message-folder message))) -(define-method set-message-flags! ((message ) flags) +(define-method %set-message-flags! ((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 @@ )) (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 'BODY)) -(define %set-message-flags! +(define %%set-message-flags! (slot-modifier 'FLAGS)) (define %message-flags-initialized? diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 26c525cc6..608c4450b 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.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)))) -- 2.25.1