;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.78 2000/05/20 19:37:03 cph Exp $
+;;; $Id: imail-core.scm,v 1.79 2000/05/22 02:17:35 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-class <url> (<imail-object>))
+(define (guarantee-url url procedure)
+ (if (not (url? url))
+ (error:wrong-type-argument url "IMAIL URL" procedure)))
+
;; Return the canonical name of URL's protocol as a string.
(define-generic url-protocol (url))
;; Return the body of URL as a string.
(define-generic url-body (url))
-(define (guarantee-url url procedure)
- (if (not (url? url))
- (error:wrong-type-argument url "IMAIL URL" procedure)))
+(define (url->string url)
+ (string-append (url-protocol url) ":" (url-body url)))
(define-method write-instance ((url <url>) port)
(write-instance-helper 'URL url port
(write-char #\space port)
(write (url->string url) port))))
-(define (make-url protocol body)
- (string->url (string-append protocol ":" body)))
-
-(define-generic ->url (object))
-(define-method ->url ((url <url>)) url)
-(define-method ->url ((string <string>)) (string->url string))
-
-(define (string->url string)
- (or (hash-table/get saved-urls string #f)
- (let ((url
- (let ((colon (string-find-next-char string #\:)))
- (if (not colon)
- (error:bad-range-argument string 'STRING->URL))
- ((or (get-url-protocol-parser (string-head string colon))
- (error:bad-range-argument string 'STRING->URL))
- (string-tail string (fix:+ colon 1))))))
- (hash-table/put! saved-urls string url)
- url)))
-
-(define (save-url url)
+;; Return a string that concisely identifies URL, for use in the
+;; presentation layer.
+(define-generic url-presentation-name (url))
+
+;; Convert STRING to a URL. GET-DEFAULT-URL is a procedure of one
+;; argument that returns a URL that is used to fill in defaults if
+;; STRING is a specification for a partial URL. GET-DEFAULT-URL is
+;; called with #F as its first argument to return a default URL to be
+;; used if STRING doesn't explicitly specify a protocol. Otherwise,
+;; it is called with a protocol name as its first argument to return a
+;; protocol-specific default.
+(define (parse-url-string string get-default-url)
+ (let ((colon (string-find-next-char string #\:)))
+ (if colon
+ (%parse-url-string (string-tail string (fix:+ colon 1))
+ (get-default-url (string-head string colon)))
+ (%parse-url-string string (get-default-url #f)))))
+
+;; Protocol-specific parsing. Dispatch on the class of DEFAULT-URL.
+;; Each method is responsible for calling INTERN-URL on the result of
+;; the parse, and returning the interned URL. Illegal syntax in
+;; STRING must cause an error to be signalled.
+(define-generic %parse-url-string (string default-url))
+
+(define (intern-url url)
(let ((string (url->string url)))
- (or (hash-table/get saved-urls string #f)
+ (or (hash-table/get interned-urls string #f)
(begin
- (hash-table/put! saved-urls string url)
+ (hash-table/put! interned-urls string url)
url))))
-(define saved-urls
+(define interned-urls
(make-string-hash-table))
-(define (url->string url)
- (string-append (url-protocol url) ":" (url-body url)))
-
-(define (define-url-protocol name class parser completer completions)
+(define (define-url-protocol name class)
(define-method url-protocol ((url class)) url name)
- (hash-table/put! url-protocols
- (string-downcase name)
- (vector parser completer completions)))
+ (hash-table/put! url-protocols (string-downcase name) class))
-(define (get-url-protocol-parser name) (get-url-protocol-item name 0))
-(define (get-url-protocol-completer name) (get-url-protocol-item name 1))
-(define (get-url-protocol-completions name) (get-url-protocol-item name 2))
-
-(define (get-url-protocol-item name index)
- (let ((v (hash-table/get url-protocols (string-downcase name) #f)))
- (and v
- (vector-ref v index))))
+(define (url-protocol-name? name)
+ (hash-table/get url-protocols (string-downcase name) #f))
(define url-protocols
(make-string-hash-table))
-
-;; Return a string that concisely identifies URL, for use in the
-;; presentation layer.
-(define-generic url-presentation-name (url))
\f
;; Do completion on URL-STRING, which is a partially-specified URL.
;; Tail-recursively calls one of the three procedure arguments, as
;; completions. If URL-STRING has no completions, IF-NOT-FOUND is
;; called with no arguments.
-(define (url-complete-string url-string if-unique if-not-unique if-not-found)
- (let ((colon (string-find-next-char url-string #\:)))
+;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
+
+(define (url-complete-string string get-default-url
+ if-unique if-not-unique if-not-found)
+ (let ((colon (string-find-next-char string #\:)))
(if colon
- (let ((prepend
- (let ((prefix (string-head url-string (fix:+ colon 1))))
- (lambda (string)
- (string-append prefix string)))))
- (let ((completer
- (get-url-protocol-completer (string-head url-string colon))))
- (if completer
- (completer (string-tail url-string (fix:+ colon 1))
- (lambda (string)
- (if-unique (prepend string)))
- (lambda (prefix get-completions)
- (if-not-unique
- (prepend prefix)
- (lambda () (map prepend (get-completions)))))
- if-not-found)
- (if-not-found))))
+ (let ((name (string-head string colon)))
+ (if (url-protocol-name? name)
+ (let ((prepend
+ (lambda (string) (string-append name ":" string))))
+ (%url-complete-string (string-tail string (fix:+ colon 1))
+ (get-default-url name)
+ (lambda (string)
+ (if-unique (prepend string)))
+ (lambda (prefix get-completions)
+ (if-not-unique
+ (prepend prefix)
+ (lambda ()
+ (map prepend (get-completions)))))
+ if-not-found))
+ (if-not-found)))
(let ((colonify (lambda (name) (string-append name ":"))))
((ordered-string-vector-completer
(hash-table/ordered-key-vector url-protocols string<?))
- url-string
+ string
(lambda (name)
(if-unique (colonify name)))
(lambda (prefix get-completions)
(lambda () (map colonify (get-completions)))))
if-not-found)))))
-;; Return a list of the completions for URL-STRING.
+(define-generic %url-complete-string
+ (string default-url if-unique if-not-unique if-not-found))
-(define (url-string-completions url-string)
- (let ((colon (string-find-next-char url-string #\:)))
+;; Return a list of the completions for STRING.
+;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
+
+(define (url-string-completions string get-default-url)
+ (let ((colon (string-find-next-char string #\:)))
(if colon
- (let ((get-completions
- (get-url-protocol-completions (string-head url-string colon))))
- (if get-completions
- (map (let ((prefix (string-head url-string (fix:+ colon 1))))
- (lambda (string)
- (string-append prefix string)))
- (get-completions (string-tail url-string (fix:+ colon 1))))
+ (let ((name (string-head string colon)))
+ (if (url-protocol-name? name)
+ (map (lambda (string) (string-append name ":" string))
+ (%url-string-completions
+ (string-tail string (fix:+ colon 1))
+ (get-default-url name)))
'()))
(map (lambda (name) (string-append name ":"))
(vector->list
((ordered-string-vector-matches
(hash-table/ordered-key-vector url-protocols string<?))
- url-string))))))
+ string))))))
+
+(define-generic %url-string-completions (string default-url))
\f
;;;; Server operations
;; already exists or can't be created.
(define (create-folder url)
- (%create-folder (->url url)))
+ (%create-folder url))
(define-generic %create-folder (url))
;; exist or if it can't be deleted.
(define (delete-folder url)
- (let ((url (->url url)))
- (let ((folder (get-memoized-folder url)))
- (if folder
- (close-folder folder)))
- (unmemoize-folder url)
- (%delete-folder url)))
+ (let ((folder (get-memoized-folder url)))
+ (if folder
+ (close-folder folder)))
+ (unmemoize-folder url)
+ (%delete-folder url))
(define-generic %delete-folder (url))
;; another. It only allows changing the name of an existing folder.
(define (rename-folder url new-url)
- (let ((url (->url url))
- (new-url (->url new-url)))
- (let ((folder (get-memoized-folder url)))
- (if folder
- (close-folder folder)))
- (unmemoize-folder url)
- (%rename-folder url new-url)))
+ (let ((folder (get-memoized-folder url)))
+ (if folder
+ (close-folder folder)))
+ (unmemoize-folder url)
+ (%rename-folder url new-url))
(define-generic %rename-folder (url new-url))
;; messages. Unspecified result.
(define (append-message message url)
- (%append-message message (->url url)))
+ (%append-message message url))
(define-generic %append-message (message url))
(if (not (folder? folder))
(error:wrong-type-argument folder "IMAIL folder" procedure)))
-(define-method ->url ((folder <folder>))
- (folder-url folder))
-
(define (folder-modified! folder type . parameters)
(without-interrupts
(lambda ()
;; Open the folder named URL.
(define (open-folder url)
- (let ((url (->url url)))
- (or (get-memoized-folder url)
- (memoize-folder (%open-folder url)))))
+ (or (get-memoized-folder url)
+ (memoize-folder (%open-folder url))))
(define-generic %open-folder (url))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.30 2000/05/20 19:39:14 cph Exp $
+;;; $Id: imail-file.scm,v 1.31 2000/05/22 02:17:39 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(pathname define accessor))
(define-method url-body ((url <file-url>))
- (pathname->short-name (file-url-pathname url)))
+ (->namestring (file-url-pathname url)))
(define-method url-presentation-name ((url <file-url>))
(file-namestring (file-url-pathname url)))
-(define ((file-url-completer filter)
- string if-unique if-not-unique if-not-found)
- (pathname-complete-string (short-name->pathname string) filter
- (lambda (string)
- (if-unique (pathname->short-name string)))
- (lambda (prefix get-completions)
- (if-not-unique (pathname->short-name prefix)
- (lambda () (map pathname->short-name (get-completions)))))
- if-not-found))
-
-(define ((file-url-completions filter) string)
- (map pathname->short-name
- (pathname-completions-list (short-name->pathname string) filter)))
-
-(define (file-suffix-filter suffix)
- (let ((suffix (string-append "." suffix)))
- (let ((l (string-length suffix)))
- (lambda (pathname)
- (let ((string (file-namestring pathname)))
- (let ((i (string-search-forward suffix string)))
- (and i
- (fix:> i 0)
- (let ((i (fix:+ i l)))
- (or (fix:= i (string-length string))
- (char=? #\. (string-ref string i)))))))))))
+(define (define-file-url-completers class filter)
+ (define-method %url-complete-string
+ ((string <string>) (default-url class)
+ if-unique if-not-unique if-not-found)
+ (pathname-complete-string
+ (merge-pathnames string (file-url-pathname default-url))
+ filter
+ (lambda (string)
+ (if-unique (->namestring string)))
+ (lambda (prefix get-completions)
+ (if-not-unique (->namestring prefix)
+ (lambda () (map ->namestring (get-completions)))))
+ if-not-found))
+ (define-method %url-string-completions
+ ((string <string>) (default-url class))
+ (map ->namestring
+ (pathname-completions-list
+ (merge-pathnames string (file-url-pathname default-url))
+ filter))))
+
+(define ((file-type-filter type) pathname)
+ (let ((type* (pathname-type pathname)))
+ (and type*
+ (string=? type* type))))
;;;; Server operations
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-imap.scm,v 1.62 2000/05/20 19:09:49 cph Exp $
+;;; $Id: imail-imap.scm,v 1.63 2000/05/22 02:17:41 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;; Name of mailbox to access.
(mailbox define accessor))
-(define (make-imap-url user-id host port mailbox)
- (save-url (%make-imap-url user-id host port mailbox)))
-
-(define-url-protocol "imap" <imap-url>
- (lambda (string)
- (let ((pv
- (or (parse-string imap:parse:imail-url string)
- (error:bad-range-argument string 'STRING->URL))))
- (%make-imap-url (parser-token pv 'USER-ID)
- (parser-token pv 'HOST)
- (let ((port (parser-token pv 'PORT)))
- (and port
- (string->number port)))
- (parser-token pv 'MAILBOX)))))
-
-(define %make-imap-url
+(define-url-protocol "imap" <imap-url>)
+
+(define make-imap-url
(let ((constructor
(instance-constructor <imap-url> '(USER-ID HOST PORT MAILBOX))))
(lambda (user-id host port mailbox)
- (if (and user-id host port mailbox)
- (constructor user-id host port mailbox)
- (let ((default (imail-default-imap-url)))
- (constructor (or user-id (imap-url-user-id default))
- (or host (imap-url-host default))
- (or port (imap-url-port default))
- (or mailbox (imap-url-mailbox default))))))))
-
-(define imap:parse:imail-url
- (let ((//server
- (sequence-parser (noise-parser (string-matcher "//"))
- (imap:server-parser #f)))
- (/mbox
- (sequence-parser (noise-parser (string-matcher "/"))
- (optional-parser imap:parse:enc-mailbox))))
- (alternatives-parser
- (sequence-parser //server (optional-parser /mbox))
- /mbox
- imap:parse:enc-mailbox)))
+ (intern-url (constructor user-id host port 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)))
+
+(define (make-imap-url-string user-id host port mailbox)
(string-append "//"
- (url:encode-string (imap-url-user-id url))
+ (url:encode-string user-id)
"@"
- (imap-url-host url)
+ host
":"
- (number->string (imap-url-port url))
+ (number->string port)
"/"
- (url:encode-string (imap-url-mailbox url))))
+ (url:encode-string mailbox)))
(define-method url-presentation-name ((url <imap-url>))
(imap-url-mailbox url))
(and (string=? (imap-url-user-id url1) (imap-url-user-id url2))
(string-ci=? (imap-url-host url1) (imap-url-host url2))
(= (imap-url-port url1) (imap-url-port url2))))
+
+(define-method %parse-url-string (string default-url)
+ (or (parse-imap-url-string string default-url)
+ (error:bad-range-argument string 'PARSE-URL-STRING)))
+
+(define parse-imap-url-string
+ (let ((parser
+ (let ((//server
+ (sequence-parser (noise-parser (string-matcher "//"))
+ (imap:server-parser #f)))
+ (/mbox
+ (sequence-parser (noise-parser (string-matcher "/"))
+ (optional-parser imap:parse:enc-mailbox))))
+ (alternatives-parser
+ (sequence-parser //server (optional-parser /mbox))
+ /mbox
+ imap:parse:enc-mailbox))))
+ (lambda (string default-url)
+ (let ((pv (parse-string parser string)))
+ (and pv
+ (make-imap-url (or (parser-token pv 'USER-ID)
+ (imap-url-user-id default-url))
+ (or (parser-token pv 'HOST)
+ (imap-url-host default-url))
+ (cond ((parser-token pv 'PORT) => string->number)
+ ((parser-token pv 'HOST) 143)
+ (else (imap-url-port default-url)))
+ (or (parser-token pv 'MAILBOX)
+ (imap-url-mailbox default-url))))))))
+\f
+(define-method %url-complete-string
+ ((string <string>) (default-url <imap-url>)
+ if-unique if-not-unique if-not-found)
+ (call-with-values
+ (lambda () (parse-imap-completion-url-string string default-url))
+ (lambda (mailbox url)
+ (if mailbox
+ (let ((convert
+ (lambda (mailbox)
+ (url-body (parse-imap-url-string mailbox url)))))
+ (complete-imap-mailbox mailbox url
+ (lambda (mailbox)
+ (if-unique (convert mailbox)))
+ (lambda (prefix get-mailboxes)
+ (if-not-unique (if (string-null? prefix)
+ (make-imap-url-string (imap-url-user-id url)
+ (imap-url-host url)
+ (imap-url-port url)
+ "")
+ (convert prefix))
+ (lambda () (map convert (get-mailboxes)))))
+ if-not-found))
+ (if-not-found)))))
+
+(define-method %url-string-completions
+ ((string <string>) (default-url <imap-url>))
+ (call-with-values
+ (lambda () (parse-imap-completion-url-string string default-url))
+ (lambda (mailbox url)
+ (if mailbox
+ (map (lambda (mailbox)
+ (url-body (parse-imap-url-string mailbox url)))
+ (imap-mailbox-completions mailbox url))
+ '()))))
+
+(define (parse-imap-completion-url-string string default-url)
+ (cond ((string-null? string)
+ (values string default-url))
+ ((parse-imap-url-string string default-url)
+ => (lambda (url) (values (imap-url-mailbox url) url)))
+ (else
+ (values #f #f))))
+
+(define (complete-imap-mailbox mailbox url
+ if-unique if-not-unique if-not-found)
+ (if (string-null? mailbox)
+ (if-not-unique mailbox
+ (lambda () (imap-mailbox-completions mailbox url)))
+ (let ((responses (imap-mailbox-completions mailbox url)))
+ (cond ((not (pair? responses))
+ (if-not-found))
+ ((pair? (cdr responses))
+ (if-not-unique (string-greatest-common-prefix responses)
+ (lambda () responses)))
+ (else
+ (if-unique (car responses)))))))
+
+(define (imap-mailbox-completions mailbox url)
+ (map imap:response:list-mailbox
+ (with-open-imap-connection url
+ (lambda (connection)
+ (imap:command:list connection "" (string-append mailbox "*"))))))
\f
;;;; Server connection
(define (imap:command:capability connection)
(imap:response:capabilities
- (imap:command:single-response imap:response:capability?
- connection 'CAPABILITY)))
+ (imap:command:single-response imap:response:capability? connection
+ 'CAPABILITY)))
(define (imap:command:login connection user-id passphrase)
((imail-message-wrapper "Logging in as " user-id)
((imail-message-wrapper "Select mailbox " mailbox)
(lambda ()
(imap:response:ok?
- (imap:command:no-response-1 connection 'SELECT
- (adjust-mailbox-name connection mailbox))))))
+ (imap:command:no-response-1 connection 'SELECT mailbox)))))
(define (imap:command:fetch connection index items)
- (imap:command:single-response imap:response:fetch?
- connection 'FETCH (+ index 1) items))
+ (imap:command:single-response imap:response:fetch? connection
+ 'FETCH (+ index 1) items))
(define (imap:command:uid-fetch connection uid items)
- (imap:command:single-response imap:response:fetch?
- connection 'UID 'FETCH uid items))
+ (imap:command:single-response imap:response:fetch? connection
+ 'UID 'FETCH uid items))
(define (imap:command:fetch-all connection items)
- (imap:command:multiple-response imap:response:fetch?
- connection 'FETCH
- (cons 'ATOM "1:*")
- items))
+ (imap:command:multiple-response imap:response:fetch? connection
+ 'FETCH (cons 'ATOM "1:*") items))
(define (imap:command:fetch-range connection start end items)
- (imap:command:multiple-response imap:response:fetch?
- connection 'FETCH
- (cons 'ATOM
- (string-append
- (number->string (+ start 1))
- ":"
- (if end
- (number->string end)
- "*")))
- items))
+ (imap:command:multiple-response
+ imap:response:fetch? connection
+ 'FETCH
+ (cons 'ATOM
+ (string-append (number->string (+ start 1))
+ ":"
+ (if end (number->string end) "*")))
+ items))
(define (imap:command:uid-store-flags connection uid flags)
(imap:command:no-response connection 'UID 'STORE uid 'FLAGS flags))
((imail-message-wrapper "Expunging messages")
(lambda ()
(imap:command:no-response connection 'EXPUNGE))))
-\f
+
(define (imap:command:noop connection)
(imap:command:no-response connection 'NOOP))
(define (imap:command:create connection mailbox)
- (imap:command:no-response connection 'CREATE
- (adjust-mailbox-name connection mailbox)))
+ (imap:command:no-response connection 'CREATE mailbox))
(define (imap:command:delete connection mailbox)
- (imap:command:no-response connection 'DELETE
- (adjust-mailbox-name connection mailbox)))
+ (imap:command:no-response connection 'DELETE mailbox))
(define (imap:command:rename connection from to)
- (imap:command:no-response connection 'RENAME
- (adjust-mailbox-name connection from)
- (adjust-mailbox-name connection to)))
+ (imap:command:no-response connection 'RENAME from to))
(define (imap:command:copy connection index mailbox)
- (imap:command:no-response connection 'COPY (+ index 1)
- (adjust-mailbox-name connection mailbox)))
+ (imap:command:no-response connection 'COPY (+ index 1) mailbox))
(define (imap:command:append connection mailbox flags time text)
- (imap:command:no-response connection
- 'APPEND
- (adjust-mailbox-name connection mailbox)
+ (imap:command:no-response 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 'SEARCH key-plist))
-
-(define (adjust-mailbox-name connection mailbox)
- (case (imap-connection-server-type connection)
- ((CYRUS)
- (if (or (string-ci=? "inbox" mailbox)
- (string-prefix-ci? "inbox." mailbox)
- (string-prefix-ci? "user." mailbox))
- mailbox
- (string-append "inbox." mailbox)))
- (else mailbox)))
+ (apply imap:command:single-response imap:response:search? connection
+ 'SEARCH key-plist))
+
+(define (imap:command:list connection reference pattern)
+ (imap:command:multiple-response imap:response:list? connection
+ 'LIST reference pattern))
\f
(define (imap:command:no-response connection command . arguments)
(let ((response
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.33 2000/05/20 19:39:20 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.34 2000/05/22 02:17:47 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;; URL
(define-class <rmail-url> (<file-url>))
+(define-url-protocol "rmail" <rmail-url>)
-(let ((filter
- (let ((suffix-filter (file-suffix-filter "rmail")))
- (lambda (pathname)
- (or (string-ci=? (file-namestring pathname) "rmail")
- (suffix-filter string))))))
- (define-url-protocol "rmail" <rmail-url>
- (lambda (string)
- (%make-rmail-url (short-name->pathname string)))
- (file-url-completer filter)
- (file-url-completions filter)))
-
-(define (make-rmail-url pathname)
- (save-url (%make-rmail-url pathname)))
-
-(define %make-rmail-url
+(define make-rmail-url
(let ((constructor (instance-constructor <rmail-url> '(PATHNAME))))
(lambda (pathname)
- (constructor (merge-pathnames pathname)))))
+ (intern-url (constructor (merge-pathnames pathname))))))
+
+(define-method %parse-url-string ((string <string>) (default-url <rmail-url>))
+ (make-rmail-url (merge-pathnames string (file-url-pathname default-url))))
+
+(define-file-url-completers <rmail-url>
+ (let ((type-filter (file-type-filter "rmail")))
+ (lambda (pathname)
+ (or (string-ci=? (file-namestring pathname) "rmail")
+ (type-filter string)))))
;;;; Server operations
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.77 2000/05/19 21:25:31 cph Exp $
+;;; $Id: imail-top.scm,v 1.78 2000/05/22 02:17:50 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
but does not copy any new mail into the folder."
(lambda ()
(list (and (command-argument)
- (prompt-for-string "Run IMAIL on folder" #f
- 'DEFAULT-TYPE 'VISIBLE-DEFAULT
- 'HISTORY 'IMAIL
- 'HISTORY-INDEX 0))))
+ (prompt-for-imail-url-string "Run IMAIL on folder" #f
+ 'DEFAULT-TYPE 'VISIBLE-DEFAULT
+ 'HISTORY 'IMAIL
+ 'HISTORY-INDEX 0))))
(lambda (url-string)
(let ((folder
(open-folder
" on host "
(imap-url-host url))
receiver))
+
+(define (prompt-for-imail-url-string prompt default . options)
+ (apply prompt-for-completed-string
+ prompt
+ default
+ (lambda (string if-unique if-not-unique if-not-found)
+ (url-complete-string string imail-get-default-url
+ if-unique if-not-unique if-not-found))
+ (lambda (string)
+ (url-string-completions string imail-get-default-url))
+ (lambda (string) string #t)
+ options))
\f
(define (imail-default-url)
(let ((primary-folder (ref-variable imail-primary-folder)))
(if primary-folder
(imail-parse-partial-url primary-folder)
- (imail-default-imap-url))))
+ (imail-get-default-url "imap"))))
(define (imail-parse-partial-url string)
- (->url
- (let ((colon (string-find-next-char string #\:)))
- (if colon
- string
- (string-append "imap:" string)))))
-
-(define (imail-default-imap-url)
- (call-with-values
- (lambda ()
- (let ((server (ref-variable imail-default-imap-server)))
- (let ((colon (string-find-next-char server #\:)))
- (if colon
- (values (string-head server colon)
- (or (string->number (string-tail server (+ colon 1)))
- (error "Invalid port specification:" server)))
- (values server 143)))))
- (lambda (host port)
- (make-imap-url (or (ref-variable imail-default-user-id)
- (current-user-name))
- host
- port
- (ref-variable imail-default-imap-mailbox)))))
+ (parse-url-string string imail-get-default-url))
+
+(define (imail-get-default-url protocol)
+ (let ((do-imap
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (let ((server (ref-variable imail-default-imap-server)))
+ (let ((colon (string-find-next-char server #\:)))
+ (if colon
+ (values
+ (string-head server colon)
+ (or (string->number (string-tail server (+ colon 1)))
+ (error "Invalid port specification:" server)))
+ (values server 143)))))
+ (lambda (host port)
+ (make-imap-url (or (ref-variable imail-default-user-id)
+ (current-user-name))
+ host
+ port
+ (ref-variable imail-default-imap-mailbox)))))))
+ (cond ((not protocol)
+ (let ((folder (selected-folder #f)))
+ (if folder
+ (folder-url folder)
+ (do-imap))))
+ ((string-ci=? protocol "imap") (do-imap))
+ ((string-ci=? protocol "rmail") (make-rmail-url "~/RMAIL"))
+ ((string-ci=? protocol "umail") (make-umail-url "~/inbox.mail"))
+ (else (error:bad-range-argument protocol)))))
(define (imail-present-user-alert procedure)
(call-with-output-to-temporary-buffer " *IMAP alert*"
(lambda (flag)
(message-flagged? message flag))))
(string-append "message with flag"
- (if (fix:= 1 (length flags)) "" "s")
+ (if (= 1 (length flags)) "" "s")
" "
- (decorated-string-append "" ", " ""
- flags))
+ (decorated-string-append "" ", " "" flags))
#f))))
(define-command imail-previous-flagged-message
(define-command imail-input
"Append messages to this folder from a specified folder."
- "sInput from folder"
+ (lambda ()
+ (list (prompt-for-imail-url-string "Input from folder" #f
+ 'DEFAULT-TYPE 'INSERTED-DEFAULT
+ 'HISTORY 'IMAIL-INPUT
+ 'HISTORY-INDEX 0)))
(lambda (url-string)
(let ((folder (selected-folder)))
(let ((folder* (open-folder (imail-parse-partial-url url-string)))
(define-command imail-output
"Append this message to a specified folder."
(lambda ()
- (list (prompt-for-string "Output to folder" #f
- 'DEFAULT-TYPE 'INSERTED-DEFAULT
- 'HISTORY 'IMAIL-OUTPUT
- 'HISTORY-INDEX 0)
+ (list (prompt-for-imail-url-string "Output to folder" #f
+ 'DEFAULT-TYPE 'INSERTED-DEFAULT
+ 'HISTORY 'IMAIL-OUTPUT
+ 'HISTORY-INDEX 0)
(command-argument)))
(lambda (url-string argument)
(let ((delete? (ref-variable imail-delete-after-output)))
(define-command imail-create-folder
"Create a new folder with the specified name.
An error if signalled if the folder already exists."
- "sCreate folder"
+ (lambda ()
+ (list (prompt-for-imail-url-string "Create folder" #f
+ 'DEFAULT-TYPE 'INSERTED-DEFAULT
+ 'HISTORY 'IMAIL-CREATE-FOLDER
+ 'HISTORY-INDEX 0)))
(lambda (url-string)
(create-folder (imail-parse-partial-url url-string))))
(define-command imail-delete-folder
"Delete a specified folder."
- "sDelete folder"
+ (lambda ()
+ (list (prompt-for-imail-url-string "Delete folder" #f
+ 'DEFAULT-TYPE 'INSERTED-DEFAULT
+ 'HISTORY 'IMAIL-DELETE-FOLDER
+ 'HISTORY-INDEX 0)))
(lambda (url-string)
(delete-folder (imail-parse-partial-url url-string))))
\f
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.27 2000/05/20 03:22:50 cph Exp $
+;;; $Id: imail-umail.scm,v 1.28 2000/05/22 02:17:55 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;; URL
(define-class <umail-url> (<file-url>))
+(define-url-protocol "umail" <umail-url>)
-(let ((filter (file-suffix-filter "mail")))
- (define-url-protocol "umail" <umail-url>
- (lambda (string)
- (%make-umail-url (short-name->pathname string)))
- (file-url-completer filter)
- (file-url-completions filter)))
-
-(define (make-umail-url pathname)
- (save-url (%make-umail-url pathname)))
-
-(define %make-umail-url
+(define make-umail-url
(let ((constructor (instance-constructor <umail-url> '(PATHNAME))))
(lambda (pathname)
- (constructor (merge-pathnames pathname)))))
+ (intern-url (constructor (merge-pathnames pathname))))))
+
+(define-method %parse-url-string ((string <string>) (default-url <umail-url>))
+ (make-umail-url (merge-pathnames string (file-url-pathname default-url))))
+
+(define-file-url-completers <umail-url>
+ (file-type-filter "mail"))
;;;; Server operations
IMAIL To-Do List
-$Id: todo.txt,v 1.31 2000/05/20 03:23:32 cph Exp $
+$Id: todo.txt,v 1.32 2000/05/22 02:17:58 cph Exp $
Bug fixes
---------
* Repackage the code so that each file now in the core is in a
separate package.
-* Do URL defaulting by merging a partially specified URL with the URL
- of the selected folder.
-
* Reimplement UID synchronization. Take advantage of monotonic UID
numbers to discover largest prefix range that hasn't changed.
Binary search can be used which should produce excellent results on
basically creates the target, opens the source, and copies all of
the messages.
-* Implement URL completion.
-
* Write M-x imail-resend.
* Add an indication showing the connection status in the mode line.
projects / mit-scheme.git / commitdiff