Eliminate MAKE-PEER-URL in favor of MAKE-CHILD-URL.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index e0008c45e20fddc0d91a08b21049e9049f423404..56334531225bdf46fa9d6b631892fe4c57f7dc4e 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.122 2001/05/15 19:46:48 cph Exp $
+;;; $Id: imail-core.scm,v 1.123 2001/05/17 04:37:26 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -88,10 +88,9 @@
 ;; following the rightmost delimiter.
 (define-generic url-base-name (folder-url))
 
-;; Return a URL that has the same container as FOLDER-URL, but with
-;; base name NAME.  This is roughly equivalent to appending NAME to
-;; the container string of FOLDER-URL.
-(define-generic make-peer-url (folder-url name))
+;; Return a URL that refers to the child NAME of the container
+;; referred to by CONTAINER-URL.
+(define-generic make-child-url (container-url name))
 
 ;; Return a string that concisely identifies URL, for use in the
 ;; presentation layer.

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 0563887ee8ea25d850cf3c298a1d81f707ecfd3a..d44bca74c0ad95d1828722b9d551cd144e3419bf 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.65 2001/05/15 19:46:51 cph Exp $
+;;; $Id: imail-file.scm,v 1.66 2001/05/17 04:37:30 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -102,18 +102,21 @@
 (define-method parse-url-body ((string <string>) (default-url <pathname-url>))
   (let ((pathname
         (parse-pathname-url-body string (pathname-url-pathname default-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)))
+    ((standard-pathname-url-constructor pathname) pathname)))
+
+(define (standard-pathname-url-constructor pathname)
+  (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
+            ;; Default for non-existent files:
+            make-umail-url))
+       (else
+        (error "Pathname refers to illegal file type:" pathname))))))
 
 (define (parse-pathname-url-body string default-pathname)
   (let ((finish
@@ -194,6 +197,10 @@
       (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)))
 \f
 ;;;; Server operations
 

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index f56d7d3e951c8e6158aafe88ff50d8569d1e618e..5b16ab4d11d94cf0b529c8c0a9bb04d1e445a83c 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.152 2001/05/17 04:00:04 cph Exp $
+;;; $Id: imail-imap.scm,v 1.153 2001/05/17 04:37:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -138,11 +138,9 @@
          (string-tail mailbox (fix:+ index 1))
          mailbox))))
 
-(define-method make-peer-url ((url <imap-folder-url>) base-name)
-  (imap-url-new-mailbox
-   url
-   (string-append (imap-url-mailbox (url-container url)) base-name)))
-\f
+(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 parse-url-body (string (default-url <imap-url>))
   (call-with-values (lambda () (parse-imap-url-body string default-url))
     (lambda (user-id host port mailbox)

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index b4d0eff69d453c10381b9985b75019abb3d20664..50fcc81707f379dae5557d8f34d988482b8692b3 100644 (file)
--- 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.63 2001/05/15 19:46:57 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.64 2001/05/17 04:37:42 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -36,11 +36,6 @@
        (and (equal? (pathname-name pathname) "RMAIL")
             (not (pathname-type pathname))))))
 
-(define-method make-peer-url ((url <rmail-url>) name)
-  (make-rmail-url
-   (merge-pathnames (pathname-default-type name "rmail")
-                   (directory-pathname (pathname-url-pathname url)))))
-
 ;;;; Server operations
 
 (define-method %open-folder ((url <rmail-url>))

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index e2d71253de0580e7aea0e4e6a8b8a115e7be1d24..ef931a8a7efcb8e517b8a5ab3574e528e41337ed 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.238 2001/05/13 03:46:14 cph Exp $
+;;; $Id: imail-top.scm,v 1.239 2001/05/17 04:37:52 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -1365,17 +1365,18 @@ If it doesn't exist, it is created first."
       (list from
            (prompt-for-folder
             "Copy messages to folder"
-            (make-peer-url
-             (or (let ((history
-                        (prompt-history-strings 'IMAIL-COPY-FOLDER-TARGET)))
-                   (and (pair? history)
-                        (let ((url
-                               (ignore-errors
-                                (lambda ()
-                                  (imail-parse-partial-url (car history))))))
-                          (and (url? url)
-                               url))))
-                 (imail-default-url #f))
+            (make-child-url
+             (url-container
+              (or (let ((history
+                         (prompt-history-strings 'IMAIL-COPY-FOLDER-TARGET)))
+                    (and (pair? history)
+                         (let ((url
+                                (ignore-errors
+                                 (lambda ()
+                                   (imail-parse-partial-url (car history))))))
+                           (and (url? url)
+                                url))))
+                  (imail-default-url #f)))
              (url-base-name (imail-parse-partial-url from)))
             'HISTORY 'IMAIL-COPY-FOLDER-TARGET))))
   (lambda (from to)

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index df53735aa9b9f726950477e5c8af976208b02ec1..a65bdf6a92a48bcae27095ba932aea670ea15a0b 100644 (file)
--- 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.44 2001/05/15 19:46:59 cph Exp $
+;;; $Id: imail-umail.scm,v 1.45 2001/05/17 04:37:55 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -33,11 +33,6 @@
   (lambda (pathname) pathname #f)
   (lambda (pathname) (equal? (pathname-type pathname) "mail")))
 
-(define-method make-peer-url ((url <umail-url>) name)
-  (make-umail-url
-   (merge-pathnames (pathname-default-type name "mail")
-                   (directory-pathname (pathname-url-pathname url)))))
-
 ;;;; Server operations
 
 (define-method %open-folder ((url <umail-url>))