From 58887c6ce988bdc728e79f91412e329d1ee23187 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 14 Sep 2001 02:07:21 +0000 Subject: [PATCH] Add mechanism to permute the message order of a folder. --- v7/src/imail/imail-core.scm | 84 ++++++++++++++++++++++++++++++++-- v7/src/imail/imail-file.scm | 4 +- v7/src/imail/imail-imap.scm | 14 +++--- v7/src/imail/imail-summary.scm | 4 +- v7/src/imail/load.scm | 4 +- 5 files changed, 92 insertions(+), 18 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 3a7ab3d6b..2eb89e774 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.144 2001/06/12 00:47:19 cph Exp $ +;;; $Id: imail-core.scm,v 1.145 2001/09/14 02:06:39 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -397,7 +397,16 @@ (define-method url-base-name ((resource )) (url-base-name (resource-locator resource))) -(define-class ()) +(define-class () + (permutation define accessor + initial-value #f)) + +(define set-folder-permutation! + (let ((modifier (slot-modifier 'PERMUTATION))) + (lambda (folder permutation) + (modifier folder permutation) + (object-modified! folder 'PERMUTED)))) + (define-class ()) (define-method resource-type-name ((r )) r 'FOLDER) @@ -505,7 +514,11 @@ (guarantee-index index 'GET-MESSAGE) (if (not (< index (folder-length folder))) (error:bad-range-argument index 'GET-MESSAGE)) - (%get-message folder index)) + (%get-message folder + (let ((permutation (folder-permutation folder))) + (if permutation + (permute-index permutation folder index) + index)))) (define-generic %get-message (folder index)) @@ -583,6 +596,7 @@ (folder define standard initial-value #f) (index define standard + accessor %message-index initial-value #f)) (define-method write-instance ((message ) port) @@ -591,7 +605,7 @@ (write-char #\space port) (write (message-folder message) port) (write-char #\space port) - (write (message-index message) port)))) + (write (%message-index message) port)))) (define (guarantee-message message procedure) (if (not (message? message)) @@ -602,6 +616,16 @@ (define-generic message-internal-time (message)) (define-generic message-length (message)) +(define (message-index message) + (let ((index (%message-index message)) + (folder (message-folder message))) + (let ((permutation + (and folder + (folder-permutation folder)))) + (if permutation + (unpermute-index permutation folder index) + index)))) + (define %set-message-flags! (let ((modifier (slot-modifier 'FLAGS))) (lambda (message flags) @@ -644,7 +668,11 @@ (define (first-unseen-message folder) (let ((end (folder-length folder))) - (let loop ((start (first-unseen-message-index folder))) + (let loop + ((start + (if (folder-permutation folder) + 0 + (first-unseen-message-index folder)))) (and (< start end) (let ((message (get-message folder start))) (if (message-seen? message) @@ -691,6 +719,52 @@ message (loop index))))))))) +;;;; Folder permutations + +(define-structure (folder-permutation + (type-descriptor folder-permutation-rtd) + (constructor make-folder-permutation (predicate))) + (predicate #f read-only #t) + (forward #f) + (reverse #f) + (modification-count -1)) + +(define (permute-index permutation folder index) + (guarantee-valid-permutation permutation folder) + (let ((v (folder-permutation-forward permutation))) + (if (fix:< index (vector-length v)) + (vector-ref v index) + index))) + +(define (unpermute-index permutation folder index) + (guarantee-valid-permutation permutation folder) + (let ((v (folder-permutation-reverse permutation))) + (if (fix:< index (vector-length v)) + (vector-ref v index) + index))) + +(define (guarantee-valid-permutation permutation folder) + (let loop () + (let ((count (object-modification-count folder))) + (if (not (= (folder-permutation-modification-count permutation) count)) + (begin + (let ((n (folder-length folder))) + (let ((vf (make-vector n)) + (vr (make-vector n))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-set! vf i (%get-message folder i))) + (sort! vf (folder-permutation-predicate permutation)) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (let ((j (%message-index (vector-ref vf i)))) + (vector-set! vf i j) + (vector-set! vr j i))) + (set-folder-permutation-forward! permutation vf) + (set-folder-permutation-reverse! permutation vr))) + (set-folder-permutation-modification-count! permutation count) + (loop)))))) + ;;;; 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 ea87b8c15..aebfc2f89 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.78 2001/06/12 00:47:24 cph Exp $ +;;; $Id: imail-file.scm,v 1.79 2001/09/14 02:06:43 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -375,7 +375,7 @@ (let loop ((index 0) (winners '())) (if (< index n) (loop (+ index 1) - (if (let ((message (get-message folder index))) + (if (let ((message (%get-message folder index))) (or (string-search-forward criteria (header-fields->string diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index b36b6078c..05ad08f1e 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.184 2001/07/21 03:53:36 cph Exp $ +;;; $Id: imail-imap.scm,v 1.185 2001/09/14 02:06:53 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -1072,7 +1072,7 @@ (if (not (initpred message)) (with-imap-message-open message (lambda (connection) - (let ((index (message-index message))) + (let ((index (%message-index message))) (let ((suffix (string-append " UID for message " (number->string (+ index 1))))) @@ -1099,7 +1099,7 @@ (let ((suffix (string-append " " noun " for message " - (number->string (+ (message-index message) 1))))) + (number->string (+ (%message-index message) 1))))) ((imail-ui:message-wrapper "Reading" suffix) (lambda () (imap:read-literal-progress-hook imail-ui:progress-meter @@ -1173,7 +1173,7 @@ (reverse! messages))))) (define (message-list->set messages) - (let loop ((indexes (map message-index messages)) (groups '())) + (let loop ((indexes (map %message-index messages)) (groups '())) (if (pair? indexes) (let ((start (car indexes))) (let parse-group ((this start) (rest (cdr indexes))) @@ -1235,7 +1235,7 @@ (string-append " body" (if (equal? section '(TEXT)) "" " part") " for message " - (number->string (+ (message-index message) 1))))) + (number->string (+ (%message-index message) 1))))) ((imail-ui:message-wrapper "Reading" suffix) (lambda () (imap:read-literal-progress-hook imail-ui:progress-meter @@ -1972,8 +1972,8 @@ (with-imap-connection-folder connection (lambda (folder) (process-fetch-attributes - (get-message folder - (- (imap:response:fetch-index response) 1)) + (%get-message folder + (- (imap:response:fetch-index response) 1)) response))) (eq? command 'FETCH)) (else diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm index 744da2f96..707fda739 100644 --- a/v7/src/imail/imail-summary.scm +++ b/v7/src/imail/imail-summary.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-summary.scm,v 1.42 2001/05/23 05:05:16 cph Exp $ +;;; $Id: imail-summary.scm,v 1.43 2001/09/14 02:07:00 cph Exp $ ;;; ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology ;;; @@ -240,7 +240,7 @@ SUBJECT is a string of regexps separated by commas." (let ((message (car parameters))) (if message (imail-summary-select-message buffer message)))) - ((EXPUNGE INCREASE-LENGTH SET-LENGTH) + ((EXPUNGE INCREASE-LENGTH SET-LENGTH PERMUTED) (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer)))))) ;;;; Summary content generation diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm index 34edd811f..7d7494463 100644 --- a/v7/src/imail/load.scm +++ b/v7/src/imail/load.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: load.scm,v 1.28 2001/08/17 13:01:06 cph Exp $ +;;; $Id: load.scm,v 1.29 2001/09/14 02:07:21 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -28,4 +28,4 @@ (lambda () (fluid-let ((*allow-package-redefinition?* #t)) (load-package-set "imail")))) -(add-subsystem-identification! "IMAIL" '(1 11)) \ No newline at end of file +(add-subsystem-identification! "IMAIL" '(1 12)) \ No newline at end of file -- 2.25.1