From 2df307e135e151e03b60934ea85f67a4ee8a5c05 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 19 Jan 2000 05:54:55 +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 | 86 ++++++++++++++++++------------------- v7/src/imail/imail-file.scm | 32 ++++++++------ 2 files changed, 62 insertions(+), 56 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 39be30f4c..eef55e016 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.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 @@ ;;;; Message type -(define-class () +(define-class ( (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 - '(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 - '(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 f493905b3..0ba9eb244 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.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 ) 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 ) 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 )) - (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*)))))))) (define-method search-folder ((folder ) criteria) folder criteria -- 2.25.1