Change message implementation so that each message belongs to a single

folder.  Each message also contains an index within its folder, which
is automatically updated by the folder implementation.  These changes
facilitate using message-based navigation rather than index
computations.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 39be30f4ccd30b112c543cf3c15effa7cf22edf9..eef55e016fa44fb938052bda26263b47a7653017 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.12 2000/01/19 05:39:13 cph Exp $
+;;; $Id: imail-core.scm,v 1.13 2000/01/19 05:54:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -323,60 +323,60 @@
 \f
 ;;;; Message type
 
-(define-class <message> ()
+(define-class (<message> (constructor (header-fields body flags properties)))
+    ()
   (header-fields define standard
                 accessor header-fields
                 modifier set-header-fields!)
   (body define standard)
   (flags define standard)
   (properties define standard)
-  (folder define accessor)
+  (folder define standard)
   (index define standard))
 
 (define (guarantee-message message procedure)
   (if (not (message? message))
       (error:wrong-type-argument message "IMAIL message" procedure)))
 
-(define make-detached-message
-  (let ((constructor
-        (instance-constructor <message>
-                              '(HEADER-FIELDS BODY FLAGS PROPERTIES))))
-    (lambda (headers body)
-      (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
-       (cond ((not (pair? headers))
-              (constructor (reverse! headers*)
-                           body
-                           (reverse! flags)
-                           (reverse! properties)))
-             ((header-field->message-flags (car headers))
-              => (lambda (flags*)
-                   (loop (cdr headers)
-                         headers*
-                         (append! (reverse! (cdr flags*)) flags)
-                         properties)))
-             ((header-field->message-property (car headers))
-              => (lambda (property)
-                   (loop (cdr headers)
-                         headers*
-                         flags
-                         (cons property properties))))
-             (else
-              (loop (cdr headers)
-                    (cons (car headers) headers*)
-                    flags
-                    properties)))))))
-
-(define %copy-message
-  (let ((constructor
-        (instance-constructor <message>
-                              '(HEADER-FIELDS BODY FLAGS PROPERTIES FOLDER))))
-    (lambda (message folder)
-      (guarantee-folder folder '%COPY-MESSAGE)
-      (constructor (map copy-header-field (header-fields message))
-                  (message-body message)
-                  (list-copy (message-flags message))
-                  (alist-copy (message-properties message))
-                  folder))))
+(define (make-detached-message headers body)
+  (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
+    (cond ((not (pair? headers))
+          (make-message (reverse! headers*)
+                        body
+                        (reverse! flags)
+                        (reverse! properties)))
+         ((header-field->message-flags (car headers))
+          => (lambda (flags*)
+               (loop (cdr headers)
+                     headers*
+                     (append! (reverse! (cdr flags*)) flags)
+                     properties)))
+         ((header-field->message-property (car headers))
+          => (lambda (property)
+               (loop (cdr headers)
+                     headers*
+                     flags
+                     (cons property properties))))
+         (else
+          (loop (cdr headers)
+                (cons (car headers) headers*)
+                flags
+                properties)))))
+
+(define (attach-message message folder)
+  (guarantee-folder folder 'ATTACH-MESSAGE)
+  (let ((message
+        (make-message (map copy-header-field (header-fields message))
+                      (message-body message)
+                      (list-copy (message-flags message))
+                      (alist-copy (message-properties message))
+                      folder)))
+    (set-message-folder! message folder)
+    message))
+
+(define (detach-message message)
+  (set-message-folder! message #f)
+  (set-message-index! message #f))
 
 (define (maybe-strip-imail-headers strip? headers)
   (if strip?

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index f493905b31443de98e54fb8ede3d349ab8abce5c..0ba9eb244496bf76057ea905214399c07707061e 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.3 2000/01/19 05:38:52 cph Exp $
+;;; $Id: imail-file.scm,v 1.4 2000/01/19 05:54:55 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -75,7 +75,7 @@
   (list-ref (file-folder-messages folder) index))
 
 (define-method %insert-message ((folder <file-folder>) index message)
-  (let ((message (%copy-message message folder)))
+  (let ((message (attach-message message folder)))
     (set-message-index! message index)
     (without-interrupts
      (lambda ()
@@ -100,7 +100,7 @@
                   (loop (fix:+ index* 1) this (cdr this))))))))))
 
 (define-method %append-message ((folder <file-folder>) message)
-  (let ((message (%copy-message message folder)))
+  (let ((message (attach-message message folder)))
     (without-interrupts
      (lambda ()
        (set-file-folder-messages!
@@ -120,16 +120,22 @@
                (list message)))))))))
 
 (define-method expunge-deleted-messages ((folder <file-folder>))
-  (let ((messages
-        (list-transform-negative (file-folder-messages folder)
-          message-deleted?)))
-    (without-interrupts
-     (lambda ()
-       (do ((messages messages (cdr messages))
-           (index 0 (+ index 1)))
-          ((null? messages))
-        (set-message-index! (car messages) index))
-       (set-file-folder-messages! folder messages)))))
+  (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))
+             (loop (cdr messages) index messages*))
+            (else
+             (set-message-index! (car messages) index)
+             (loop (cdr messages)
+                   (fix:+ index 1)
+                   (cons (car messages) messages*))))))))
 \f
 (define-method search-folder ((folder <file-folder>) criteria)
   folder criteria