;;; -*-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
;;;
;; 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))
;;; -*-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
;;;
(define-method url-body-container-string ((url <file-url>))
(directory-namestring (file-url-pathname url)))
+(define-method url-base-name ((url <file-url>))
+ (pathname-name (file-url-pathname url)))
+
(define-method url-exists? ((url <file-url>))
(file-exists? (file-url-pathname url)))
;;; -*-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
;;;
(let ((constructor
(instance-constructor <imap-url> '(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)))
-\f
+(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 <imap-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>))
(imap-url-mailbox url))
-(define-method url-body-container-string ((url <imap-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))))
+\f
(define-method url-exists? ((url <imap-url>))
(not
(condition?
'(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 <imap-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 <imap-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 <imap-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 <imap-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))
+ "")))
\f
(define-method parse-url-body (string default-url)
(call-with-values (lambda () (parse-imap-url-body string default-url))
(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)))
(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))
'()))))
(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 '() '())))
(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)))
(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)))
(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))
;;; -*-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
;;;
(define-method parse-url-body ((string <string>) (default-url <rmail-url>))
(make-rmail-url (merge-pathnames string (file-url-pathname default-url))))
+(define-method make-peer-url ((url <rmail-url>) name)
+ (make-rmail-url
+ (merge-pathnames (pathname-default-type name "rmail")
+ (directory-pathname (file-url-pathname url)))))
+
(define-file-url-completers <rmail-url>
(let ((type-filter (file-type-filter "rmail")))
(lambda (pathname)
folder
(compute-rmail-folder-header-fields folder))
(save-folder folder)))
-
+\f
;;;; Folder
(define-class (<rmail-folder> (constructor (url))) (<file-folder>)
;;; -*-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
;;;
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)
(or (first-unseen-message folder)
(selected-message #f))
#t)))))))
-
-(define (prompt-for-imail-url-string prompt . options)
+\f
+(define (prompt-for-imail-url-string prompt default . options)
(let ((get-option
(lambda (key)
(let loop ((options options))
(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))))
"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)))
(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)
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)))
(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)
(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)))
(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)))
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)
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))))
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))))
;;; -*-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
;;;
(define-method parse-url-body ((string <string>) (default-url <umail-url>))
(make-umail-url (merge-pathnames string (file-url-pathname default-url))))
+(define-method make-peer-url ((url <umail-url>) name)
+ (make-umail-url
+ (merge-pathnames (pathname-default-type name "mail")
+ (directory-pathname (file-url-pathname url)))))
+
(define-file-url-completers <umail-url>
(file-type-filter "mail"))
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
---------
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.
projects / mit-scheme.git / commitdiff