From: Chris Hanson Date: Thu, 17 May 2001 04:37:55 +0000 (+0000) Subject: Eliminate MAKE-PEER-URL in favor of MAKE-CHILD-URL. X-Git-Tag: 20090517-FFI~2820 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=022a8429b858d0efd5360721999ae414219023a1;p=mit-scheme.git 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 e0008c45e..563345312 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.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 0563887ee..d44bca74c 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.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 ) (default-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 ) name) + (let ((pathname (merge-pathnames name (pathname-url-pathname url)))) + ((standard-pathname-url-constructor pathname) pathname))) ;;;; Server operations diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index f56d7d3e9..5b16ab4d1 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.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 ) base-name) - (imap-url-new-mailbox - url - (string-append (imap-url-mailbox (url-container url)) base-name))) - +(define-method make-child-url ((url ) base-name) + (imap-url-new-mailbox url (string-append (imap-url-mailbox url) base-name))) + (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) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index b4d0eff69..50fcc8170 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.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 ) name) - (make-rmail-url - (merge-pathnames (pathname-default-type name "rmail") - (directory-pathname (pathname-url-pathname url))))) - ;;;; Server operations (define-method %open-folder ((url )) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index e2d71253d..ef931a8a7 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.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 df53735aa..a65bdf6a9 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.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 ) name) - (make-umail-url - (merge-pathnames (pathname-default-type name "mail") - (directory-pathname (pathname-url-pathname url))))) - ;;;; Server operations (define-method %open-folder ((url ))