;;; -*-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
;;;
;;;; URL type
(define-class <url> (<imail-object>))
+(define-class <folder-url> (<url>))
+(define-class <container-url> (<url>))
(define (guarantee-url url procedure)
(if (not (url? url))
(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
(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.
(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))
\f
;;;; Server operations
;;; -*-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
;;;
\f
;;;; URL
-(define-class <file-url> (<url>)
+(define-class <pathname-url> (<url>)
(pathname define accessor))
-(define-method url-body ((url <file-url>))
- (pathname->url-body (file-url-pathname url)))
+(define-url-protocol "file" <pathname-url>)
-(define-method url-presentation-name ((url <file-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 <file-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 <file-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-url>))
- (file-exists? (file-url-pathname url)))
+(define pathname-url-constructors
+ (make-eq-hash-table))
-(define-method url-selectable? ((url <file-url>))
- (file-regular? (file-url-pathname url)))
+(define-method url-body ((url <pathname-url>))
+ (pathname->url-body (pathname-url-pathname url)))
(define (pathname->url-body pathname)
(string-append (let ((device (pathname-device pathname)))
""))
(url:encode-string (file-namestring pathname))))
-(define (parse-file-url-body string default-pathname)
+(define-method url-container ((url <pathname-url>))
+ (make-directory-url
+ (directory-pathname
+ (directory-pathname-as-file (pathname-url-pathname url)))))
+\f
+(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 <string>) (default-url <pathname-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
((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)))))
\f
+;;;; File folders
+
+(define-class <file-url> (<folder-url> <pathname-url>))
+(define make-file-url (pathname-url-constructor <file-url>))
+
+(define-method url-exists? ((url <file-url>))
+ (file-exists? (pathname-url-pathname url)))
+
+(define-method url-is-selectable? ((url <file-url>))
+ (file-regular? (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
+
+(define-class <directory-url> (<container-url> <pathname-url>))
+
+(define make-directory-url
+ (let ((constructor (instance-constructor <directory-url> '(PATHNAME))))
+ (lambda (pathname)
+ (intern-url
+ (constructor (pathname-as-directory (merge-pathnames pathname)))))))
+
+(register-pathname-url-constructor <directory-url> make-directory-url)
+
+(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)))))
+\f
;;;; Server operations
(define-method %url-complete-string
- ((string <string>) (default-url <file-url>)
+ ((string <string>) (default-url <pathname-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)))
if-not-found))
(define-method %url-string-completions
- ((string <string>) (default-url <file-url>))
+ ((string <string>) (default-url <pathname-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 <file-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.
(define-computed-method %rename-folder ((uc1 <file-url>) (uc2 <file-url>))
(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 <file-url>) thunk)
url
(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 <file-folder>))
(discard-file-folder-messages folder)
;;; -*-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
;;;
\f
;;;; URL
-(define-class <imap-url> (<url>)
+(define-class <imap-url> (<folder-url> <container-url>)
;; User name to connect as.
(user-id define accessor)
;; Name or IP address of host to connect to.
(define-url-protocol "imap" <imap-url>)
+(define-method url-exists? ((url <imap-url>))
+ (and (imap-url-info url) #t))
+
+(define-method url-is-selectable? ((url <imap-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 <imap-url> '(USER-ID HOST PORT MAILBOX))))
(substring-downcase! mailbox 0 5)
mailbox))
(else mailbox)))
-
+\f
(define-method url-body ((url <imap-url>))
(make-imap-url-string url (imap-url-mailbox url)))
(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))))
-\f
-(define-method url-exists? ((url <imap-url>))
- (and (imap-url-info url) #t))
-
-(define-method url-selectable? ((url <imap-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 <imap-url>))
(make-url-string (url-protocol url) (make-imap-url-string url #f)))
-(define-method url-body-container-string ((url <imap-url>))
- (make-imap-url-string
- url
- (imap-mailbox-container-string url (imap-url-mailbox url))))
-
(define-method url-base-name ((url <imap-url>))
(let ((mailbox (imap-url-mailbox url)))
(let ((index (string-search-backward "/" mailbox)))
(string-tail mailbox index)
mailbox))))
-(define-method make-peer-url ((url <imap-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 <imap-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>))
+ (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
;;; -*-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
;;;
;;;; URL
(define-class <rmail-url> (<file-url>))
-(define-url-protocol "rmail" <rmail-url>)
-
-(define make-rmail-url
- (let ((constructor (instance-constructor <rmail-url> '(PATHNAME))))
- (lambda (pathname)
- (intern-url (constructor (merge-pathnames pathname))))))
-
-(define-method parse-url-body ((string <string>) (default-url <rmail-url>))
- (make-rmail-url
- (parse-file-url-body string (file-url-pathname default-url))))
+(define make-rmail-url (pathname-url-constructor <rmail-url>))
+
+(define-pathname-url-predicate <rmail-url>
+ (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 <rmail-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 <rmail-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 <rmail-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 '#())
(write-rmail-message message port))))))
(define-method append-message-to-file ((message <message>) (url <rmail-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)
;;; -*-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
;;;
Specifies a folder on an IMAP server. The portions in brackets
are optional and are filled in automatically if omitted.
-rmail:<pathname>
- Specifies an RMAIL file.
-
-umail:<pathname>
- Specifies a unix mail file.
+file:<pathname>
+ 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
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
(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)
(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))
"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)
(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?
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))
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
(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)))
\f
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)
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)
+\f
+(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))
(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))))
(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)))
\f
;;; -*-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
;;;
;;;; URL
(define-class <umail-url> (<file-url>))
-(define-url-protocol "umail" <umail-url>)
-
-(define make-umail-url
- (let ((constructor (instance-constructor <umail-url> '(PATHNAME))))
- (lambda (pathname)
- (intern-url (constructor (merge-pathnames pathname))))))
-
-(define-method parse-url-body ((string <string>) (default-url <umail-url>))
- (make-umail-url
- (parse-file-url-body string (file-url-pathname default-url))))
+(define make-umail-url (pathname-url-constructor <umail-url>))
+
+(define-pathname-url-predicate <umail-url>
+ (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 <umail-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 <umail-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 <umail-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 '#())
(folder-modification-count folder))
(save-folder folder)))
-(define (read-umail-file pathname)
- (make-umail-folder (make-umail-url pathname)))
-
;;;; Folder
(define-class (<umail-folder> (constructor (url))) (<file-folder>))
(write-umail-message message #t port))))))
(define-method append-message-to-file ((message <message>) (url <umail-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)))
projects / mit-scheme.git / commitdiff