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.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index b981f13b42ce7b9e14246a6c2d4a33ba3b81de9c..e0603ca7def985e80d9962833b1b9df133e767ae 100644 (file)
--- 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)))
 \f
 ;; 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))
 \f
 ;;;; Resources
 
@@ -338,6 +367,9 @@
 (define-method container-url ((resource <resource>))
   (container-url (resource-locator resource)))
 
+(define-method container-url-for-prompt ((resource <resource>))
+  (container-url-for-prompt (resource-locator resource)))
+
 (define-class <folder> (<resource>))
 (define-class <container> (<resource>))
 
@@ -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))
 \f
 ;;;; Message type
 

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 0dde1e8eb2327bf9cf5ac298f3a979698a31d924..70ae63e8a03e0f648eeb7a33aa84f522992af854 100644 (file)
--- 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 <pathname-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 <pathname-url>))
+  (make-directory-url (pathname-container (pathname-url-pathname url))))
+
+(define-method url-child-name ((url <pathname-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))))
 \f
-;;;; File folders
+;;;; File URLs
 
 (define-class <file-url> (<folder-url> <pathname-url>))
 (define make-file-url (pathname-url-constructor <file-url>))
@@ -170,13 +178,10 @@
 (define-method url-exists? ((url <file-url>))
   (file-exists? (pathname-url-pathname url)))
 
-(define-method url-presentation-name ((url <file-url>))
-  (file-namestring (pathname-url-pathname url)))
-
 (define-method url-base-name ((url <file-url>))
   (pathname-name (pathname-url-pathname url)))
 
-;;;; File containers
+;;;; Directory URLs
 
 (define-class <directory-url> (<container-url> <pathname-url>))
 
@@ -191,16 +196,21 @@
 (define-method url-exists? ((url <directory-url>))
   (file-directory? (pathname-url-pathname url)))
 
-(define-method url-presentation-name ((url <directory-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 <directory-url>) name)
   (let ((pathname (merge-pathnames name (pathname-url-pathname url))))
     ((standard-pathname-url-constructor pathname) pathname)))
+
+(define-method container-url-contents ((url <directory-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))))))
 \f
 ;;;; Server operations
 
@@ -482,18 +492,6 @@
 (define-method save-resource ((container <file-container>))
   container
   #f)
-
-(define-method container-contents ((container <file-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))))))
 \f
 ;;;; Message
 

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 6da35502b25fac6622030fb8906e7997876101fb..b81b7b9fccc1cb2c96894fb3bd61ebaf32a284f7 100644 (file)
--- 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 <imap-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 <imap-url>))
-  (make-url-string (url-protocol url) (make-imap-url-string url #f)))
-
 (define-method url-base-name ((url <imap-folder-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 <imap-container-url>) base-name)
-  (imap-url-new-mailbox url (string-append (imap-url-mailbox url) base-name)))
+(define-method url-pass-phrase-key ((url <imap-url>))
+  (make-url-string (url-protocol url) (make-imap-url-string url #f)))
 
 (define-method parse-url-body (string (default-url <imap-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>))
-  (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>))
+  (imap-url-new-mailbox url
+                       (or (imap-url-container-mailbox url)
+                           (get-personal-namespace url)
+                           "")))
+
+(define-method url-child-name ((url <imap-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 <imap-container-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 <imap-container-url>))
   (with-open-imap-connection url
     (lambda (connection)
       (map (lambda (response)
@@ -1378,9 +1381,6 @@
 (define-method save-resource ((container <imap-container>))
   container
   #f)
-
-(define-method container-contents ((container <imap-container>))
-  (imap-container-url-contents (resource-locator container)))
 \f
 ;;;; IMAP command invocation
 

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index f1b779cffa93dd1c2c273dc3e4b7bbfaa2736e4f..66778d06d97d760c1c749c6283ce6ea97774da7c 100644 (file)
--- 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)))))
 \f
 (define (maybe-prompt-for-folder prompt . options)
   (or (selected-url-string #f)