From 87fe7f31c9144c054b4a8409330fe3681c568643 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 24 May 2001 17:46:51 +0000 Subject: [PATCH] Simplify meaning of CONTAINER-URL; it no longer does anything special for IMAP URLs. Define new operation CONTAINER-URL-FOR-PROMPT that has the behavior that CONTAINER-URL used to. Implement new operation URL-CHILD-NAME which is now the complement to CONTAINER-URL. These operations now return compatible halves of the URL, which may be recombined using MAKE-CHILD-URL to obtain the original URL. Change implementation of URL-PRESENTATION-NAME; it now just calls URL-CHILD-NAME, stripping a slash off the end if present. Clarify definition of URL-BASE-NAME. Revert CONTAINER-CONTENTS back to CONTAINER-URL-CONTENTS. Maybe tomorrow I'll change my mind again. --- v7/src/imail/imail-core.scm | 69 +++++++++++++++++++++----------- v7/src/imail/imail-file.scm | 54 +++++++++++++------------ v7/src/imail/imail-imap.scm | 78 ++++++++++++++++++------------------- v7/src/imail/imail-top.scm | 13 ++++--- 4 files changed, 119 insertions(+), 95 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index b981f13b4..e0603ca7d 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.134 2001/05/24 03:41:28 cph Exp $ +;;; $Id: imail-core.scm,v 1.135 2001/05/24 17:46:42 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -133,24 +133,40 @@ ;; Return #T iff URL both exists and can be opened. (define-generic url-is-selectable? (folder-url)) -;; Return a reference to the container of URL. -;; E.g. the container of "imap://localhost/inbox/foo" is -;; "imap://localhost/inbox/" (except that for IMAP folders, the result -;; may be affected by the NAMESPACE prefix information). +;; 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)) -;; 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. -(define-generic url-base-name (folder-url)) - -;; Return a URL that refers to the child NAME of the container +;; Like CONTAINER-URL except that the returned container URL is +;; allowed to be different from the true container URL when this +;; results in a better prompt. +;; +;; For example, when URL is "imap://localhost/inbox" and the IMAP +;; server is Cyrus, this will return "imap://localhost/inbox/". +(define-generic container-url-for-prompt (url)) + +;; Return the child name of a URL. The child name of a URL is the +;; suffix of the URL that uniquely identifies the resource with +;; respect to its container. +;; +;; Here are some examples: +;; +;; URL child name +;; --------------------------- ---------- +;; imap://localhost/inbox/foo foo +;; imap://localhost/inbox/foo/ foo/ +;; file:/usr/home/cph/foo.mail foo.mail +(define-generic url-child-name (url)) + +;; Return a URL that refers to the child CHILD-NAME of the container ;; referred to by CONTAINER-URL. -(define-generic make-child-url (container-url name)) +(define-generic make-child-url (container-url child-name)) -;; Return a string that concisely identifies URL, for use in the -;; presentation layer. -(define-generic url-presentation-name (url)) +;; Return the base name of FOLDER-URL. This is the child name of +;; FOLDER-URL, but presented in a type-independent way. For example, +;; if the child name of a file URL is "foo.mail", the base name is +;; just "foo". +(define-generic url-base-name (folder-url)) ;; Return a string that uniquely identifies the server and account for ;; URL. E.g. for IMAP this could be the URL string without the @@ -197,6 +213,12 @@ (define url-protocols (make-string-hash-table)) + +(define (url-presentation-name url) + (let ((child-name (url-child-name url))) + (if (string-suffix? "/" child-name) + (string-head child-name (fix:- (string-length child-name) 1)) + child-name))) ;; Do completion on URL-STRING, which is a partially-specified URL. ;; Tail-recursively calls one of the three procedure arguments, as @@ -314,6 +336,13 @@ (let ((container (get-memoized-resource (container-url url)))) (if container (apply object-modified! container type url arguments)))) + +;; ------------------------------------------------------------------- +;; 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)) ;;;; Resources @@ -338,6 +367,9 @@ (define-method container-url ((resource )) (container-url (resource-locator resource))) +(define-method container-url-for-prompt ((resource )) + (container-url-for-prompt (resource-locator resource))) + (define-class ()) (define-class ()) @@ -500,13 +532,6 @@ ;; enhancement. (define-generic preload-folder-outlines (folder)) - -;; ------------------------------------------------------------------- -;; Return a list of URLs referring to the contents of CONTAINER. -;; The result can contain both folder and container URLs. -;; The result is not sorted. - -(define-generic container-contents (container)) ;;;; Message type diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 0dde1e8eb..70ae63e8a 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.71 2001/05/24 01:13:44 cph Exp $ +;;; $Id: imail-file.scm,v 1.72 2001/05/24 17:46:45 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -49,9 +49,17 @@ (make-eq-hash-table)) (define-method container-url ((url )) - (make-directory-url - (directory-pathname - (directory-pathname-as-file (pathname-url-pathname url))))) + (make-directory-url (pathname-container (pathname-url-pathname url)))) + +(define-method container-url-for-prompt ((url )) + (make-directory-url (pathname-container (pathname-url-pathname url)))) + +(define-method url-child-name ((url )) + (let ((pathname (pathname-url-pathname url))) + (enough-namestring pathname (pathname-container pathname)))) + +(define (pathname-container pathname) + (directory-pathname (directory-pathname-as-file pathname))) (define (define-pathname-url-predicates class file-predicate @@ -162,7 +170,7 @@ "")) (url:encode-string (file-namestring pathname)))) -;;;; File folders +;;;; File URLs (define-class ( )) (define make-file-url (pathname-url-constructor )) @@ -170,13 +178,10 @@ (define-method url-exists? ((url )) (file-exists? (pathname-url-pathname url))) -(define-method url-presentation-name ((url )) - (file-namestring (pathname-url-pathname url))) - (define-method url-base-name ((url )) (pathname-name (pathname-url-pathname url))) -;;;; File containers +;;;; Directory URLs (define-class ( )) @@ -191,16 +196,21 @@ (define-method url-exists? ((url )) (file-directory? (pathname-url-pathname url))) -(define-method url-presentation-name ((url )) - (let ((pathname (pathname-url-pathname url))) - (let ((directory (pathname-directory pathname))) - (if (pair? (cdr directory)) - (car (last-pair directory)) - (->namestring pathname))))) - (define-method make-child-url ((url ) name) (let ((pathname (merge-pathnames name (pathname-url-pathname url)))) ((standard-pathname-url-constructor pathname) pathname))) + +(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)))))) ;;;; Server operations @@ -482,18 +492,6 @@ (define-method save-resource ((container )) container #f) - -(define-method container-contents ((container )) - (simple-directory-read (pathname-url-pathname (resource-locator container)) - (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)))))) ;;;; Message diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 6da35502b..b81b7b9fc 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.159 2001/05/24 01:13:53 cph Exp $ +;;; $Id: imail-imap.scm,v 1.160 2001/05/24 17:46:47 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -114,32 +114,15 @@ (null? (cdr responses)) (car responses)))) -(define-method url-presentation-name ((url )) - (let* ((mailbox (imap-url-mailbox url)) - (end - (let ((n (string-length mailbox))) - (if (string-suffix? "/" mailbox) - (fix:- n 1) - n)))) - (substring mailbox - (let ((index (substring-find-previous-char mailbox 0 end #\/))) - (if index - (fix:+ index 1) - 0)) - end))) - -(define-method url-pass-phrase-key ((url )) - (make-url-string (url-protocol url) (make-imap-url-string url #f))) - (define-method url-base-name ((url )) (let ((mailbox (imap-url-mailbox url))) - (let ((index (string-find-previous-char mailbox #\/))) + (let ((index (imap-mailbox-container-slash mailbox))) (if index (string-tail mailbox (fix:+ index 1)) mailbox)))) -(define-method make-child-url ((url ) base-name) - (imap-url-new-mailbox url (string-append (imap-url-mailbox url) base-name))) +(define-method url-pass-phrase-key ((url )) + (make-url-string (url-protocol url) (make-imap-url-string url #f))) (define-method parse-url-body (string (default-url )) (call-with-values (lambda () (parse-imap-url-body string default-url)) @@ -177,20 +160,40 @@ ;;;; Container heirarchy (define-method container-url ((url )) - (imap-url-new-mailbox - url - (let ((mailbox (imap-url-mailbox url))) - (let ((index - (substring-find-previous-char mailbox - 0 - (let ((n (string-length mailbox))) - (if (string-suffix? "/" mailbox) - (fix:- n 1) - n)) - #\/))) - (if index - (string-head mailbox (fix:+ index 1)) - (or (get-personal-namespace url) "")))))) + (imap-url-new-mailbox url + (or (imap-url-container-mailbox url) + ""))) + +(define-method container-url-for-prompt ((url )) + (imap-url-new-mailbox url + (or (imap-url-container-mailbox url) + (get-personal-namespace url) + ""))) + +(define-method url-child-name ((url )) + (let* ((mailbox (imap-url-mailbox url)) + (index (imap-mailbox-container-slash mailbox))) + (if index + (string-tail mailbox (fix:+ index 1)) + mailbox))) + +(define-method make-child-url ((url ) child-name) + (imap-url-new-mailbox url (string-append (imap-url-mailbox url) child-name))) + +(define (imap-url-container-mailbox url) + (let* ((mailbox (imap-url-mailbox url)) + (index (imap-mailbox-container-slash mailbox))) + (and index + (string-head mailbox (fix:+ index 1))))) + +(define (imap-mailbox-container-slash mailbox) + (substring-find-previous-char mailbox + 0 + (let ((n (string-length mailbox))) + (if (string-suffix? "/" mailbox) + (fix:- n 1) + n)) + #\/)) (define (get-personal-namespace url) (let ((response @@ -215,7 +218,7 @@ (string-replace prefix (string-ref delimiter 0) #\/)) prefix))))))) -(define (imap-container-url-contents url) +(define-method container-url-contents ((url )) (with-open-imap-connection url (lambda (connection) (map (lambda (response) @@ -1378,9 +1381,6 @@ (define-method save-resource ((container )) container #f) - -(define-method container-contents ((container )) - (imap-container-url-contents (resource-locator container))) ;;;; IMAP command invocation diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index f1b779cff..66778d06d 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.249 2001/05/24 03:43:17 cph Exp $ +;;; $Id: imail-top.scm,v 1.250 2001/05/24 17:46:51 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -1352,9 +1352,10 @@ The folder's type may not be changed." 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE 'REQUIRE-MATCH? #t))) (list from - (prompt-for-folder "Rename folder to" - (container-url (imail-parse-partial-url from)) - 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET)))) + (prompt-for-folder + "Rename folder to" + (container-url-for-prompt (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))) @@ -1383,7 +1384,7 @@ If it doesn't exist, it is created first." (lambda () (imail-parse-partial-url (car history)))))) (and (url? url) - (container-url url))))) + (container-url-for-prompt url))))) (imail-default-container)) (url-base-name (imail-parse-partial-url from))) 'HISTORY 'IMAIL-COPY-FOLDER-TARGET)))) @@ -1635,7 +1636,7 @@ Negative argument means search in reverse." (let ((container (selected-container #f))) (if container (resource-locator container) - (container-url (imail-default-url #f))))) + (container-url-for-prompt (imail-default-url #f))))) (define (maybe-prompt-for-folder prompt . options) (or (selected-url-string #f) -- 2.25.1