From: Chris Hanson Date: Fri, 4 Feb 2000 05:19:33 +0000 (+0000) Subject: Implement MAYBE-REVERT-FOLDER. X-Git-Tag: 20090517-FFI~4263 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bef3ed572c17dfec7adc924025c50d70a9129ef4;p=mit-scheme.git Implement MAYBE-REVERT-FOLDER. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index a5398b3a3..407aae530 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.20 2000/02/04 04:53:12 cph Exp $ +;;; $Id: imail-core.scm,v 1.21 2000/02/04 05:19:21 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -309,6 +309,7 @@ (%maybe-revert-folder folder resolve-conflict)) (define-generic %maybe-revert-folder (folder resolve-conflict)) +(define-generic %revert-folder (folder)) ;; Write the contents of FOLDER to URL. (define (write-folder folder url) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index a351cfdf5..945a5ddc9 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.6 2000/02/04 04:53:08 cph Exp $ +;;; $Id: imail-file.scm,v 1.7 2000/02/04 05:19:26 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -63,10 +63,19 @@ (define-class () (url accessor folder-url) - (messages define standard)) + (messages define standard initial-value '()) + (modification-time define standard initial-value #f)) + +(define (file-folder-pathname folder) + (file-url-pathname (folder-url folder))) + +(define (update-file-folder-modification-time! folder) + (set-file-folder-modification-time! + folder + (file-modification-time (file-folder-pathname folder)))) (define-method %folder-valid? ((folder )) - (file-exists? (file-url-pathname (folder-url folder)))) + (file-exists? (file-folder-pathname folder))) (define-method folder-length ((folder )) (length (file-folder-messages folder))) @@ -158,6 +167,14 @@ folder unspecific) +(define-method %maybe-revert-folder ((folder ) resolve-conflict) + (if (if (eqv? (file-folder-modification-time folder) + (file-modification-time (file-folder-pathname folder))) + (or (not (folder-modified? folder)) + (resolve-conflict folder)) + (folder-modified? folder)) + (%revert-folder folder))) + (define-method subscribe-folder ((folder )) folder (error "Unimplemented operation:" 'SUBSCRIBE-FOLDER)) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index d355ebdff..526e9ce7e 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.11 2000/02/04 04:53:04 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.12 2000/02/04 05:19:30 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -41,15 +41,14 @@ (read-rmail-file (file-url-pathname url) #f)) (define-method %new-folder ((url )) - (let ((folder (make-rmail-folder url '()))) + (let ((folder (make-rmail-folder url))) (set-header-fields! folder (compute-rmail-folder-header-fields folder)) (save-folder folder) folder)) ;;;; Folder -(define-class ( (constructor (url header-fields messages))) - ()) +(define-class ( (constructor (url))) ()) (define-method header-fields ((folder )) (folder-get folder 'RMAIL-HEADER-FIELDS '())) @@ -58,7 +57,8 @@ (folder-put! folder 'RMAIL-HEADER-FIELDS headers)) (define-method %write-folder ((folder ) (url )) - (write-rmail-file folder (file-url-pathname url) #f)) + (write-rmail-file folder (file-url-pathname url) #f) + (update-file-folder-modification-time! folder)) (define-method poll-folder ((folder )) (rmail-get-new-mail folder)) @@ -85,16 +85,20 @@ (read-rmail-folder (make-rmail-url pathname) port import?)))) (define (read-rmail-folder url port import?) - (let ((folder (make-rmail-folder url '()))) - (set-header-fields! folder (read-rmail-prolog port)) - (let loop () - (let ((message (read-rmail-message port import?))) - (if message - (begin - (append-message folder message) - (loop))))) + (let ((folder (make-rmail-folder url))) + (%revert-folder folder) folder)) +(define-method %revert-folder ((folder )) + (set-header-fields! folder (read-rmail-prolog port)) + (let loop () + (let ((message (read-rmail-message port import?))) + (if message + (begin + (append-message folder message) + (loop))))) + (update-file-folder-modification-time! folder)) + (define (read-rmail-prolog port) (if (not (string-prefix? "BABYL OPTIONS:" (read-required-line port))) (error "Not an RMAIL file:" port)) @@ -280,15 +284,15 @@ (- (folder-length folder) initial-count))))) (define (rmail-folder-inbox-list folder) - (let ((url (folder-url folder)) - (inboxes (get-first-header-field-value folder "mail" #f))) + (let ((inboxes (get-first-header-field-value folder "mail" #f))) (cond (inboxes (map (let ((directory - (directory-pathname (file-url-pathname url)))) + (directory-pathname (file-folder-pathname folder)))) (lambda (filename) (merge-pathnames (string-trim filename) directory))) (burst-string inboxes #\, #f))) - ((pathname=? (rmail-primary-folder-name) (url-body url)) + ((pathname=? (rmail-primary-folder-name) + (url-body (folder-url folder))) (rmail-primary-inbox-list)) (else '())))) @@ -309,8 +313,7 @@ (directory-pathname pathname)) (rename-inbox-using-movemail pathname - (directory-pathname - (file-url-pathname (folder-url folder))))) + (directory-pathname (file-folder-pathname folder)))) (else (rename-inbox-using-rename pathname))))) (and (file-exists? pathname) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index a867f5ae0..eeb16c22e 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.7 2000/01/19 05:38:46 cph Exp $ +;;; $Id: imail-umail.scm,v 1.8 2000/02/04 05:19:33 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -41,16 +41,17 @@ (read-umail-file (file-url-pathname url) #f)) (define-method %new-folder ((url )) - (let ((folder (make-umail-folder url '()))) + (let ((folder (make-umail-folder url))) (save-folder folder) folder)) ;;;; Folder -(define-class ( (constructor (url messages))) ()) +(define-class ( (constructor (url))) ()) (define-method %write-folder ((folder ) (url )) - (write-umail-file folder (file-url-pathname url) #f)) + (write-umail-file folder (file-url-pathname url) #f) + (update-file-folder-modification-time! folder)) (define-method poll-folder ((folder )) folder @@ -64,8 +65,13 @@ (read-umail-folder (make-umail-url pathname) port import?)))) (define (read-umail-folder url port import?) - (make-umail-folder - url + (let ((folder (make-umail-folder url))) + (%revert-folder folder) + folder)) + +(define-method %revert-folder ((folder )) + (set-file-folder-messages! + folder (let ((from-line (read-line port))) (if (eof-object? from-line) '() @@ -79,7 +85,8 @@ (let ((messages (cons message messages))) (if from-line (loop from-line messages) - (reverse! messages))))))))))) + (reverse! messages)))))))))) + (update-file-folder-modification-time! folder)) (define (read-umail-message from-line port import?) (let read-headers ((header-lines '()))