From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 17 May 2001 04:00:04 +0000 (+0000)
Subject: Split the IMAP URL type into two types: one for IMAP folders, and the
X-Git-Tag: 20090517-FFI~2821
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=403e0bdca9585a57483e65c2709e5b5e4f55fad0;p=mit-scheme.git
Split the IMAP URL type into two types: one for IMAP folders, and the
other for IMAP containers. The two are distinguished solely by the
form of their mailbox names: a trailing slash (or null mailbox) means
it's a container, otherwise it's a folder.
---
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 18adf20e2..f56d7d3e9 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.151 2001/05/15 19:46:54 cph Exp $
+;;; $Id: imail-imap.scm,v 1.152 2001/05/17 04:00:04 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
@@ -25,7 +25,7 @@
;;;; URL
-(define-class <imap-url> (<folder-url> <container-url>)
+(define-class <imap-url> (<url>)
;; User name to connect as.
(user-id define accessor)
;; Name or IP address of host to connect to.
@@ -36,35 +36,31 @@
(mailbox define accessor))
(define-url-protocol "imap" <imap-url>)
+(define-class <imap-folder-url> (<imap-url> <folder-url>))
+(define-class <imap-container-url> (<imap-url> <container-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 make-imap-url
+ (let ((fields '(USER-ID HOST PORT MAILBOX)))
+ (let ((make-folder (instance-constructor <imap-folder-url> fields))
+ (make-container (instance-constructor <imap-container-url> fields)))
+ (lambda (user-id host port mailbox)
+ (intern-url
+ ((if (or (string-null? mailbox) (string-suffix? "/" mailbox))
+ make-container
+ make-folder)
+ user-id
+ (string-downcase host)
+ port
+ (canonicalize-imap-mailbox mailbox)))))))
-(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 (imap-url-new-mailbox url mailbox)
+ (make-imap-url (imap-url-user-id url)
+ (imap-url-host url)
+ (imap-url-port url)
+ mailbox))
-(define make-imap-url
- (let ((constructor
- (instance-constructor <imap-url> '(USER-ID HOST PORT MAILBOX))))
- (lambda (user-id host port mailbox)
- (intern-url
- (constructor user-id
- (string-downcase host)
- port
- (canonicalize-imap-mailbox mailbox))))))
+(define-method url-body ((url <imap-url>))
+ (make-imap-url-string url (imap-url-mailbox url)))
(define (make-imap-url-string url mailbox)
(string-append "//"
@@ -91,12 +87,6 @@
(substring-downcase! mailbox 0 5)
mailbox))
(else mailbox)))
-
-(define-method url-body ((url <imap-url>))
- (make-imap-url-string url (imap-url-mailbox url)))
-
-(define-method url-presentation-name ((url <imap-url>))
- (url-base-name url))
(define (compatible-imap-urls? url1 url2)
;; Can URL1 and URL2 both be accessed from the same IMAP session?
@@ -104,29 +94,55 @@
(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 <imap-url>))
+ (and (imap-url-info url) #t))
+
+(define-method url-is-selectable? ((url <imap-folder-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-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-url>))
+(define-method url-base-name ((url <imap-folder-url>))
(let ((mailbox (imap-url-mailbox url)))
- (let ((index (string-search-backward "/" mailbox)))
+ (let ((index (string-find-previous-char mailbox #\/)))
(if index
- (string-tail mailbox index)
+ (string-tail mailbox (fix:+ index 1))
mailbox))))
-(define (imap-url-new-mailbox url mailbox)
- (make-imap-url (imap-url-user-id url)
- (imap-url-host url)
- (imap-url-port url)
- mailbox))
-
-(define-method make-peer-url ((url <imap-url>) base-name)
- (let ((url (url-container url)))
- (imap-url-new-mailbox
- url
- (string-append (imap-url-mailbox url) "/" base-name))))
-
+(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)))
+
(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)
@@ -160,13 +176,22 @@
(imap-url-mailbox default-url)))
(values #f #f #f #f))))))
+;;;; Container heirarchy
+
(define-method url-container ((url <imap-url>))
(imap-url-new-mailbox
url
(let ((mailbox (imap-url-mailbox url)))
- (let ((index (string-find-previous-char mailbox #\/)))
+ (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 index)
+ (string-head mailbox (fix:+ index 1))
(or (get-personal-namespace url) ""))))))
(define (get-personal-namespace url)
@@ -187,19 +212,12 @@
(let ((prefix (imap:decode-mailbox-name (caar namespace)))
(delimiter (cadar namespace)))
(if delimiter
- (let ((base
- (if (string-suffix? delimiter prefix)
- (string-head prefix
- (fix:- (string-length prefix) 1))
- prefix)))
- (if (string-ci=? "inbox" base)
- "inbox"
- (string-replace base
- (string-ref delimiter 0)
- #\/)))
+ (if (string-ci=? "inbox/" prefix)
+ "inbox/"
+ (string-replace prefix (string-ref delimiter 0) #\/))
prefix)))))))
-(define-method container-url-contents ((url <imap-url>))
+(define-method container-url-contents ((url <imap-container-url>))
(with-open-imap-connection url
(lambda (connection)
(map (lambda (response)
@@ -212,18 +230,15 @@
(if delimiter
(string-replace mailbox (string-ref delimiter 0) #\/)
mailbox))))
- (imap:command:list connection
- ""
- (string-append
- (imap-mailbox/url->server
- url
- (let ((mailbox (imap-url-mailbox url)))
- (if (or (string-null? mailbox)
- (string-suffix? "/" mailbox))
- mailbox
- (string-append mailbox "/"))))
- "%"))))))
+ (imap:command:list
+ connection
+ ""
+ (string-append (imap-mailbox/url->server url
+ (imap-url-mailbox url))
+ "%"))))))
+;;;; Completion
+
(define-method %url-complete-string
((string <string>) (default-url <imap-url>)
if-unique if-not-unique if-not-found)
@@ -1273,7 +1288,7 @@
;;;; Folder operations
-(define-method %open-folder ((url <imap-url>))
+(define-method %open-folder ((url <imap-folder-url>))
(let ((folder
(make-imap-folder url
(or (search-imap-connections