From: Chris Hanson Date: Tue, 15 May 2001 19:47:02 +0000 (+0000) Subject: New operation CONTAINER-URL-CONTENTS. X-Git-Tag: 20090517-FFI~2822 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d88ce6fd5c9904d8825db9a819a1f7cfe378c02a;p=mit-scheme.git New operation CONTAINER-URL-CONTENTS. Reimplemented URL-IS-SELECTABLE? for file folders. New implementation probes the file to determine if it is a known type. File-folder completion now only considers files of known type and directories. It also doesn't consider "." and ".." directories. Code that mapped IMAP heirarchy delimiters was broken, although this caused no practical consequences. It has been reimplemented to make it both correct and simpler. IMAP-folder completion used to probe subfolders of a folder to determine if a folder should have a "/" at the end. This was wasteful of network bandwidth and had no practical consequences, so it has been changed to not do this. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 08a24afa5..e0008c45e 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.121 2001/05/13 03:45:48 cph Exp $ +;;; $Id: imail-core.scm,v 1.122 2001/05/15 19:46:48 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -78,6 +78,11 @@ ;; may be affected by the NAMESPACE prefix information). (define-generic url-container (url)) +;; Return a list of URLs referring to the contents of CONTAINER-URL. +;; The result can contain both folder and container URLs. +;; The result is not sorted. +(define-generic container-url-contents (container-url)) + ;; Return the base name of FOLDER-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. diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 6261478b4..0563887ee 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.64 2001/05/13 03:45:52 cph Exp $ +;;; $Id: imail-file.scm,v 1.65 2001/05/15 19:46:51 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -48,61 +48,71 @@ (define pathname-url-constructors (make-eq-hash-table)) -(define-method url-body ((url )) - (pathname->url-body (pathname-url-pathname url))) - -(define (pathname->url-body pathname) - (string-append (let ((device (pathname-device pathname))) - (if (string? device) - (string-append "/" device ":") - "")) - (let ((directory (pathname-directory pathname))) - (if (pair? directory) - (string-append - (if (eq? (car directory) 'ABSOLUTE) "/" "") - (decorated-string-append - "" "" "/" - (map (lambda (string) - (url:encode-string - (if (eq? string 'UP) ".." string))) - (cdr directory)))) - "")) - (url:encode-string (file-namestring pathname)))) - (define-method url-container ((url )) (make-directory-url (directory-pathname (directory-pathname-as-file (pathname-url-pathname url))))) - -(define (define-pathname-url-predicate class predicate) + +(define (define-pathname-url-predicates class + file-predicate + directory-predicate + pathname-predicate) (let ((constructor (get-pathname-url-constructor class))) (let loop ((entries pathname-url-predicates)) (if (pair? entries) (if (eq? class (vector-ref (car entries) 0)) (begin - (vector-set! (car entries) 1 predicate) - (vector-set! (car entries) 2 constructor)) + (vector-set! (car entries) 1 file-predicate) + (vector-set! (car entries) 2 directory-predicate) + (vector-set! (car entries) 3 pathname-predicate) + (vector-set! (car entries) 4 constructor)) (loop (cdr entries))) (begin (set! pathname-url-predicates - (cons (vector class predicate constructor) + (cons (vector class + file-predicate + directory-predicate + pathname-predicate + constructor) pathname-url-predicates)) unspecific))))) +(define (find-pathname-url-constructor pathname must-exist? if-not-found) + (let ((type (file-type-indirect pathname)) + (search + (lambda (index) + (let loop ((entries pathname-url-predicates)) + (and (pair? entries) + (if ((vector-ref (car entries) index) pathname) + (vector-ref (car entries) 4) + (loop (cdr entries)))))))) + (or (case type + ((REGULAR) (search 1)) + ((DIRECTORY) (search 2)) + ((#F) (and (not must-exist?) (search 3))) + (else #f)) + (and if-not-found + (if-not-found pathname type))))) + (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)))) - ((let loop ((entries pathname-url-predicates)) - (if (pair? entries) - (if ((vector-ref (car entries) 1) pathname) - (vector-ref (car entries) 2) - (loop (cdr entries))) - (if (or (directory-pathname? pathname) - (file-directory? pathname)) - make-directory-url - make-file-url))) + ((find-pathname-url-constructor pathname #f + (lambda (pathname type) + (case type + ((REGULAR) make-file-url) + ((DIRECTORY) make-directory-url) + ((#F) + (if (directory-pathname? pathname) + make-directory-url + make-file-url)) + (else + (error "Pathname refers to illegal file type:" pathname))))) pathname))) (define (parse-pathname-url-body string default-pathname) @@ -127,6 +137,27 @@ (error:bad-range-argument string 'PARSE-PATHNAME-URL-BODY)) (else (finish string))))) + +(define-method url-body ((url )) + (pathname->url-body (pathname-url-pathname url))) + +(define (pathname->url-body pathname) + (string-append (let ((device (pathname-device pathname))) + (if (string? device) + (string-append "/" device ":") + "")) + (let ((directory (pathname-directory pathname))) + (if (pair? directory) + (string-append + (if (eq? (car directory) 'ABSOLUTE) "/" "") + (decorated-string-append + "" "" "/" + (map (lambda (string) + (url:encode-string + (if (eq? string 'UP) ".." string))) + (cdr directory)))) + "")) + (url:encode-string (file-namestring pathname)))) ;;;; File folders @@ -136,9 +167,6 @@ (define-method url-exists? ((url )) (file-exists? (pathname-url-pathname url))) -(define-method url-is-selectable? ((url )) - (file-regular? (pathname-url-pathname url))) - (define-method url-presentation-name ((url )) (file-namestring (pathname-url-pathname url))) @@ -169,6 +197,18 @@ ;;;; Server operations +(define-method container-url-contents ((url )) + (simple-directory-read (pathname-url-pathname url) + (lambda (name directory result) + (if (or (string=? name ".") (string=? name "..")) + result + (let* ((pathname + (parse-namestring (string-append directory name) #f #f)) + (constructor (pathname-url-filter pathname))) + (if constructor + (cons (constructor pathname) result) + result)))))) + (define-method %url-complete-string ((string ) (default-url ) if-unique if-not-unique if-not-found) @@ -176,7 +216,7 @@ (parse-pathname-url-body string (directory-pathname (pathname-url-pathname default-url))) - (lambda (pathname) pathname #t) + pathname-url-filter (lambda (string) (if-unique (pathname->url-body string))) (lambda (prefix get-completions) @@ -191,7 +231,14 @@ (parse-pathname-url-body string (directory-pathname (pathname-url-pathname default-url))) - (lambda (pathname) pathname #t)))) + pathname-url-filter))) + +(define (pathname-url-filter pathname) + (find-pathname-url-constructor pathname #t + (lambda (pathname type) + pathname + (and (eq? type 'DIRECTORY) + make-directory-url)))) (define-method %delete-folder ((url )) (delete-file (pathname-url-pathname url))) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index cc73b632f..18adf20e2 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.150 2001/05/13 03:46:01 cph Exp $ +;;; $Id: imail-imap.scm,v 1.151 2001/05/15 19:46:54 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -122,55 +122,11 @@ mailbox)) (define-method make-peer-url ((url ) base-name) - (imap-url-new-mailbox - url - (string-append (imap-mailbox-container-string url (imap-url-mailbox url)) - base-name))) + (let ((url (url-container url))) + (imap-url-new-mailbox + url + (string-append (imap-url-mailbox url) "/" base-name)))) -(define-method url-container ((url )) - (imap-url-new-mailbox - url - (let ((mailbox (imap-mailbox-container-string url (imap-url-mailbox url)))) - (if (string-suffix? "/" mailbox) - (string-head mailbox (fix:- (string-length mailbox) 1)) - mailbox)))) - -(define (imap-mailbox-container-string url mailbox) - (let ((index (string-search-backward "/" mailbox))) - (if index - (string-head mailbox index) - (or (let ((response - (let ((connection - (search-imap-connections - (lambda (connection) - (and (compatible-imap-urls? - (imap-connection-url connection) - url) - (not - (eq? (imap-connection-delimiter connection) - 'UNKNOWN))))))) - (and connection - (imap-connection-namespace connection))))) - (and response - (let ((namespace - (imap:response:namespace-personal response))) - (and (pair? namespace) - (car namespace) - (let ((prefix - (imap:decode-mailbox-name (caar namespace))) - (delimiter (cadar namespace))) - (cond ((not delimiter) - prefix) - ((and (fix:= (string-length prefix) 6) - (string-prefix-ci? "inbox" prefix) - (string-suffix? delimiter prefix)) - "inbox/") - (else - (string-replace prefix - (string-ref delimiter 0) - #\/)))))))) - "")))) - (define-method parse-url-body (string (default-url )) (call-with-values (lambda () (parse-imap-url-body string default-url)) (lambda (user-id host port mailbox) @@ -204,6 +160,70 @@ (imap-url-mailbox default-url))) (values #f #f #f #f)))))) +(define-method url-container ((url )) + (imap-url-new-mailbox + url + (let ((mailbox (imap-url-mailbox url))) + (let ((index (string-find-previous-char mailbox #\/))) + (if index + (string-head mailbox index) + (or (get-personal-namespace url) "")))))) + +(define (get-personal-namespace url) + (let ((response + (let ((connection + (search-imap-connections + (lambda (connection) + (and (compatible-imap-urls? (imap-connection-url connection) + url) + (not (eq? (imap-connection-namespace connection) + 'UNKNOWN))))))) + (and connection + (imap-connection-namespace connection))))) + (and response + (let ((namespace (imap:response:namespace-personal response))) + (and (pair? namespace) + (car namespace) + (let ((prefix (imap:decode-mailbox-name (caar namespace))) + (delimiter (cadar namespace))) + (if delimiter + (let ((base + (if (string-suffix? delimiter prefix) + (string-head prefix + (fix:- (string-length prefix) 1)) + prefix))) + (if (string-ci=? "inbox" base) + "inbox" + (string-replace base + (string-ref delimiter 0) + #\/))) + prefix))))))) + +(define-method container-url-contents ((url )) + (with-open-imap-connection url + (lambda (connection) + (map (lambda (response) + (imap-url-new-mailbox + url + (let ((delimiter (imap:response:list-delimiter response)) + (mailbox + (imap:decode-mailbox-name + (imap:response:list-mailbox response)))) + (if delimiter + (string-replace mailbox (string-ref delimiter 0) #\/) + mailbox)))) + (imap:command:list connection + "" + (string-append + (imap-mailbox/url->server + url + (let ((mailbox (imap-url-mailbox url))) + (if (or (string-null? mailbox) + (string-suffix? "/" mailbox)) + mailbox + (string-append mailbox "/")))) + "%")))))) + (define-method %url-complete-string ((string ) (default-url ) if-unique if-not-unique if-not-found) @@ -254,36 +274,27 @@ (define (imap-mailbox-completions prefix url) (with-open-imap-connection url (lambda (connection) - (let ((get-list - (lambda (prefix) - (imap:command:list connection "" (string-append 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)))) - (let ((mailbox* - (if delimiter - (string-replace mailbox (string-ref delimiter 0) #\/) - mailbox))) - (let ((tail - (if (and delimiter - (or (memq '\NOSELECT flags) - (and (not (memq '\NOINFERIORS flags)) - (pair? - (get-list - (string-append mailbox - delimiter)))))) - (list (string-append mailbox* "/")) - '()))) - (if (memq '\NOSELECT flags) - tail - (cons mailbox* tail)))))) - (get-list (imap-mailbox/url->server url prefix))))))) + (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)))) + (let ((mailbox + (if delimiter + (string-replace mailbox (string-ref delimiter 0) #\/) + mailbox))) + (if (and delimiter + (memq '\NOSELECT flags) + (not (memq '\NOINFERIORS flags))) + (string-append mailbox "/") + mailbox)))) + (imap:command:list + connection + "" + (string-append (imap-mailbox/url->server url prefix) "%")))))) -;;;; URL/server delimiter conversion +;;;; URL->server delimiter conversion (define (imap-url-server-mailbox url) (imap-mailbox/url->server url (imap-url-mailbox url))) @@ -294,46 +305,29 @@ (string-replace mailbox #\/ delimiter) mailbox))) -(define (imap-mailbox/server->url url mailbox) - (let ((delimiter (imap-mailbox-delimiter url mailbox))) - (if (and delimiter (not (char=? delimiter #\/))) - (string-replace mailbox delimiter #\/) - mailbox))) - (define (imap-mailbox-delimiter url mailbox) - (or (let ((entry (find-imap-namespace-entry url mailbox))) - (and entry - (cadr entry))) - (let ((delimiter (imap-url-delimiter url))) - (and delimiter - (string-ref delimiter 0))))) - -(define (find-imap-namespace-entry url mailbox) - (let ((response (imap-url-namespace url))) - (and response - (let ((try - (lambda (namespace) - (let loop ((entries namespace)) - (and (pair? entries) - (or (let ((prefix - (imap:decode-mailbox-name (caar entries))) - (delimiter (cadar entries))) - (if (and delimiter - (fix:= (string-length prefix) 6) - (string-prefix-ci? "inbox" prefix) - (string-suffix? delimiter prefix)) - (and (string-prefix-ci? prefix mailbox) - (list (string-append "inbox" delimiter) - (string-ref delimiter 0))) - (and (string-prefix? prefix mailbox) - (list prefix - (and delimiter - (string-ref delimiter - 0)))))) - (loop (cdr entries)))))))) - (or (try (imap:response:namespace-personal response)) - (try (imap:response:namespace-shared response)) - (try (imap:response:namespace-other response))))))) + (let* ((slash (string-find-next-char mailbox #\/)) + (root + (if slash + (string-head mailbox (fix:+ slash 1)) + mailbox)) + (key (imap-url-new-mailbox url (if slash root "")))) + (let ((delimiter (hash-table/get imap-delimiters-table key 'UNKNOWN))) + (if (eq? delimiter 'UNKNOWN) + (let ((delimiter + (imap:response:list-delimiter + (with-open-imap-connection url + (lambda (connection) + (imap:command:get-delimiter connection root)))))) + (let ((delimiter + (and delimiter + (string-ref delimiter 0)))) + (hash-table/put! imap-delimiters-table key delimiter) + delimiter)) + delimiter)))) + +(define imap-delimiters-table + (make-equal-hash-table)) ;;;; Server connection @@ -342,8 +336,7 @@ (port define standard initial-value #f) (greeting define standard initial-value #f) (capabilities define standard initial-value '()) - (delimiter define standard initial-value 'UNKNOWN) - (namespace define standard initial-value #f) + (namespace define standard initial-value 'UNKNOWN) (sequence-number define standard initial-value 0) (response-queue define accessor initializer (lambda () (cons '() '()))) (folder define standard initial-value #f) @@ -526,16 +519,11 @@ (imail-ui:delete-stored-pass-phrase url) (error "Unable to log in:" (imap:response:response-text-string response)))))) - (if (eq? (imap-connection-delimiter connection) 'UNKNOWN) - (begin - (set-imap-connection-delimiter! - connection - (imap:response:list-delimiter - (car (imap:command:list connection "" "inbox")))) - (if (memq 'NAMESPACE (imap-connection-capabilities connection)) - (set-imap-connection-namespace! - connection - (imap:command:namespace connection))))) + (if (eq? (imap-connection-namespace connection) 'UNKNOWN) + (set-imap-connection-namespace! + connection + (and (memq 'NAMESPACE (imap-connection-capabilities connection)) + (imap:command:namespace connection)))) #t))) (define (close-imap-connection connection) @@ -572,19 +560,6 @@ (if (imap-connection-port connection) (imap:command:logout connection)) (close-imap-connection connection)))) - -(define (imap-url-delimiter url) - (let ((connection (get-imap-connection url))) - (let ((delimiter (imap-connection-delimiter connection))) - (if (eq? delimiter 'UNKNOWN) - (with-open-imap-connection url imap-connection-delimiter) - delimiter)))) - -(define (imap-url-namespace url) - (let ((connection (get-imap-connection url))) - (if (eq? (imap-connection-delimiter connection) 'UNKNOWN) - (with-open-imap-connection url imap-connection-namespace) - (imap-connection-namespace connection)))) ;;;; Folder datatype @@ -1470,8 +1445,14 @@ 'SEARCH key-plist)) (define (imap:command:list connection reference pattern) - (imap:command:multiple-response imap:response:list? connection - 'LIST reference pattern)) + (imap:command:multiple-response imap:response:list? connection 'LIST + (imap:encode-mailbox-name reference) + (imap:encode-mailbox-name pattern))) + +(define (imap:command:get-delimiter connection reference) + (imap:command:single-response imap:response:list? connection 'LIST + (imap:encode-mailbox-name reference) + (imap:encode-mailbox-name ""))) (define (imap:command:no-response connection command . arguments) (let ((responses (apply imap:command connection command arguments))) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 9288c5cf5..b4d0eff69 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.62 2001/05/13 03:46:04 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.63 2001/05/15 19:46:57 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -28,23 +28,13 @@ (define-class ()) (define make-rmail-url (pathname-url-constructor )) -(define-pathname-url-predicate +(define-pathname-url-predicates + (lambda (pathname) (check-file-prefix pathname "BABYL OPTIONS:")) + (lambda (pathname) pathname #f) (lambda (pathname) - (case (file-type-indirect pathname) - ((REGULAR) - (let* ((magic "BABYL OPTIONS:") - (n-to-read (string-length magic)) - (buffer (make-string n-to-read)) - (n-read - (call-with-input-file pathname - (lambda (port) - (read-string! buffer port))))) - (and (fix:= n-to-read n-read) - (string=? buffer magic)))) - ((#F) - (or (string=? (pathname-type pathname) "rmail") - (string=? (file-namestring pathname) "RMAIL"))) - (else #f)))) + (or (equal? (pathname-type pathname) "rmail") + (and (equal? (pathname-name pathname) "RMAIL") + (not (pathname-type pathname)))))) (define-method make-peer-url ((url ) name) (make-rmail-url diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 4e9d24ee4..df53735aa 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.43 2001/05/13 03:46:17 cph Exp $ +;;; $Id: imail-umail.scm,v 1.44 2001/05/15 19:46:59 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -28,21 +28,10 @@ (define-class ()) (define make-umail-url (pathname-url-constructor )) -(define-pathname-url-predicate - (lambda (pathname) - (case (file-type-indirect pathname) - ((REGULAR) - (let* ((magic "From ") - (n-to-read (string-length magic)) - (buffer (make-string n-to-read)) - (n-read - (call-with-input-file pathname - (lambda (port) - (read-string! buffer port))))) - (and (fix:= n-to-read n-read) - (string=? buffer magic)))) - ((#F) (string=? (pathname-type pathname) "mail")) - (else #f)))) +(define-pathname-url-predicates + (lambda (pathname) (check-file-prefix pathname "From ")) + (lambda (pathname) pathname #f) + (lambda (pathname) (equal? (pathname-type pathname) "mail"))) (define-method make-peer-url ((url ) name) (make-umail-url diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index b6de90b27..9321feb13 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-util.scm,v 1.37 2001/05/14 19:27:54 cph Exp $ +;;; $Id: imail-util.scm,v 1.38 2001/05/15 19:47:02 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -176,6 +176,19 @@ (if (default-object? line-ending) "\n" line-ending) lines)) +(define (check-file-prefix pathname magic) + (let* ((n-to-read (string-length magic)) + (buffer (make-string n-to-read)) + (n-read + (catch-file-errors (lambda (condition) condition #f) + (lambda () + (call-with-input-file pathname + (lambda (port) + (read-string! buffer port))))))) + (and n-read + (fix:= n-to-read n-read) + (string=? buffer magic)))) + (define (read-required-char port) (let ((char (read-char port))) (if (eof-object? char) @@ -376,11 +389,13 @@ result)))))) (define ((result-filter filter) name directory result) - (let ((pathname (parse-namestring (string-append directory name) #f #f))) - (cond ((safe-file-directory? pathname) - (cons (pathname-as-directory pathname) result)) - ((filter pathname) (cons pathname result)) - (else result)))) + (if (or (string=? name ".") (string=? name "..")) + result + (let ((pathname (parse-namestring (string-append directory name) #f #f))) + (cond ((safe-file-directory? pathname) + (cons (pathname-as-directory pathname) result)) + ((filter pathname) (cons pathname result)) + (else result))))) (define (safe-file-directory? pathname) (catch-file-errors (lambda (condition) condition #f)