From f44e657691b7af102749de2574692dd40f6f6f14 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 14 Jun 2000 02:16:23 +0000 Subject: [PATCH] When renaming a folder, the default for the target is the container for the source. When copying a folder, the default for the target is the base name of the source, merged into the container of the most recent copy target. --- v7/src/imail/imail-core.scm | 15 ++- v7/src/imail/imail-file.scm | 5 +- v7/src/imail/imail-imap.scm | 188 +++++++++++++++++++++-------------- v7/src/imail/imail-rmail.scm | 9 +- v7/src/imail/imail-top.scm | 52 ++++++---- v7/src/imail/imail-umail.scm | 7 +- v7/src/imail/todo.txt | 7 +- 7 files changed, 178 insertions(+), 105 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 887249f8c..5a0913abc 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.99 2000/06/08 18:49:27 cph Exp $ +;;; $Id: imail-core.scm,v 1.100 2000/06/14 02:15:36 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -71,13 +71,24 @@ ;; Return a string that represents the object containing URL's folder. ;; E.g. the container of "imap://localhost/inbox" is -;; "imap://localhost/". +;; "imap://localhost/" (except that for IMAP folders, the result may +;; be affected by the NAMESPACE prefix information). (define (url-container-string url) (make-url-string (url-protocol url) (url-body-container-string url))) (define-generic url-body-container-string (url)) +;; Return the base name of URL. This is the PATHNAME-NAME of a +;; file-based folder, and for IMAP it's the part of the mailbox name +;; following the rightmost delimiter. +(define-generic url-base-name (url)) + +;; Return a URL that has the same container as URL, but with base name +;; NAME. This is roughly equivalent to appending NAME to the +;; container string of URL. +(define-generic make-peer-url (url name)) + ;; Return #T if URL represents an existing folder. (define-generic url-exists? (url)) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 4b33b5027..bc664889b 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.41 2000/06/01 05:10:14 cph Exp $ +;;; $Id: imail-file.scm,v 1.42 2000/06/14 02:15:38 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -36,6 +36,9 @@ (define-method url-body-container-string ((url )) (directory-namestring (file-url-pathname url))) +(define-method url-base-name ((url )) + (pathname-name (file-url-pathname url))) + (define-method url-exists? ((url )) (file-exists? (file-url-pathname url))) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 21492c3b3..19fa2d324 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.116 2000/06/10 20:59:40 cph Exp $ +;;; $Id: imail-imap.scm,v 1.117 2000/06/14 02:15:39 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -40,68 +40,65 @@ (let ((constructor (instance-constructor '(USER-ID HOST PORT MAILBOX)))) (lambda (user-id host port mailbox) - (intern-url (constructor user-id - (string-downcase host) - port - (canonicalize-imap-mailbox mailbox)))))) - -(define (make-imap-url-string user-id host port mailbox) + (let ((url + (intern-url (constructor user-id + (string-downcase host) + port + "inbox")))) + (if (string-ci=? "inbox" mailbox) + url + (intern-url + (constructor user-id + (string-downcase host) + port + (canonicalize-imap-mailbox url mailbox)))))))) + +(define (make-imap-url-string url mailbox) (string-append "//" - (url:encode-string user-id) + (url:encode-string (imap-url-user-id url)) "@" - (string-downcase host) - (if (= port 143) - "" - (string-append ":" (number->string port))) + (string-downcase (imap-url-host url)) + (let ((port (imap-url-port url))) + (if (= port 143) + "" + (string-append ":" (number->string port)))) (if mailbox (string-append "/" - (url:encode-string (canonicalize-imap-mailbox mailbox))) + (url:encode-string + (canonicalize-imap-mailbox url mailbox))) ""))) -(define (canonicalize-imap-mailbox mailbox) - (cond ((string-ci=? mailbox "inbox") "inbox") - ((and (string-prefix-ci? "inbox." mailbox) - (not (string-prefix? "inbox." mailbox))) - (let ((mailbox (string-copy mailbox))) - (substring-downcase! mailbox 0 6) - mailbox)) - (else mailbox))) - +(define (canonicalize-imap-mailbox url mailbox) + (if (string-ci=? "inbox" mailbox) + "inbox" + (if (and (string-prefix-ci? "inbox" mailbox) + (not (string-prefix? "inbox" mailbox))) + (with-open-imap-connection url + (lambda (connection) + (let ((delimiter (imap-connection-delimiter connection))) + (if (and delimiter + (char=? (string-ref mailbox 5) + (string-ref delimiter 0))) + (let ((mailbox (string-copy mailbox))) + (substring-downcase! mailbox 0 5) + mailbox) + mailbox)))) + mailbox))) + (define-method url-body ((url )) - (make-imap-url-string (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - (imap-url-mailbox url))) + (make-imap-url-string url (imap-url-mailbox url))) (define-method url-presentation-name ((url )) (imap-url-mailbox url)) -(define-method url-body-container-string ((url )) - (make-imap-url-string - (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - (with-open-imap-connection url - (lambda (connection) - (let ((namespace - (let ((namespace (imap-connection-namespace connection))) - (and namespace - (let ((personal - (imap:response:namespace-personal namespace))) - (and (pair? personal) - (car personal))))))) - (if (and namespace (cadr namespace)) - (let ((prefix (car namespace)) - (delimiter (cadr namespace))) - (if (and (fix:= (string-length prefix) 6) - (string-prefix-ci? "inbox" prefix) - (not (string-prefix? "inbox" prefix)) - (string-suffix? delimiter prefix)) - (string-append "inbox" delimiter) - prefix)) - "")))))) - +(define (compatible-imap-urls? url1 url2) + ;; Can URL1 and URL2 both be accessed from the same IMAP session? + ;; E.g. can the IMAP COPY command work between them? + (and (string=? (imap-url-user-id url1) (imap-url-user-id url2)) + (string=? (imap-url-host url1) (imap-url-host url2)) + (= (imap-url-port url1) (imap-url-port url2)))) + (define-method url-exists? ((url )) (not (condition? @@ -114,19 +111,66 @@ '(MESSAGES)))) #t))))) -(define (compatible-imap-urls? url1 url2) - ;; Can URL1 and URL2 both be accessed from the same IMAP session? - ;; E.g. can the IMAP COPY command work between them? - (and (string=? (imap-url-user-id url1) (imap-url-user-id url2)) - (string=? (imap-url-host url1) (imap-url-host url2)) - (= (imap-url-port url1) (imap-url-port url2)))) - (define-method url-pass-phrase-key ((url )) - (make-url-string "imap" - (make-imap-url-string (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - #f))) + (make-url-string "imap" (make-imap-url-string url #f))) + +(define-method url-body-container-string ((url )) + (make-imap-url-string + url + (with-open-imap-connection url + (lambda (connection) + (imap-mailbox-container-string connection (imap-url-mailbox url)))))) + +(define-method url-base-name ((url )) + (with-open-imap-connection url + (lambda (connection) + (let ((mailbox (imap-url-mailbox url))) + (let ((index + (let ((delimiter (imap-connection-delimiter connection))) + (and delimiter + (string-search-backward delimiter mailbox))))) + (if index + (string-tail mailbox index) + mailbox)))))) + +(define-method make-peer-url ((url ) base-name) + (make-imap-url (imap-url-user-id url) + (imap-url-host url) + (imap-url-port url) + (string-append + (with-open-imap-connection url + (lambda (connection) + (imap-mailbox-container-string connection + (imap-url-mailbox url)))) + base-name))) + +(define (imap-mailbox-container-string connection mailbox) + (let ((index + (let ((delimiter (imap-connection-delimiter connection))) + (and delimiter + (string-search-backward delimiter mailbox))))) + (if index + (string-head mailbox index) + (imap-mailbox-name-prefix connection)))) + +(define (imap-mailbox-name-prefix connection) + (let ((namespace + (let ((namespace (imap-connection-namespace connection))) + (and namespace + (let ((personal + (imap:response:namespace-personal namespace))) + (and (pair? personal) + (car personal))))))) + (if (and namespace (cadr namespace)) + (let ((prefix (car namespace)) + (delimiter (cadr namespace))) + (if (and (fix:= (string-length prefix) 6) + (string-prefix-ci? "inbox" prefix) + (not (string-prefix? "inbox" prefix)) + (string-suffix? delimiter prefix)) + (string-append "inbox" delimiter) + prefix)) + ""))) (define-method parse-url-body (string default-url) (call-with-values (lambda () (parse-imap-url-body string default-url)) @@ -168,11 +212,7 @@ (lambda (mailbox url) (if mailbox (let ((convert - (lambda (mailbox) - (make-imap-url-string (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - mailbox)))) + (lambda (mailbox) (make-imap-url-string url mailbox)))) (complete-imap-mailbox mailbox url (lambda (mailbox) (if-unique (convert mailbox))) @@ -187,11 +227,7 @@ (call-with-values (lambda () (imap-completion-args string default-url)) (lambda (mailbox url) (if mailbox - (map (lambda (mailbox) - (make-imap-url-string (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - mailbox)) + (map (lambda (mailbox) (make-imap-url-string url mailbox)) (imap-mailbox-completions mailbox url)) '())))) @@ -231,6 +267,7 @@ (port define standard initial-value #f) (greeting define standard initial-value #f) (capabilities define standard initial-value '()) + (delimiter define standard initial-value #f) (namespace define standard initial-value #f) (sequence-number define standard initial-value 0) (response-queue define accessor initializer (lambda () (cons '() '()))) @@ -248,6 +285,7 @@ (lambda () (set-imap-connection-greeting! connection #f) (set-imap-connection-capabilities! connection '()) + (set-imap-connection-delimiter! connection #f) (set-imap-connection-namespace! connection #f) (set-imap-connection-sequence-number! connection 0) (let ((queue (imap-connection-response-queue connection))) @@ -377,6 +415,7 @@ (imail-ui:delete-stored-pass-phrase url) (error "Unable to log in:" (imap:response:response-text-string response)))))) + (imap:command:list connection "" "inbox") ;get delimiter (if (memq 'NAMESPACE (imap-connection-capabilities connection)) (imap:command:namespace connection)) #t))) @@ -1491,6 +1530,9 @@ (set-imap-connection-namespace! connection response) #f) ((imap:response:list? response) + (set-imap-connection-delimiter! + connection + (imap:response:list-delimiter response)) (eq? command 'LIST)) ((imap:response:lsub? response) (eq? command 'LSUB)) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 7d603146f..84c920d03 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.38 2000/06/05 20:56:49 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.39 2000/06/14 02:15:40 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -35,6 +35,11 @@ (define-method parse-url-body ((string ) (default-url )) (make-rmail-url (merge-pathnames string (file-url-pathname default-url)))) +(define-method make-peer-url ((url ) name) + (make-rmail-url + (merge-pathnames (pathname-default-type name "rmail") + (directory-pathname (file-url-pathname url))))) + (define-file-url-completers (let ((type-filter (file-type-filter "rmail"))) (lambda (pathname) @@ -57,7 +62,7 @@ folder (compute-rmail-folder-header-fields folder)) (save-folder folder))) - + ;;;; Folder (define-class ( (constructor (url))) () diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index bd1fa06d5..fa026afd9 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.150 2000/06/13 21:18:24 cph Exp $ +;;; $Id: imail-top.scm,v 1.151 2000/06/14 02:15:42 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -167,7 +167,7 @@ the type of folder. Likewise, the available commands are the same regardless of the folder type." (lambda () (list (and (command-argument) - (prompt-for-imail-url-string "Run IMAIL on folder" + (prompt-for-imail-url-string "Run IMAIL on folder" #f 'HISTORY 'IMAIL 'REQUIRE-MATCH? #t)))) (lambda (url-string) @@ -191,8 +191,8 @@ regardless of the folder type." (or (first-unseen-message folder) (selected-message #f)) #t))))))) - -(define (prompt-for-imail-url-string prompt . options) + +(define (prompt-for-imail-url-string prompt default . options) (let ((get-option (lambda (key) (let loop ((options options)) @@ -201,7 +201,11 @@ regardless of the folder type." (if (eq? (car options) key) (cadr options) (loop (cddr options))))))) - (default (url-container-string (imail-default-url)))) + (default + (cond ((string? default) default) + ((url? default) (url->string default)) + ((not default) (url-container-string (imail-default-url))) + (else (error "Illegal default:" default))))) (let ((history (get-option 'HISTORY))) (if (null? (prompt-history-strings history)) (set-prompt-history-strings! history (list default)))) @@ -1440,7 +1444,7 @@ With prefix argument N, removes FLAG from next N messages, "Create a new folder with the specified name. An error if signalled if the folder already exists." (lambda () - (list (prompt-for-imail-url-string "Create folder" + (list (prompt-for-imail-url-string "Create folder" #f 'HISTORY 'IMAIL-CREATE-FOLDER))) (lambda (url-string) (let ((url (imail-parse-partial-url url-string))) @@ -1450,7 +1454,7 @@ An error if signalled if the folder already exists." (define-command imail-delete-folder "Delete a specified folder and all its messages." (lambda () - (list (prompt-for-imail-url-string "Delete folder" + (list (prompt-for-imail-url-string "Delete folder" #f 'HISTORY 'IMAIL-DELETE-FOLDER 'REQUIRE-MATCH? #t))) (lambda (url-string) @@ -1468,14 +1472,15 @@ May only rename a folder to a new name on the same server or file system. The folder's type may not be changed." (lambda () (let ((from - (prompt-for-imail-url-string "Rename folder" + (prompt-for-imail-url-string "Rename folder" #f 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE 'HISTORY-INDEX 0 'REQUIRE-MATCH? #t))) (list from - (prompt-for-imail-url-string "Rename folder to" - 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET - 'HISTORY-INDEX 0)))) + (prompt-for-imail-url-string + "Rename folder to" + (url-container-string (imail-parse-partial-url from)) + 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET)))) (lambda (from to) (let ((from (imail-parse-partial-url from)) (to (imail-parse-partial-url to))) @@ -1485,7 +1490,7 @@ The folder's type may not be changed." (define-command imail-input "Run IMAIL on a specified folder." (lambda () - (list (prompt-for-imail-url-string "Run IMAIL on folder" + (list (prompt-for-imail-url-string "Run IMAIL on folder" #f 'HISTORY 'IMAIL 'REQUIRE-MATCH? #t))) (lambda (url-string) @@ -1494,7 +1499,7 @@ The folder's type may not be changed." (define-command imail-input-from-folder "Append messages to this folder from a specified folder." (lambda () - (list (prompt-for-imail-url-string "Get messages from folder" + (list (prompt-for-imail-url-string "Get messages from folder" #f 'HISTORY 'IMAIL-INPUT 'HISTORY-INDEX 0 'REQUIRE-MATCH? #t))) @@ -1522,7 +1527,7 @@ The folder's type may not be changed." (define-command imail-output "Append this message to a specified folder." (lambda () - (list (prompt-for-imail-url-string "Output to folder" + (list (prompt-for-imail-url-string "Output to folder" #f 'HISTORY 'IMAIL-OUTPUT 'HISTORY-INDEX 0) (command-argument))) @@ -1548,7 +1553,7 @@ The messages are NOT deleted even if imail-delete-after-output is true. This command is meant to be used to move the contents of a folder either to or from an IMAP server." (lambda () - (list (prompt-for-imail-url-string "Copy all messages to folder" + (list (prompt-for-imail-url-string "Copy all messages to folder" #f 'HISTORY 'IMAIL-OUTPUT 'HISTORY-INDEX 0))) (lambda (url-string) @@ -1560,14 +1565,21 @@ If the target folder exists, the messages are appended to it. If it doesn't exist, it is created first." (lambda () (let ((from - (prompt-for-imail-url-string "Copy folder" + (prompt-for-imail-url-string "Copy folder" #f 'HISTORY 'IMAIL-COPY-FOLDER-SOURCE 'HISTORY-INDEX 0 'REQUIRE-MATCH? #t))) (list from - (prompt-for-imail-url-string "Copy messages to folder" - 'HISTORY 'IMAIL-COPY-FOLDER-TARGET - 'HISTORY-INDEX 0)))) + (prompt-for-imail-url-string + "Copy messages to folder" + (make-peer-url + (let ((history + (prompt-history-strings 'IMAIL-COPY-FOLDER-TARGET))) + (and (pair? history) + (imail-parse-partial-url (car history)) + (imail-default-url))) + (url-base-name (imail-parse-partial-url from))) + 'HISTORY 'IMAIL-COPY-FOLDER-TARGET)))) (lambda (from to) (copy-folder (open-folder (imail-parse-partial-url from)) (imail-parse-partial-url to)))) @@ -1947,7 +1959,7 @@ A prefix argument says to prompt for a URL and append all messages from that folder to the current one." (lambda () (list (and (command-argument) - (prompt-for-imail-url-string "Get messages from folder" + (prompt-for-imail-url-string "Get messages from folder" #f 'HISTORY 'IMAIL-INPUT 'HISTORY-INDEX 0 'REQUIRE-MATCH? #t)))) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index f61b5a47f..09ff4c0f8 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.31 2000/06/05 20:56:52 cph Exp $ +;;; $Id: imail-umail.scm,v 1.32 2000/06/14 02:15:43 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -35,6 +35,11 @@ (define-method parse-url-body ((string ) (default-url )) (make-umail-url (merge-pathnames string (file-url-pathname default-url)))) +(define-method make-peer-url ((url ) name) + (make-umail-url + (merge-pathnames (pathname-default-type name "mail") + (directory-pathname (file-url-pathname url))))) + (define-file-url-completers (file-type-filter "mail")) diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt index 99a36843f..09b725c25 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.77 2000/06/13 21:18:45 cph Exp $ +$Id: todo.txt,v 1.78 2000/06/14 02:16:23 cph Exp $ Bug fixes --------- @@ -31,11 +31,6 @@ New features big binary things but small text things that are easier to view inline. -* In M-x imail-copy-folder, default the target buffer to have the same - name as the source buffer, e.g. from "foo.rmail" to "inbox.foo". - [It may not be obvious how to do this as I'm not sure how to specify - the prefix "inbox." in a server-independent way.] - * Set the IMAIL buffer's modification bit to indicate whether the folder is locally modified. Meaningful only for file folders. Hook up the save-folder code into M-x save-some-buffers. -- 2.25.1