From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 22 May 2000 13:52:41 +0000 (+0000)
Subject: In APPEND-MESSAGE, create mailbox if append/copy causes error
X-Git-Tag: 20090517-FFI~3752
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e047580213f80fa0b7228dd0ef746e5c5f957266;p=mit-scheme.git

In APPEND-MESSAGE, create mailbox if append/copy causes error
containing TRYCREATE.
---

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 142d06c8d..da6572d7a 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.68 2000/05/22 13:30:18 cph Exp $
+;;; $Id: imail-imap.scm,v 1.69 2000/05/22 13:52:07 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -732,20 +732,37 @@
 	     url new-url)))
 
 (define-method %append-message ((message <message>) (url <imap-url>))
-  (let ((folder (message-folder message)))
+  (let ((folder (message-folder message))
+	(maybe-create
+	 (lambda (connection thunk)
+	   (let ((response (thunk)))
+	     (if (imap:response:no? response)
+		 (if (imap:response-code:trycreate?
+		      (imap:response:response-text-code response))
+		     (begin
+		       (imap:command:create connection (imap-url-mailbox url))
+		       (let ((response (thunk)))
+			 (if (imap:response:no? response)
+			     (imap:server-error response))))
+		     (imap:server-error response)))))))
     (if (let ((url* (folder-url folder)))
 	  (and (imap-url? url*)
 	       (compatible-imap-urls? url url*)))
-	(imap:command:copy (imap-folder-connection folder)
-			   (message-index message)
-			   (imap-url-mailbox url))
+	(let ((connection (imap-folder-connection folder)))
+	  (maybe-create connection
+	    (lambda ()
+	      (imap:command:uid-copy connection
+				     (imap-message-uid message)
+				     (imap-url-mailbox url)))))
 	(with-open-imap-connection url
 	  (lambda (connection)
-	    (imap:command:append connection
-				 (imap-url-mailbox url)
-				 (message-flags message)
-				 (message-internal-time message)
-				 (message->string message)))))))
+	    (maybe-create connection
+	      (lambda ()
+		(imap:command:append connection
+				     (imap-url-mailbox url)
+				     (message-flags message)
+				     (message-internal-time message)
+				     (message->string message)))))))))
 
 (define-method available-folder-names ((url <imap-url>))
   url
@@ -880,14 +897,14 @@
 (define (imap:command:rename connection from to)
   (imap:command:no-response connection 'RENAME from to))
 
-(define (imap:command:copy connection index mailbox)
-  (imap:command:no-response connection 'COPY (+ index 1) mailbox))
+(define (imap:command:uid-copy connection uid mailbox)
+  (imap:command:no-response-1 connection 'UID 'COPY uid mailbox))
 
 (define (imap:command:append connection mailbox flags time text)
-  (imap:command:no-response connection 'APPEND mailbox
-			    (and (pair? flags) flags)
-			    (imap:universal-time->date-time time)
-			    (cons 'LITERAL text)))
+  (imap:command:no-response-1 connection 'APPEND mailbox
+			      (and (pair? flags) flags)
+			      (imap:universal-time->date-time time)
+			      (cons 'LITERAL text)))
 
 (define (imap:command:search connection . key-plist)
   (apply imap:command:single-response imap:response:search? connection
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 93c000f37..18f98c29b 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.39 2000/05/22 13:25:33 cph Exp $
+;;; $Id: imail.pkg,v 1.40 2000/05/22 13:52:25 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -162,6 +162,7 @@
 	  imap:response-code:permanentflags?
 	  imap:response-code:read-only?
 	  imap:response-code:read-write?
+	  imap:response-code:trycreate?
 	  imap:response-code:uidnext
 	  imap:response-code:uidnext?
 	  imap:response-code:uidvalidity
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 995b7e0ec..e3c8fcfe1 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.33 2000/05/22 04:01:58 cph Exp $
+$Id: todo.txt,v 1.34 2000/05/22 13:52:41 cph Exp $
 
 Bug fixes
 ---------
@@ -51,10 +51,6 @@ New features
 
 * Add configurable confirmation for performing EXPUNGE.
 
-* M-x imail-output should create the folder if necessary.  This means
-  that %APPEND-MESSAGE method must check for [TRYCREATE] and do the
-  create if it is present.
-
 * Add command to rename folders.  Add command to append all of the
   messages from one folder to another.