heirarchy can be quickly traversed.
Rename URL-IS-SELECTABLE? as FOLDER-URL-IS-SELECTABLE?.
Implement new operation URL-IS-CONTAINER? which returns the
equivalent container URL of a URL (which may be a folder URL).
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.137 2001/05/25 02:45:29 cph Exp $
+;;; $Id: imail-core.scm,v 1.138 2001/05/25 18:16:48 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
\f
;;;; URL type
-(define-class <url> (<property-mixin>))
+(define-class <url> (<property-mixin>)
+ (container initial-value 'UNKNOWN))
+
(define-class <folder-url> (<url>))
(define-class <container-url> (<url>))
;; Return #T iff URL represents an existing folder.
(define-generic url-exists? (url))
-;; Return #T iff URL both exists and can be opened.
-(define-generic url-is-selectable? (folder-url))
+;; Return #T iff FOLDER-URL both exists and can be opened.
+(define-generic folder-url-is-selectable? (folder-url))
+
+;; If URL both exists and can contain other resources, return a
+;; container URL for the same resource. Otherwise return #F.
+(define-generic url-is-container? (url))
+(define-method url-is-container? ((url <container-url>)) url)
;; Return a locator for the container of URL. E.g. the container URL
;; of "imap://localhost/inbox/foo" is "imap://localhost/inbox/".
(define-generic container-url (url))
+(add-method container-url (slot-accessor-method <url> 'CONTAINER))
;; Like CONTAINER-URL except that the returned container URL is
;; allowed to be different from the true container URL when this
;; Return a URL that refers to the content NAME of the container
;; referred to by CONTAINER-URL.
(define-generic make-content-url (container-url name))
-
+\f
;; Return the base name of FOLDER-URL. This is the content name of
;; FOLDER-URL, but presented in a type-independent way. For example,
;; if the content name of a file URL is "foo.mail", the base name is
;; mailbox information. This string will be included in the
;; pass-phrase prompt, and also used as a key for memoization.
(define-generic url-pass-phrase-key (url))
-\f
+
;; 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
;; STRING must cause an error to be signalled.
(define-generic parse-url-body (string default-url))
-(define (intern-url url)
- (let ((string (url->string url)))
- (or (hash-table/get interned-urls string #f)
- (begin
- (hash-table/put! interned-urls string url)
- url))))
+(define intern-url
+ (let ((modifier (slot-modifier <url> 'CONTAINER)))
+ (lambda (url compute-container)
+ (let ((string (url->string url)))
+ (or (hash-table/get interned-urls string #f)
+ (begin
+ (let ((finished? #f))
+ (dynamic-wind
+ (lambda ()
+ (hash-table/put! interned-urls string url))
+ (lambda ()
+ (modifier url (compute-container url))
+ (set! finished? #t)
+ unspecific)
+ (lambda ()
+ (if (not finished?)
+ (hash-table/remove! interned-urls string)))))
+ url))))))
(define interned-urls
(make-string-hash-table))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.73 2001/05/25 02:45:33 cph Exp $
+;;; $Id: imail-file.scm,v 1.74 2001/05/25 18:16:51 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(let ((procedure
(let ((constructor (instance-constructor class '(PATHNAME))))
(lambda (pathname)
- (intern-url (constructor (merge-pathnames pathname)))))))
+ (intern-url (constructor (merge-pathnames pathname))
+ pathname-container-url)))))
(register-pathname-url-constructor class procedure)
procedure))
(define pathname-url-constructors
(make-eq-hash-table))
-(define-method container-url ((url <pathname-url>))
+(define (pathname-container-url url)
(make-directory-url (pathname-container (pathname-url-pathname url))))
(define-method container-url-for-prompt ((url <pathname-url>))
(define pathname-url-predicates '())
\f
-(define-method url-is-selectable? ((url <pathname-url>))
- (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t))
-
(define-method parse-url-body ((string <string>) (default-url <pathname-url>))
(let ((pathname
(parse-pathname-url-body string (pathname-url-pathname default-url))))
(define-method url-exists? ((url <file-url>))
(file-exists? (pathname-url-pathname url)))
+(define-method folder-url-is-selectable? ((url <file-url>))
+ (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t))
+
+(define-method url-is-container? ((url <file-url>))
+ url
+ #f)
+
(define-method url-base-name ((url <file-url>))
(pathname-name (pathname-url-pathname url)))
(let ((constructor (instance-constructor <directory-url> '(PATHNAME))))
(lambda (pathname)
(intern-url
- (constructor (pathname-as-directory (merge-pathnames pathname)))))))
+ (constructor (pathname-as-directory (merge-pathnames pathname)))
+ pathname-container-url))))
(register-pathname-url-constructor <directory-url> make-directory-url)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-imap.scm,v 1.163 2001/05/25 02:45:41 cph Exp $
+;;; $Id: imail-imap.scm,v 1.164 2001/05/25 18:16:53 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(let ((make-folder (instance-constructor <imap-folder-url> fields))
(make-container (instance-constructor <imap-container-url> fields)))
(lambda (user-id host port mailbox)
- (intern-url
- ((if (or (string-null? mailbox) (string-suffix? "/" mailbox))
- make-container
- make-folder)
- user-id
- (string-downcase host)
- port
- (canonicalize-imap-mailbox mailbox)))))))
+ (intern-url ((if (or (string-null? mailbox)
+ (string-suffix? "/" mailbox))
+ make-container
+ make-folder)
+ user-id
+ (string-downcase host)
+ port
+ (canonicalize-imap-mailbox mailbox))
+ imap-container-url)))))
(define (imap-url-new-mailbox url mailbox)
(make-imap-url (imap-url-user-id url)
(define-method url-exists? ((url <imap-url>))
(and (imap-url-info url) #t))
-(define-method url-is-selectable? ((url <imap-folder-url>))
+(define-method folder-url-is-selectable? ((url <imap-folder-url>))
(let ((response (imap-url-info url)))
(and response
(not (memq '\NOSELECT (imap:response:list-flags response))))))
+(define-method url-is-container? ((url <imap-folder-url>))
+ (let ((response (imap-url-info url)))
+ (and response
+ (not (memq '\NOINFERIORS (imap:response:list-flags response)))
+ (imap-url-new-mailbox url
+ (string-append (imap-url-mailbox url) "/")))))
+
(define (imap-url-info url)
(let ((responses
(with-open-imap-connection url
\f
;;;; Container heirarchy
-(define-method container-url ((url <imap-url>))
+(define (imap-container-url url)
(imap-url-new-mailbox url
(or (imap-url-container-mailbox url)
"")))
(define (imap-mailbox-completions prefix url)
(with-open-imap-connection url
(lambda (connection)
- (map (lambda (response)
- (let ((flags (imap:response:list-flags response))
- (delimiter (imap:response:list-delimiter response))
- (mailbox
- (imap:decode-mailbox-name
- (imap:response:list-mailbox response))))
- (if delimiter
- (let ((mailbox
- (string-replace mailbox
- (string-ref delimiter 0)
- #\/)))
- (if (and (memq '\NOSELECT flags)
- (not (memq '\NOINFERIORS flags)))
- (string-append mailbox "/")
- mailbox))
- mailbox)))
- (imap:command:list
- connection
- ""
- (string-append (imap-mailbox/url->server url prefix) "%"))))))
+ (append-map! (lambda (response)
+ (let ((flags (imap:response:list-flags response))
+ (delimiter (imap:response:list-delimiter response))
+ (mailbox
+ (imap:decode-mailbox-name
+ (imap:response:list-mailbox response))))
+ (if delimiter
+ (let ((mailbox
+ (string-replace mailbox
+ (string-ref delimiter 0)
+ #\/)))
+ (if (memq '\NOSELECT flags)
+ (if (memq '\NOINFERIORS flags)
+ '()
+ (list (string-append mailbox "/")))
+ (list mailbox)))
+ (list mailbox))))
+ (imap:command:list
+ connection
+ ""
+ (string-append (imap-mailbox/url->server url prefix)
+ "%"))))))
\f
;;;; URL->server delimiter conversion
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.251 2001/05/25 02:45:51 cph Exp $
+;;; $Id: imail-top.scm,v 1.252 2001/05/25 18:16:56 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(%prompt-for-url prompt default options
(lambda (url)
(and (folder-url? url)
- (url-is-selectable? url)))))
+ (folder-url-is-selectable? url)))))
(define (prompt-for-container prompt default . options)
(%prompt-for-url prompt default options
projects / mit-scheme.git / commitdiff