From: Chris Hanson Date: Fri, 12 May 2000 18:23:05 +0000 (+0000) Subject: Change APPEND-MESSAGE to accept arguments (MESSAGE URL) rather than X-Git-Tag: 20090517-FFI~3886 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=10a0755d5b7b69ab65e8e46a549d0adcfc1705db;p=mit-scheme.git Change APPEND-MESSAGE to accept arguments (MESSAGE URL) rather than (FOLDER MESSAGE) as currently. There's no need to have the folder open to append a message to it, and this requirement causes problems for the IMAP back end. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 549e8ab37..3956e0a19 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.53 2000/05/12 17:56:18 cph Exp $ +;;; $Id: imail-core.scm,v 1.54 2000/05/12 18:22:46 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -151,13 +151,20 @@ (define-generic %copy-folder (url new-url)) (define-method %copy-folder ((url ) (new-url )) - (let ((from (open-folder url)) - (to (new-folder new-url))) - (let ((n (folder-length from))) + (let ((folder (open-folder url))) + (let ((n (folder-length folder))) (do ((i 0 (+ i 1))) ((= i n)) - (append-message to (get-message from i)))) - (save-folder to))) + (%append-message (get-message folder i) new-url))))) + +;; ------------------------------------------------------------------- +;; Insert a copy of MESSAGE in FOLDER at the end of the existing +;; messages. Unspecified result. + +(define (append-message message url) + (%append-message message (->url url))) + +(define-generic %append-message (message url)) ;; ------------------------------------------------------------------- ;; Return a list of URLs for folders that match URL-PATTERN. @@ -292,12 +299,6 @@ (%get-message folder index)) (define-generic %get-message (folder index)) - -;; ------------------------------------------------------------------- -;; Insert a copy of MESSAGE in FOLDER at the end of the existing -;; messages. Unspecified result. - -(define-generic append-message (folder message)) ;; ------------------------------------------------------------------- ;; Remove all messages in FOLDER that are marked for deletion. diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 493f04257..abcc2bed9 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.21 2000/05/12 17:56:22 cph Exp $ +;;; $Id: imail-file.scm,v 1.22 2000/05/12 18:22:50 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -97,25 +97,33 @@ (define-method %get-message ((folder ) index) (list-ref (file-folder-messages folder) index)) -(define-method append-message ((folder ) (message )) - (let ((message (copy-message message))) - (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 - (attach-message! message folder index) - (set-cdr! prev (list message))))) - messages) - (begin - (attach-message! message folder 0) - (list message))))))))) +(define-method %append-message ((message ) (url )) + (let ((folder (get-memoized-folder url))) + (if folder + (let ((message (copy-message message))) + (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 + (attach-message! message folder index) + (set-cdr! prev (list message))))) + messages) + (begin + (attach-message! message folder 0) + (list message)))))))) + (append-message-to-file message url)))) + +(define-generic append-message-to-file (message url)) (define-method expunge-deleted-messages ((folder )) (without-interrupts diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index aa2feafcc..adca138d2 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.32 2000/05/12 18:00:52 cph Exp $ +;;; $Id: imail-imap.scm,v 1.33 2000/05/12 18:22:52 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -520,6 +520,9 @@ (define-method %copy-folder ((url ) (new-url )) ???) +(define-method %append-message ((message ) (url )) + ???) + (define-method available-folder-names ((url )) ???) @@ -566,10 +569,6 @@ (or (imap-folder-unseen folder) 0)) |# -(define-method append-message ((folder ) (message )) - (guarantee-imap-folder-open folder) - ???) - (define-method expunge-deleted-messages ((folder )) (guarantee-imap-folder-open folder) (imap:command:expunge (imap-folder-connection folder))) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index d06ad6ba0..ba71ea9d9 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.24 2000/05/10 17:03:27 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.25 2000/05/12 18:22:56 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -68,11 +68,14 @@ (synchronize-file-folder-write folder write-rmail-file)) (define (compute-rmail-folder-header-fields folder) + (make-rmail-folder-header-fields (folder-flags folder))) + +(define (make-rmail-folder-header-fields flags) (list (make-header-field "Version" " 5") (make-header-field "Labels" (decorated-string-append "" "," "" - (flags->rmail-labels (folder-flags folder)))) + (flags->rmail-labels flags))) (make-header-field "Note" " This is the header of an rmail file.") (make-header-field "Note" " If you are seeing it in rmail,") (make-header-field "Note" @@ -96,7 +99,7 @@ (let ((message (read-rmail-message port))) (if message (begin - (append-message folder message) + (append-message message (folder-url folder)) (loop)))))))))) (define (read-rmail-prolog port) @@ -176,13 +179,27 @@ ;; **** Do backup of file here. (call-with-binary-output-file pathname (lambda (port) - (write-string "BABYL OPTIONS: -*- rmail -*-" port) - (newline port) - (write-header-fields (rmail-folder-header-fields folder) port) - (write-char rmail-message:end-char port) + (write-rmail-file-header (rmail-folder-header-fields folder)) (for-each (lambda (message) (write-rmail-message message port)) (file-folder-messages folder))))) +(define-method append-message-to-file ((message ) (url )) + (let ((pathname (file-url-pathname url))) + (if (file-exists? pathname) + (let ((port (open-binary-output-file pathname #t))) + (write-rmail-message message port) + (close-port port)) + (call-with-binary-output-file pathname + (lambda (port) + (write-rmail-file-header (make-rmail-folder-header-fields '())) + (write-rmail-message message port)))))) + +(define (write-rmail-file-header header-fields) + (write-string "BABYL OPTIONS: -*- rmail -*-" port) + (newline port) + (write-header-fields header-fields port) + (write-char rmail-message:end-char port)) + (define (write-rmail-message message port) (write-char rmail-message:start-char port) (newline port) @@ -248,8 +265,8 @@ (let ((n (folder-length inbox))) (do ((index 0 (+ index 1))) ((= index n)) - (append-message folder - (get-message inbox index)))) + (append-message (get-message inbox index) + (folder-url folder)))) inbox)) pathnames))) (save-folder folder) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 559ba8ea2..999d01ee3 100644 --- a/v7/src/imail/imail-top.scm +++ b/v7/src/imail/imail-top.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-top.scm,v 1.42 2000/05/12 18:00:56 cph Exp $ +;;; $Id: imail-top.scm,v 1.43 2000/05/12 18:22:59 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -660,13 +660,13 @@ Completion is performed over known flags when reading." "Append messages to this folder from a specified folder." "sInput from folder" (lambda (url-string) - (let ((folder (selected-folder)) - (message (selected-message)) - (folder* (open-folder url-string))) - (let ((n (folder-length folder*))) + (let ((message (selected-message)) + (folder (open-folder url-string)) + (url (folder-url (selected-folder)))) + (let ((n (folder-length folder))) (do ((index 0 (+ index 1))) ((= index n)) - (append-message folder (get-message folder* index)))) + (append-message (get-message folder index) url))) (if (not message) (select-message folder (first-unseen-message folder)))))) @@ -674,9 +674,8 @@ Completion is performed over known flags when reading." "Append this message to a specified folder." "sOutput to folder" (lambda (url-string) - (let ((folder (open-folder url-string)) - (message (selected-message))) - (append-message folder message) + (let ((message (selected-message))) + (append-message message url-string) (message-filed message) (if (ref-variable imail-delete-after-output) ((ref-command imail-delete-forward) #f)) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 991705c21..d1abc5f0e 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.18 2000/05/10 17:03:30 cph Exp $ +;;; $Id: imail-umail.scm,v 1.19 2000/05/12 18:23:03 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -138,6 +138,11 @@ (for-each (lambda (message) (write-umail-message message port)) (file-folder-messages folder))))) +(define-method append-message-to-file ((message ) (url )) + (let ((port (open-binary-output-file (file-url-pathname url) #t))) + (write-umail-message message port) + (close-port port))) + (define (write-umail-message message port) (let ((from-line (get-message-property message "umail-from-line" #f))) (if from-line diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt index 1d8b2130b..09eb4f0a5 100644 --- a/v7/src/imail/todo.txt +++ b/v7/src/imail/todo.txt @@ -1,5 +1,5 @@ IMAIL To-Do List -$Id: todo.txt,v 1.5 2000/05/12 17:56:46 cph Exp $ +$Id: todo.txt,v 1.6 2000/05/12 18:23:05 cph Exp $ Bug fixes --------- @@ -34,11 +34,6 @@ Design changes Binary search can be used which should produce excellent results on large folders. UID FETCH command should be useful for this. -* Change APPEND-MESSAGE to accept arguments (MESSAGE URL) rather than - (FOLDER MESSAGE) as currently. There's no need to have the folder - open to append a message to it, and this requirement causes problems - for the IMAP back end. - * Try to leverage IMAP MIME parser by building compatible interface for file-based folders.