From: Chris Hanson Date: Sat, 10 Jun 2000 20:18:06 +0000 (+0000) Subject: If server supports the NAMESPACE extension, use it to get namespace X-Git-Tag: 20090517-FFI~3557 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=163cf38ca5737f0f4f07b807d8e65dbd1d4e2447;p=mit-scheme.git If server supports the NAMESPACE extension, use it to get namespace information and store it in the connection object. --- diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 4e0e19538..7d6d6b9d5 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.114 2000/06/05 21:30:40 cph Exp $ +;;; $Id: imail-imap.scm,v 1.115 2000/06/10 20:17:57 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -67,7 +67,7 @@ (substring-downcase! mailbox 0 6) mailbox)) (else mailbox))) - + (define-method url-body ((url )) (make-imap-url-string (imap-url-user-id url) (imap-url-host url) @@ -212,6 +212,7 @@ (port define standard initial-value #f) (greeting define standard initial-value #f) (capabilities define standard initial-value '()) + (namespace define standard initial-value #f) (sequence-number define standard initial-value 0) (response-queue define accessor initializer (lambda () (cons '() '()))) (folder define standard initial-value #f) @@ -228,6 +229,7 @@ (lambda () (set-imap-connection-greeting! connection #f) (set-imap-connection-capabilities! connection '()) + (set-imap-connection-namespace! connection #f) (set-imap-connection-sequence-number! connection 0) (let ((queue (imap-connection-response-queue connection))) (set-car! queue '()) @@ -356,6 +358,8 @@ (imail-ui:delete-stored-pass-phrase url) (error "Unable to log in:" (imap:response:response-text-string response)))))) + (if (memq 'NAMESPACE (imap-connection-capabilities connection)) + (imap:command:namespace connection)) #t))) (define (test-imap-connection-open connection) @@ -708,11 +712,9 @@ (receiver (imap-folder-connection folder)))))) ;;; These reflectors are needed to guarantee that we read the -;;; appropriate information from the server. Normally most message -;;; slots are filled in by READ-MESSAGE-HEADERS!, but it's possible -;;; for READ-MESSAGE-HEADERS! to be interrupted, leaving unfilled -;;; slots. Also, we don't want to fill the BODY slot until it is -;;; requested, as the body might be very large. +;;; appropriate information from the server. Some message slots are +;;; filled in by READ-MESSAGE-HEADERS!, but it's possible for +;;; READ-MESSAGE-HEADERS! to be interrupted, leaving unfilled slots. (let ((accessor (slot-accessor 'UID)) (initpred (slot-initpred 'UID))) @@ -786,7 +788,7 @@ '(ENVELOPE)))) (reflector imap-message-bodystructure 'BODYSTRUCTURE (lambda (message initpred) - (guarantee-slot-initialized message initpred "bodystructure" + (guarantee-slot-initialized message initpred "body structure" '(BODYSTRUCTURE))))) ;;;; MIME support @@ -1152,6 +1154,9 @@ (define (imap:command:capability connection) (imap:command:no-response connection 'CAPABILITY)) +(define (imap:command:namespace connection) + (imap:command:no-response connection 'NAMESPACE)) + (define (imap:command:login connection user-id pass-phrase) ((imail-ui:message-wrapper "Logging in as " user-id) (lambda () @@ -1463,6 +1468,9 @@ connection (imap:response:capabilities response)) #f) + ((imap:response:namespace? response) + (set-imap-connection-namespace! connection response) + #f) ((imap:response:list? response) (eq? command 'LIST)) ((imap:response:lsub? response) diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg index e7465f06b..f527c5e9a 100644 --- a/v7/src/imail/imail.pkg +++ b/v7/src/imail/imail.pkg @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail.pkg,v 1.53 2000/06/09 04:17:52 cph Exp $ +;;; $Id: imail.pkg,v 1.54 2000/06/10 20:17:55 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -171,6 +171,10 @@ imap:response:list-mailbox imap:response:list? imap:response:lsub? + imap:response:namespace-other + imap:response:namespace-personal + imap:response:namespace-shared + imap:response:namespace? imap:response:no? imap:response:ok? imap:response:preauth? diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm index 04349caa7..ca5cce4ca 100644 --- a/v7/src/imail/imap-response.scm +++ b/v7/src/imail/imap-response.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imap-response.scm,v 1.33 2000/06/01 20:07:07 cph Exp $ +;;; $Id: imap-response.scm,v 1.34 2000/06/10 20:18:06 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -66,6 +66,7 @@ ((SEARCH) (read-search-response port)) ((STATUS) (read-status-response port)) ((CAPABILITY) (read-capability-response port)) + ((NAMESPACE) (read-namespace-response port)) (else (error "Malformed response code:" x)))))))) (define (read-tagged-response tag port) @@ -102,6 +103,14 @@ (define (read-capability-response port) (read-open-list read-interned-atom port)) +(define (read-namespace-response port) + (discard-known-char #\space port) + (let ((ns1 (read-generic port))) + (discard-known-char #\space port) + (let ((ns2 (read-generic port))) + (discard-known-char #\space port) + (list ns1 ns2 (read-generic port))))) + (define (read-response-text port) (discard-known-char #\space port) (let ((code @@ -597,6 +606,7 @@ (define (imap:response:flags? response) (eq? (car response) 'FLAGS)) (define (imap:response:list? response) (eq? (car response) 'LIST)) (define (imap:response:lsub? response) (eq? (car response) 'LSUB)) +(define (imap:response:namespace? response) (eq? (car response) 'NAMESPACE)) (define (imap:response:no? response) (eq? (car response) 'NO)) (define (imap:response:ok? response) (eq? (car response) 'OK)) (define (imap:response:preauth? response) (eq? (car response) 'PREAUTH)) @@ -612,6 +622,9 @@ (define imap:response:list-delimiter cadr) (define imap:response:list-mailbox caddr) (define imap:response:list-flags cdddr) +(define imap:response:namespace-personal cadr) +(define imap:response:namespace-other caddr) +(define imap:response:namespace-shared cadddr) (define imap:response:recent-count cadr) (define imap:response:search-indices cdr)