From: Chris Hanson Date: Sun, 13 May 2001 03:46:17 +0000 (+0000) Subject: * Implement container URLs, which are separate from folder URLs. X-Git-Tag: 20090517-FFI~2824 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=818ec0918cfd0c0659185896b80d9057668b8410;p=mit-scheme.git * Implement container URLs, which are separate from folder URLs. These are implemented as directories for file-based folders. IMAP folders are also containers. * Eliminate URL-CONTAINER-STRING; now there is URL-CONTAINER that returns a container URL. * Rename URL-SELECTABLE? to URL-IS-SELECTABLE?. * Eliminate "rmail" and "umail" protocols in favor of "file". This now covers both Rmail and unix-mail folders, as well as directories. The actual file type is determined by probing the first few bytes of the file for known patterns. The names "rmail" and "umail" are now treated as equivalent to "file" for upwards compatibility. * Change prompting code in front end so that it is possible to specify that the returned folder satisfies URL-IS-SELECTABLE?. Also add a procedure to prompt for a container. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 3d4335b5d..08a24afa5 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.120 2001/05/09 17:38:17 cph Exp $ +;;; $Id: imail-core.scm,v 1.121 2001/05/13 03:45:48 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -41,6 +41,8 @@ ;;;; URL type (define-class ()) +(define-class ()) +(define-class ()) (define (guarantee-url url procedure) (if (not (url? url)) @@ -64,35 +66,31 @@ (write-char #\space port) (write (url->string url) port)))) -;; Return a string that concisely identifies URL, for use in the -;; presentation layer. -(define-generic url-presentation-name (url)) +;; Return #T iff URL represents an existing folder. +(define-generic url-exists? (url)) -;; Return a string that represents the object containing URL's folder. -;; E.g. the container of "imap://localhost/inbox" is -;; "imap://localhost/" (except that for IMAP folders, the result may -;; be affected by the NAMESPACE prefix information). -(define (url-container-string url) - (make-url-string (url-protocol url) - (url-body-container-string url))) +;; Return #T iff URL both exists and can be opened. +(define-generic url-is-selectable? (folder-url)) -(define-generic url-body-container-string (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). +(define-generic url-container (url)) -;; Return the base name of URL. This is the PATHNAME-NAME of a +;; 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 (url)) - -;; Return a URL that has the same container as URL, but with base name -;; NAME. This is roughly equivalent to appending NAME to the -;; container string of URL. -(define-generic make-peer-url (url name)) +(define-generic url-base-name (folder-url)) -;; Return #T if URL represents an existing folder. -(define-generic url-exists? (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 #T if URL both exists and can be opened. -(define-generic url-selectable? (url)) +;; Return a string that concisely identifies URL, for use in the +;; presentation layer. +(define-generic url-presentation-name (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 @@ -110,8 +108,9 @@ (define (parse-url-string string get-default-url) (let ((colon (string-find-next-char string #\:))) (if colon - (parse-url-body (string-tail string (fix:+ colon 1)) - (get-default-url (string-head string colon))) + (parse-url-body + (string-tail string (fix:+ colon 1)) + (get-default-url (map-legacy-protocols (string-head string colon)))) (parse-url-body string (get-default-url #f))))) ;; Protocol-specific parsing. Dispatch on the class of DEFAULT-URL. @@ -189,13 +188,19 @@ (lambda (body) (make-url-string protocol body))))) (if colon - (let ((protocol (string-head string colon))) + (let ((protocol (map-legacy-protocols (string-head string colon)))) (values (string-tail string (fix:+ colon 1)) (and (url-protocol-name? protocol) (get-default-url protocol)) (make-prepend protocol))) (let ((url (get-default-url #f))) (values string url (make-prepend (url-protocol url))))))) + +(define (map-legacy-protocols protocol) + (if (or (string=? protocol "rmail") + (string=? protocol "umail")) + "file" + protocol)) ;;;; Server operations diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index ecd1c7997..6261478b4 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.63 2001/05/10 18:19:17 cph Exp $ +;;; $Id: imail-file.scm,v 1.64 2001/05/13 03:45:52 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -25,26 +25,31 @@ ;;;; URL -(define-class () +(define-class () (pathname define accessor)) -(define-method url-body ((url )) - (pathname->url-body (file-url-pathname url))) +(define-url-protocol "file" ) -(define-method url-presentation-name ((url )) - (file-namestring (file-url-pathname url))) +(define (pathname-url-constructor class) + (let ((procedure + (let ((constructor (instance-constructor class '(PATHNAME)))) + (lambda (pathname) + (intern-url (constructor (merge-pathnames pathname))))))) + (register-pathname-url-constructor class procedure) + procedure)) -(define-method url-body-container-string ((url )) - (pathname->url-body (directory-namestring (file-url-pathname url)))) +(define (register-pathname-url-constructor class constructor) + (hash-table/put! pathname-url-constructors class constructor)) -(define-method url-base-name ((url )) - (pathname-name (file-url-pathname url))) +(define (get-pathname-url-constructor class) + (or (hash-table/get pathname-url-constructors class #f) + (error "Unknown pathname-url class:" class))) -(define-method url-exists? ((url )) - (file-exists? (file-url-pathname url))) +(define pathname-url-constructors + (make-eq-hash-table)) -(define-method url-selectable? ((url )) - (file-regular? (file-url-pathname url))) +(define-method url-body ((url )) + (pathname->url-body (pathname-url-pathname url))) (define (pathname->url-body pathname) (string-append (let ((device (pathname-device pathname))) @@ -64,7 +69,43 @@ "")) (url:encode-string (file-namestring pathname)))) -(define (parse-file-url-body string default-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) + (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)) + (loop (cdr entries))) + (begin + (set! pathname-url-predicates + (cons (vector class predicate constructor) + pathname-url-predicates)) + unspecific))))) + +(define pathname-url-predicates '()) + +(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))) + pathname))) + +(define (parse-pathname-url-body string default-pathname) (let ((finish (lambda (string) (merge-pathnames @@ -83,18 +124,58 @@ ((string-prefix? "///" string) (finish (string-tail string (string-length "//")))) ((string-prefix? "//" string) - (error:bad-range-argument string 'PARSE-URL-BODY)) + (error:bad-range-argument string 'PARSE-PATHNAME-URL-BODY)) (else (finish string))))) +;;;; File folders + +(define-class ( )) +(define make-file-url (pathname-url-constructor )) + +(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))) + +(define-method url-base-name ((url )) + (pathname-name (pathname-url-pathname url))) + +;;;; File containers + +(define-class ( )) + +(define make-directory-url + (let ((constructor (instance-constructor '(PATHNAME)))) + (lambda (pathname) + (intern-url + (constructor (pathname-as-directory (merge-pathnames pathname))))))) + +(register-pathname-url-constructor make-directory-url) + +(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))))) + ;;;; Server operations (define-method %url-complete-string - ((string ) (default-url ) + ((string ) (default-url ) if-unique if-not-unique if-not-found) (pathname-complete-string - (parse-file-url-body string - (directory-pathname (file-url-pathname default-url))) + (parse-pathname-url-body + string + (directory-pathname (pathname-url-pathname default-url))) (lambda (pathname) pathname #t) (lambda (string) (if-unique (pathname->url-body string))) @@ -104,16 +185,16 @@ if-not-found)) (define-method %url-string-completions - ((string ) (default-url )) + ((string ) (default-url )) (map pathname->url-body (pathname-completions-list - (parse-file-url-body + (parse-pathname-url-body string - (directory-pathname (file-url-pathname default-url))) + (directory-pathname (pathname-url-pathname default-url))) (lambda (pathname) pathname #t)))) (define-method %delete-folder ((url )) - (delete-file (file-url-pathname url))) + (delete-file (pathname-url-pathname url))) ;;; The next method only works when operating on two URLs of the same ;;; class, and is restricted to cases where RENAME-FILE works. @@ -121,7 +202,8 @@ (define-computed-method %rename-folder ((uc1 ) (uc2 )) (and (eq? uc1 uc2) (lambda (url new-url) - (rename-file (file-url-pathname url) (file-url-pathname new-url))))) + (rename-file (pathname-url-pathname url) + (pathname-url-pathname new-url))))) (define-method with-open-connection ((url ) thunk) url @@ -147,7 +229,7 @@ (define-generic revert-file-folder (folder)) (define (file-folder-pathname folder) - (file-url-pathname (folder-url folder))) + (pathname-url-pathname (folder-url folder))) (define-method %close-folder ((folder )) (discard-file-folder-messages folder) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index fefd81e84..cc73b632f 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.149 2001/05/09 17:38:33 cph Exp $ +;;; $Id: imail-imap.scm,v 1.150 2001/05/13 03:46:01 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -25,7 +25,7 @@ ;;;; URL -(define-class () +(define-class ( ) ;; User name to connect as. (user-id define accessor) ;; Name or IP address of host to connect to. @@ -37,6 +37,25 @@ (define-url-protocol "imap" ) +(define-method url-exists? ((url )) + (and (imap-url-info url) #t)) + +(define-method url-is-selectable? ((url )) + (let ((response (imap-url-info url))) + (and response + (not (memq '\NOSELECT (imap:response:list-flags response)))))) + +(define (imap-url-info url) + (let ((responses + (with-open-imap-connection url + (lambda (connection) + (imap:command:list connection + "" + (imap-url-server-mailbox url)))))) + (and (pair? responses) + (null? (cdr responses)) + (car responses)))) + (define make-imap-url (let ((constructor (instance-constructor '(USER-ID HOST PORT MAILBOX)))) @@ -72,7 +91,7 @@ (substring-downcase! mailbox 0 5) mailbox)) (else mailbox))) - + (define-method url-body ((url )) (make-imap-url-string url (imap-url-mailbox url))) @@ -85,34 +104,10 @@ (and (string=? (imap-url-user-id url1) (imap-url-user-id url2)) (string=? (imap-url-host url1) (imap-url-host url2)) (= (imap-url-port url1) (imap-url-port url2)))) - -(define-method url-exists? ((url )) - (and (imap-url-info url) #t)) - -(define-method url-selectable? ((url )) - (let ((response (imap-url-info url))) - (and response - (not (memq '\NOSELECT (imap:response:list-flags response)))))) - -(define (imap-url-info url) - (let ((responses - (with-open-imap-connection url - (lambda (connection) - (imap:command:list connection - "" - (imap-url-server-mailbox url)))))) - (and (pair? responses) - (null? (cdr responses)) - (car responses)))) (define-method url-pass-phrase-key ((url )) (make-url-string (url-protocol url) (make-imap-url-string url #f))) -(define-method url-body-container-string ((url )) - (make-imap-url-string - url - (imap-mailbox-container-string url (imap-url-mailbox url)))) - (define-method url-base-name ((url )) (let ((mailbox (imap-url-mailbox url))) (let ((index (string-search-backward "/" mailbox))) @@ -120,14 +115,26 @@ (string-tail mailbox index) mailbox)))) -(define-method make-peer-url ((url ) base-name) +(define (imap-url-new-mailbox url mailbox) (make-imap-url (imap-url-user-id url) (imap-url-host url) (imap-url-port url) - (string-append - (imap-mailbox-container-string url (imap-url-mailbox url)) + 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))) +(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 diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index c843de056..9288c5cf5 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.61 2001/03/20 04:03:56 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.62 2001/05/13 03:46:04 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -26,31 +26,40 @@ ;;;; URL (define-class ()) -(define-url-protocol "rmail" ) - -(define make-rmail-url - (let ((constructor (instance-constructor '(PATHNAME)))) - (lambda (pathname) - (intern-url (constructor (merge-pathnames pathname)))))) - -(define-method parse-url-body ((string ) (default-url )) - (make-rmail-url - (parse-file-url-body string (file-url-pathname default-url)))) +(define make-rmail-url (pathname-url-constructor )) + +(define-pathname-url-predicate + (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)))) (define-method make-peer-url ((url ) name) (make-rmail-url (merge-pathnames (pathname-default-type name "rmail") - (directory-pathname (file-url-pathname url))))) + (directory-pathname (pathname-url-pathname url))))) ;;;; Server operations (define-method %open-folder ((url )) - (if (not (file-readable? (file-url-pathname url))) + (if (not (file-readable? (pathname-url-pathname url))) (error:bad-range-argument url 'OPEN-FOLDER)) (make-rmail-folder url)) (define-method %create-folder ((url )) - (if (file-exists? (file-url-pathname url)) + (if (file-exists? (pathname-url-pathname url)) (error:bad-range-argument url 'CREATE-FOLDER)) (let ((folder (make-rmail-folder url))) (set-file-folder-messages! folder '#()) @@ -268,7 +277,7 @@ (write-rmail-message message port)))))) (define-method append-message-to-file ((message ) (url )) - (let ((pathname (file-url-pathname url))) + (let ((pathname (pathname-url-pathname url))) (if (file-exists? pathname) (let ((port (open-binary-output-file pathname #t))) (write-rmail-message message port) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 097628d48..e2d71253d 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.237 2001/05/07 18:01:40 cph Exp $ +;;; $Id: imail-top.scm,v 1.238 2001/05/13 03:46:14 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -216,11 +216,8 @@ imap://[@][:]/ Specifies a folder on an IMAP server. The portions in brackets are optional and are filled in automatically if omitted. -rmail: - Specifies an RMAIL file. - -umail: - Specifies a unix mail file. +file: + Specifies a file-based folder, e.g. RMAIL. You may simultaneously open multiple mail folders. If you revisit a folder that is already in a buffer, that buffer is selected. Messages @@ -229,9 +226,9 @@ the type of folder. Likewise, the available commands are the same regardless of the folder type." (lambda () (list (and (command-argument) - (prompt-for-imail-url-string "Run IMAIL on folder" #f - 'HISTORY 'IMAIL - 'REQUIRE-MATCH? #t)))) + (prompt-for-selectable-folder "Run IMAIL on folder" #f + 'HISTORY 'IMAIL + 'REQUIRE-MATCH? #t)))) (lambda (url-string) (let ((folder (open-folder @@ -819,10 +816,10 @@ With prefix argument N, removes FLAG from next N messages, (define-command imail-input-from-folder "Append messages to this folder from a specified folder." (lambda () - (list (prompt-for-imail-url-string "Get messages from folder" #f - 'HISTORY 'IMAIL-INPUT-FROM-FOLDER - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t))) + (list (prompt-for-selectable-folder "Get messages from folder" #f + 'HISTORY 'IMAIL-INPUT-FROM-FOLDER + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t))) (lambda (url-string) (let ((url (imail-parse-partial-url url-string))) (copy-folder (open-folder url) @@ -833,10 +830,10 @@ With prefix argument N, removes FLAG from next N messages, (define-command imail-output "Append this message to a specified folder." (lambda () - (list (prompt-for-imail-url-string "Output to folder" - (ref-variable imail-output-default #f) - 'HISTORY 'IMAIL-OUTPUT - 'HISTORY-INDEX 0) + (list (prompt-for-folder "Output to folder" + (ref-variable imail-output-default #f) + 'HISTORY 'IMAIL-OUTPUT + 'HISTORY-INDEX 0) (command-argument))) (lambda (url-string argument) (let ((url (imail-parse-partial-url url-string)) @@ -1312,8 +1309,8 @@ ADDRESSES is a string consisting of several addresses separated by commas." "Create a new folder with the specified name. An error if signalled if the folder already exists." (lambda () - (list (prompt-for-imail-url-string "Create folder" #f - 'HISTORY 'IMAIL-CREATE-FOLDER))) + (list (prompt-for-folder "Create folder" #f + 'HISTORY 'IMAIL-CREATE-FOLDER))) (lambda (url-string) (let ((url (imail-parse-partial-url url-string))) (create-folder url) @@ -1322,9 +1319,9 @@ An error if signalled if the folder already exists." (define-command imail-delete-folder "Delete a specified folder and all its messages." (lambda () - (list (prompt-for-imail-url-string "Delete folder" #f - 'HISTORY 'IMAIL-DELETE-FOLDER - 'REQUIRE-MATCH? #t))) + (list (prompt-for-folder "Delete folder" #f + 'HISTORY 'IMAIL-DELETE-FOLDER + 'REQUIRE-MATCH? #t))) (lambda (url-string) (let ((url (imail-parse-partial-url url-string))) (if (prompt-for-yes-or-no? @@ -1340,14 +1337,14 @@ May only rename a folder to a new name on the same server or file system. The folder's type may not be changed." (lambda () (let ((from - (prompt-for-imail-url-string "Rename folder" #f - 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t))) + (prompt-for-folder "Rename folder" #f + 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t))) (list from - (prompt-for-imail-url-string + (prompt-for-folder "Rename folder to" - (url-container-string (imail-parse-partial-url from)) + (url->string (url-container (imail-parse-partial-url from))) 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET)))) (lambda (from to) (let ((from (imail-parse-partial-url from)) @@ -1361,12 +1358,12 @@ If the target folder exists, the messages are appended to it. If it doesn't exist, it is created first." (lambda () (let ((from - (prompt-for-imail-url-string "Copy folder" #f - 'HISTORY 'IMAIL-COPY-FOLDER-SOURCE - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t))) + (prompt-for-selectable-folder "Copy folder" #f + 'HISTORY 'IMAIL-COPY-FOLDER-SOURCE + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t))) (list from - (prompt-for-imail-url-string + (prompt-for-folder "Copy messages to folder" (make-peer-url (or (let ((history @@ -1461,9 +1458,9 @@ With prefix argument, closes and buries only selected IMAIL folder." (define-command imail-input "Run IMAIL on a specified folder." (lambda () - (list (prompt-for-imail-url-string "Run IMAIL on folder" #f - 'HISTORY 'IMAIL - 'REQUIRE-MATCH? #t))) + (list (prompt-for-selectable-folder "Run IMAIL on folder" #f + 'HISTORY 'IMAIL + 'REQUIRE-MATCH? #t))) (lambda (url-string) ((ref-command imail) url-string))) @@ -1510,10 +1507,10 @@ A prefix argument says to prompt for a URL and append all messages from that folder to the current one." (lambda () (list (and (command-argument) - (prompt-for-imail-url-string "Get messages from folder" #f - 'HISTORY 'IMAIL-INPUT - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t)))) + (prompt-for-selectable-folder "Get messages from folder" #f + 'HISTORY 'IMAIL-INPUT + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t)))) (lambda (url-string) (if url-string ((ref-command imail-input-from-folder) url-string) @@ -1614,11 +1611,28 @@ Negative argument means search in reverse." port (ref-variable imail-default-imap-mailbox #f))))) - ((string-ci=? protocol "rmail") (make-rmail-url "~/RMAIL")) - ((string-ci=? protocol "umail") (make-umail-url "~/inbox.mail")) + ((string-ci=? protocol "file") (make-rmail-url "~/RMAIL")) (else (error:bad-range-argument protocol)))) - -(define (prompt-for-imail-url-string prompt default . options) + +(define (prompt-for-folder prompt default . options) + (%prompt-for-url prompt default options + (lambda (url) + (and (folder-url? url) + (url-exists? url))))) + +(define (prompt-for-selectable-folder prompt default . options) + (%prompt-for-url prompt default options + (lambda (url) + (and (folder-url? url) + (url-is-selectable? url))))) + +(define (prompt-for-container prompt default . options) + (%prompt-for-url prompt default options + (lambda (url) + (and (container-url? url) + (url-exists? url))))) + +(define (%prompt-for-url prompt default options predicate) (let ((get-option (lambda (key) (let loop ((options options)) @@ -1628,10 +1642,11 @@ Negative argument means search in reverse." (cadr options) (loop (cddr options))))))) (default - (cond ((string? default) default) - ((url? default) (url->string default)) - ((not default) (url-container-string (imail-default-url #f))) - (else (error "Illegal default:" default))))) + (cond ((string? default) default) + ((url? default) (url->string default)) + ((not default) + (url->string (url-container (imail-default-url #f)))) + (else (error "Illegal default:" default))))) (let ((history (get-option 'HISTORY))) (if (null? (prompt-history-strings history)) (set-prompt-history-strings! history (list default)))) @@ -1644,7 +1659,7 @@ Negative argument means search in reverse." (lambda (string) (url-string-completions string imail-get-default-url)) (lambda (string) - (url-exists? (imail-parse-partial-url string))) + (predicate (imail-parse-partial-url string))) 'DEFAULT-TYPE 'INSERTED-DEFAULT options))) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index afde17565..4e9d24ee4 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.42 2001/03/19 22:51:53 cph Exp $ +;;; $Id: imail-umail.scm,v 1.43 2001/05/13 03:46:17 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -26,31 +26,38 @@ ;;;; URL (define-class ()) -(define-url-protocol "umail" ) - -(define make-umail-url - (let ((constructor (instance-constructor '(PATHNAME)))) - (lambda (pathname) - (intern-url (constructor (merge-pathnames pathname)))))) - -(define-method parse-url-body ((string ) (default-url )) - (make-umail-url - (parse-file-url-body string (file-url-pathname default-url)))) +(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-method make-peer-url ((url ) name) (make-umail-url (merge-pathnames (pathname-default-type name "mail") - (directory-pathname (file-url-pathname url))))) + (directory-pathname (pathname-url-pathname url))))) ;;;; Server operations (define-method %open-folder ((url )) - (if (not (file-readable? (file-url-pathname url))) + (if (not (file-readable? (pathname-url-pathname url))) (error:bad-range-argument url 'OPEN-FOLDER)) (make-umail-folder url)) (define-method %create-folder ((url )) - (if (file-exists? (file-url-pathname url)) + (if (file-exists? (pathname-url-pathname url)) (error:bad-range-argument url 'CREATE-FOLDER)) (let ((folder (make-umail-folder url))) (set-file-folder-messages! folder '#()) @@ -60,9 +67,6 @@ (folder-modification-count folder)) (save-folder folder))) -(define (read-umail-file pathname) - (make-umail-folder (make-umail-url pathname))) - ;;;; Folder (define-class ( (constructor (url))) ()) @@ -171,7 +175,7 @@ (write-umail-message message #t port)))))) (define-method append-message-to-file ((message ) (url )) - (let ((port (open-binary-output-file (file-url-pathname url) #t))) + (let ((port (open-binary-output-file (pathname-url-pathname url) #t))) (write-umail-message message #t port) (close-port port)))