From: Chris Hanson Date: Fri, 25 May 2001 18:16:56 +0000 (+0000) Subject: Cache CONTAINER-URL of every URL when it is created, so that the X-Git-Tag: 20090517-FFI~2783 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b43925a26e528707089cb1d95872016e448194e;p=mit-scheme.git Cache CONTAINER-URL of every URL when it is created, so that the 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). --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index bb9fd68c5..5aa7bcf58 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.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 ;;; @@ -101,7 +101,9 @@ ;;;; URL type -(define-class ()) +(define-class () + (container initial-value 'UNKNOWN)) + (define-class ()) (define-class ()) @@ -130,12 +132,18 @@ ;; 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 )) 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 'CONTAINER)) ;; Like CONTAINER-URL except that the returned container URL is ;; allowed to be different from the true container URL when this @@ -161,7 +169,7 @@ ;; 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)) - + ;; 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 @@ -173,7 +181,7 @@ ;; 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)) - + ;; 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 @@ -194,12 +202,24 @@ ;; 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 '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)) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 75a9795a6..aef38b77f 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.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 ;;; @@ -34,7 +34,8 @@ (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)) @@ -48,7 +49,7 @@ (define pathname-url-constructors (make-eq-hash-table)) -(define-method container-url ((url )) +(define (pathname-container-url url) (make-directory-url (pathname-container (pathname-url-pathname url)))) (define-method container-url-for-prompt ((url )) @@ -104,9 +105,6 @@ (define pathname-url-predicates '()) -(define-method url-is-selectable? ((url )) - (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t)) - (define-method parse-url-body ((string ) (default-url )) (let ((pathname (parse-pathname-url-body string (pathname-url-pathname default-url)))) @@ -178,6 +176,13 @@ (define-method url-exists? ((url )) (file-exists? (pathname-url-pathname url))) +(define-method folder-url-is-selectable? ((url )) + (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t)) + +(define-method url-is-container? ((url )) + url + #f) + (define-method url-base-name ((url )) (pathname-name (pathname-url-pathname url))) @@ -189,7 +194,8 @@ (let ((constructor (instance-constructor '(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 make-directory-url) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index cebc0df76..3b7af5701 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.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 ;;; @@ -44,14 +44,15 @@ (let ((make-folder (instance-constructor fields)) (make-container (instance-constructor 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) @@ -98,11 +99,18 @@ (define-method url-exists? ((url )) (and (imap-url-info url) #t)) -(define-method url-is-selectable? ((url )) +(define-method folder-url-is-selectable? ((url )) (let ((response (imap-url-info url))) (and response (not (memq '\NOSELECT (imap:response:list-flags response)))))) +(define-method url-is-container? ((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 @@ -159,7 +167,7 @@ ;;;; Container heirarchy -(define-method container-url ((url )) +(define (imap-container-url url) (imap-url-new-mailbox url (or (imap-url-container-mailbox url) ""))) @@ -274,26 +282,28 @@ (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) + "%")))))) ;;;; URL->server delimiter conversion diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 271cec45c..2dd5ddaec 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.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 ;;; @@ -1660,7 +1660,7 @@ Negative argument means search in reverse." (%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