From 0b27950079a90d65f629ba4dca22fccec0667f25 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 19 Jan 2000 05:39:13 +0000
Subject: [PATCH] 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.

---
 v7/src/imail/imail-core.scm  | 151 +++++++++++++++++++++++++----------
 v7/src/imail/imail-file.scm  |  69 ++++++++++++----
 v7/src/imail/imail-rmail.scm |  37 ++++-----
 v7/src/imail/imail-umail.scm |   6 +-
 4 files changed, 182 insertions(+), 81 deletions(-)

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 98a98d0d5..39be30f4c 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.11 2000/01/18 22:21:01 cph Exp $
+;;; $Id: imail-core.scm,v 1.12 2000/01/19 05:39:13 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -244,7 +244,7 @@
 ;; error for invalid INDEX.
 (define (get-message folder index)
   (guarantee-index index 'GET-MESSAGE)
-  (if (not (fix:< index (count-messages folder)))
+  (if (not (< index (count-messages folder)))
       (error:bad-range-argument index 'GET-MESSAGE))
   (%get-message folder index))
 
@@ -255,7 +255,7 @@
 ;; Unspecified result.
 (define (insert-message folder index message)
   (guarantee-index index 'INSERT-MESSAGE)
-  (if (not (fix:<= index (length (count-messages folder))))
+  (if (not (<= index (count-messages folder)))
       (error:bad-range-argument index 'INSERT-MESSAGE))
   (guarantee-message message 'INSERT-MESSAGE)
   (%insert-message folder index message))
@@ -323,52 +323,60 @@
 
 ;;;; Message type
 
-(define-structure (message (type-descriptor message-rtd)
-			   (safe-accessors #t))
-  header-fields
-  body
-  flags
-  properties)
+(define-class <message> ()
+  (header-fields define standard
+		 accessor header-fields
+		 modifier set-header-fields!)
+  (body define standard)
+  (flags define standard)
+  (properties define standard)
+  (folder define accessor)
+  (index define standard))
 
 (define (guarantee-message message procedure)
   (if (not (message? message))
       (error:wrong-type-argument message "IMAIL message" procedure)))
 
-(define-generic header-fields (object))
-
-(define-method header-fields ((message message-rtd))
-  (message-header-fields message))
-
-(define (copy-message message)
-  (make-message (map copy-header-field (message-header-fields message))
-		(message-body message)
-		(list-copy (message-flags message))
-		(alist-copy (message-properties message))))
-
-(define (make-standard-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 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 (maybe-strip-imail-headers strip? headers)
   (if strip?
@@ -378,6 +386,61 @@
 	      (header-field->message-property header))))
       headers))
 
+;;;; Message Navigation
+
+(define (first-unseen-message folder)
+  (let ((message (first-message folder)))
+    (and message
+	 (let loop ((message message))
+	   (let ((next (next-message message)))
+	     (cond ((not next) message)
+		   ((message-seen? next) (loop next))
+		   (else next)))))))
+
+(define (first-message folder)
+  (and (> (count-messages folder) 0)
+       (get-message folder 0)))
+
+(define (last-message folder)
+  (let ((n (count-messages folder)))
+    (and (> n 0)
+	 (get-message folder (- n 1)))))
+
+(define (previous-message message #!optional predicate)
+  (let ((predicate
+	 (if (or (default-object? predicate) (not predicate))
+	     (lambda (message) message #t)
+	     predicate))
+	(folder (message-folder message)))
+    (let loop ((index (message-index message)))
+      (and (> index 0)
+	   (let ((index (- index 1)))
+	     (let ((message (get-message folder index)))
+	       (if (predicate message)
+		   message
+		   (loop index))))))))
+
+(define (next-message message #!optional predicate)
+  (let ((predicate
+	 (if (or (default-object? predicate) (not predicate))
+	     (lambda (message) message #t)
+	     predicate))
+	(folder (message-folder message)))
+    (let ((n (count-messages folder)))
+      (let loop ((index (message-index message)))
+	(let ((index (+ index 1)))
+	  (and (< index n)
+	       (let ((message (get-message folder index)))
+		 (if (predicate message)
+		     message
+		     (loop index)))))))))
+
+(define (previous-deleted-message message)
+  (previous-message message message-deleted?))
+
+(define (next-deleted-message message)
+  (next-message message message-deleted?))
+
 ;;;; Message flags
 
 ;;; Flags are markers that can be attached to messages.  They indicate
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 915063e2b..f493905b3 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.2 2000/01/14 18:09:04 cph Exp $
+;;; $Id: imail-file.scm,v 1.3 2000/01/19 05:38:52 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -75,25 +75,62 @@
   (list-ref (file-folder-messages folder) index))
 
 (define-method %insert-message ((folder <file-folder>) index message)
-  (let ((message (copy-message message))
-	(messages (file-folder-messages folder)))
-    (if (fix:= 0 index)
-	(set-file-folder-messages! folder (cons message messages))
-	(let loop ((index* 1) (prev messages) (this (cdr messages)))
-	  (if (fix:= index index*)
-	      (set-cdr! prev (cons message this))
-	      (loop (fix:+ index* 1) this (cdr this)))))))
+  (let ((message (%copy-message message folder)))
+    (set-message-index! message index)
+    (without-interrupts
+     (lambda ()
+       (let ((messages (file-folder-messages folder)))
+	 (if (fix:= 0 index)
+	     (begin
+	       (do ((messages messages (cdr messages))
+		    (index 1 (fix:+ index 1)))
+		   ((not (pair? messages)))
+		 (set-message-index! (car messages) index))
+	       (set-file-folder-messages! folder (cons message messages)))
+	     (let loop ((index* 1) (prev messages) (this (cdr messages)))
+	       (if (not (pair? this))
+		   (error:bad-range-argument index 'INSERT-MESSAGE))
+	       (if (fix:= index index*)
+		   (begin
+		     (do ((messages this (cdr messages))
+			  (index (fix:+ index 1) (fix:+ index 1)))
+			 ((not (pair? messages)))
+		       (set-message-index! (car messages) index))
+		     (set-cdr! prev (cons message this)))
+		   (loop (fix:+ index* 1) this (cdr this))))))))))
 
 (define-method %append-message ((folder <file-folder>) message)
-  (set-file-folder-messages! folder
-			     (append! (file-folder-messages folder)
-				      (list (copy-message message)))))
+  (let ((message (%copy-message message folder)))
+    (without-interrupts
+     (lambda ()
+       (set-file-folder-messages!
+	folder
+	(let ((messages (file-folder-messages folder)))
+	  (if (pair? messages)
+	      (begin
+		(let loop ((prev messages) (this (cdr messages)) (index 1))
+		  (if (pair? this)
+		      (loop this (cdr this) (fix:+ index 1))
+		      (begin
+			(set-message-index! message index)
+			(set-cdr! prev (list message)))))
+		messages)
+	      (begin
+		(set-message-index! message 0)
+		(list message)))))))))
 
 (define-method expunge-deleted-messages ((folder <file-folder>))
-  (set-file-folder-messages!
-   folder
-   (list-transform-negative (file-folder-messages folder) message-deleted?)))
-
+  (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)))))
+
 (define-method search-folder ((folder <file-folder>) criteria)
   folder criteria
   (error "Unimplemented operation:" 'SEARCH-FOLDER))
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index ce3e60bb0..6b740bc63 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.6 2000/01/18 20:54:01 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.7 2000/01/19 05:37:56 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -86,8 +86,8 @@
   (flags->rmail-labels
    (let ((n (count-messages folder)))
      (let loop ((index 0) (flags '()))
-       (if (fix:< index n)
-	   (loop (fix:+ index 1)
+       (if (< index n)
+	   (loop (+ index 1)
 		 (union-of-lists (message-flags (get-message folder index))
 				 flags))
 	   flags)))))
@@ -100,25 +100,26 @@
       (read-rmail-folder (make-rmail-url pathname) port import?))))
 
 (define (read-rmail-folder url port import?)
-  (let ((folder-headers (read-rmail-prolog port)))
-    (make-rmail-folder url
-		       folder-headers
-		       (read-rmail-messages port import?))))
+  (let ((folder (make-rmail-folder url (read-rmail-prolog port) '())))
+    (let loop ()
+      (let ((message (read-rmail-message port import?)))
+	(if message
+	    (begin
+	      (append-message folder message)
+	      (loop)))))
+    folder))
 
 (define (read-rmail-prolog port)
   (if (not (string-prefix? "BABYL OPTIONS:" (read-required-line port)))
       (error "Not an RMAIL file:" port))
   (lines->header-fields (read-lines-to-eom port)))
 
-(define (read-rmail-messages port import?)
-  (source->list (lambda () (read-rmail-message port import?))))
-
 (define (read-rmail-message port import?)
   ;; **** This must be generalized to recognize an RMAIL file that has
   ;; unix-mail format messages appended to it.
   (let ((line (read-line port)))
     (cond ((eof-object? line)
-	   line)
+	   #f)
 	  ((and (fix:= 1 (string-length line))
 		(char=? rmail-message:start-char (string-ref line 0)))
 	   (read-rmail-message-1 port import?))
@@ -139,11 +140,11 @@
 	     (body (read-to-eom port))
 	     (finish
 	      (lambda (headers)
-		(let ((message (make-standard-message headers body)))
+		(let ((message (make-detached-message headers body)))
 		  (for-each (lambda (flag)
 			      (set-message-flag message flag))
 			    flags)
-		  (let ((headers (message-header-fields message)))
+		  (let ((headers (header-fields message)))
 		    (if (and (pair? headers)
 			     (string-ci=? "summary-line"
 					  (header-field-name (car headers))))
@@ -152,7 +153,7 @@
 			   message
 			   (header-field-name (car headers))
 			   (header-field-value (car headers)))
-			  (set-message-header-fields! message (cdr headers)))))
+			  (set-header-fields! message (cdr headers)))))
 		  message))))
 	(if formatted?
 	    (let ((message (finish headers)))
@@ -212,7 +213,7 @@
 (define (write-rmail-message message port export?)
   (write-char rmail-message:start-char port)
   (newline port)
-  (let ((headers (message-header-fields message))
+  (let ((headers (header-fields message))
 	(displayed-headers
 	 (get-message-property message "displayed-header-fields" 'NONE)))
     (write-rmail-attributes-line message displayed-headers port)
@@ -279,8 +280,8 @@
 		 (map (lambda (pathname)
 			(let ((inbox (read-rmail-inbox folder pathname #t)))
 			  (let ((n (count-messages inbox)))
-			    (do ((index 0 (fix:+ index 1)))
-				((fix:= index n))
+			    (do ((index 0 (+ index 1)))
+				((= index n))
 			      (append-message folder
 					      (get-message inbox index))))
 			  inbox))
@@ -290,7 +291,7 @@
 			(if folder
 			    (delete-folder folder)))
 		      inbox-folders))
-	  (fix:- (count-messages folder) initial-count)))))
+	  (- (count-messages folder) initial-count)))))
 
 (define (rmail-folder-inbox-list folder)
   (let ((url (folder-url folder))
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 763684409..a867f5ae0 100644
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.6 2000/01/18 20:47:17 cph Exp $
+;;; $Id: imail-umail.scm,v 1.7 2000/01/19 05:38:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -112,7 +112,7 @@
 
 (define (make-umail-message from-line header-lines body-lines import?)
   (let ((message
-	 (make-standard-message
+	 (make-detached-message
 	  (maybe-strip-imail-headers import?
 				     (lines->header-fields header-lines))
 	  (lines->string (map (lambda (line)
@@ -166,7 +166,7 @@
 			 (message-property->header-field (car n.v) (cdr n.v))
 			 port)))
 		  (message-properties message))))
-  (write-header-fields (message-header-fields message) port)
+  (write-header-fields (header-fields message) port)
   (newline port)
   (for-each (lambda (line)
 	      (if (string-prefix-ci? "From " line)
-- 
2.25.1