;;; imap.el --- imap library
-;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
;;
;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
-;; (NAMESPACE), RFC2359 (UIDPLUS), and the kerberos V4 part of RFC1731
-;; (with use of external program `imtest'). It also take advantage
-;; the UNSELECT extension in Cyrus IMAPD.
+;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS)
+;; (with use of external library starttls.el and program starttls) and
+;; the GSSAPI / kerberos V4 sections of RFC1731 (with use of external
+;; program `imtest'). It also take advantage the UNSELECT extension
+;; in Cyrus IMAPD.
;;
;; Without the work of John McClary Prevost and Jim Radford this library
;; would not have seen the light of day. Many thanks.
;; o Don't use `read' at all (important places already fixed)
;; o Accept list of articles instead of message set string in most
;; imap-message-* functions.
-;; o Cyrus IMAPd 1.6.x `imtest' support in the imtest wrapper
;;
;; Revision history:
;;
;; User variables.
-(defvar imap-imtest-program "imtest -kp %s %p"
- "How to call program for Kerberos 4 authentication.
-%s is replaced with server and %p with port to connect to. The
-program should accept IMAP commands on stdin and return responses to
-stdout.")
+(defvar imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
+ "imtest -kp %s %p")
+ "List of strings containing commands for Kerberos 4 authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'. The program should accept
+IMAP commands on stdin and return responses to stdout.")
+
+(defvar imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s")
+ "List of strings containing commands for GSSAPI (krb5) authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'. The program should accept
+IMAP commands on stdin and return responses to stdout.")
(defvar imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p"
"openssl s_client -ssl2 -connect %s:%p"
(defvar imap-fetch-data-hook nil
"Hooks called after receiving each FETCH response.")
-(defvar imap-streams '(kerberos4 starttls ssl network)
+(defvar imap-streams '(gssapi kerberos4 starttls ssl network)
"Priority of streams to consider when opening connection to server.")
(defvar imap-stream-alist
- '((kerberos4 imap-kerberos4s-p imap-kerberos4-open)
- (ssl imap-ssl-p imap-ssl-open)
- (network imap-network-p imap-network-open)
- (starttls imap-starttls-p imap-starttls-open))
+ '((gssapi imap-gssapi-stream-p imap-gssapi-open)
+ (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
+ (ssl imap-ssl-p imap-ssl-open)
+ (network imap-network-p imap-network-open)
+ (starttls imap-starttls-p imap-starttls-open))
"Definition of network streams.
(NAME CHECK OPEN)
server support the stream and OPEN is a function for opening the
stream.")
-(defvar imap-authenticators '(kerberos4 digest-md5 cram-md5 login anonymous)
+(defvar imap-authenticators '(gssapi
+ kerberos4
+ digest-md5
+ cram-md5
+ login
+ anonymous)
"Priority of authenticators to consider when authenticating to server.")
(defvar imap-authenticator-alist
- '((kerberos4 imap-kerberos4a-p imap-kerberos4-auth)
- (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
- (login imap-login-p imap-login-auth)
- (anonymous imap-anonymous-p imap-anonymous-auth)
- (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
+ '((gssapi imap-gssapi-auth-p imap-gssapia-auth)
+ (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth)
+ (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
+ (login imap-login-p imap-login-auth)
+ (anonymous imap-anonymous-p imap-anonymous-auth)
+ (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
"Definition of authenticators.
(NAME CHECK AUTHENTICATE)
\f
;; Server functions; stream stuff:
-(defun imap-kerberos4s-p (buffer)
+(defun imap-kerberos4-stream-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(defun imap-kerberos4-open (name buffer server port)
- (message "Opening Kerberized IMAP connection...")
- (let* ((port (or port imap-default-port))
- (coding-system-for-read imap-coding-system-for-read)
- (coding-system-for-write imap-coding-system-for-write)
- (process (start-process
- name buffer shell-file-name shell-command-switch
- (format-spec
- imap-imtest-program
- (format-spec-make ?s server ?p (number-to-string port))))))
- (when process
- (with-current-buffer buffer
- (setq imap-client-eol "\n")
- ;; Result of authentication is a string: __Full privacy protection__
- (while (and (memq (process-status process) '(open run))
- (goto-char (point-min))
- (not (and (imap-parse-greeting)
- (re-search-forward "__\\(.*\\)__\n" nil t))))
- (accept-process-output process 1)
- (sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
- (let ((response (match-string 1)))
- (erase-buffer)
- (message "Kerberized IMAP connection: %s" response)
- (if (and response (let ((case-fold-search nil))
- (not (string-match "failed" response))))
- process
- (if (memq (process-status process) '(open run))
- (imap-send-command-wait "LOGOUT"))
- (delete-process process)
- nil))))))
+ (let ((cmds imap-kerberos4-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n")
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+ (or (while (looking-at "^C:")
+ (forward-line))
+ t)
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest < 1.6:
+ (or (re-search-forward
+ "^__\\(.*\\)__\n" nil t)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ "^\\(Authenticat.*\\)" nil t))
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "Kerberos 4 IMAP connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+(defun imap-gssapi-stream-p (buffer)
+ (imap-capability 'AUTH=GSSAPI buffer))
+
+(defun imap-gssapi-open (name buffer server port)
+ (let ((cmds imap-gssapi-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n")
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ "^\\(Authenticat.*\\)" nil t)
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "GSSAPI IMAP connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+
(defun imap-ssl-p (buffer)
nil)
(unwind-protect
(progn
(set-process-filter imap-process 'imap-arrival-filter)
- (when (and (eq imap-stream 'tls)
+ (when (and (eq imap-stream 'starttls)
(imap-ok-p (imap-send-command-wait "STARTTLS")))
(starttls-negotiate imap-process)))
(set-process-filter imap-process nil)))
;; passwd nil))))
ret)))
-(defun imap-kerberos4a-p (buffer)
+(defun imap-gssapi-auth-p (buffer)
+ (imap-capability 'AUTH=GSSAPI buffer))
+
+(defun imap-gssapi-auth (buffer)
+ (eq imap-stream 'gssapi))
+
+(defun imap-kerberos4-auth-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(defun imap-kerberos4-auth (buffer)
(imap-utf7-decode
(imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
+(defun imap-mailbox-examine-1 (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-select-1 mailbox 'exmine)))
+
(defun imap-mailbox-examine (mailbox &optional buffer)
"Examine MAILBOX on server in BUFFER."
(imap-mailbox-select mailbox 'exmine buffer))
(list items))))))
(if (listp items)
(mapcar (lambda (item)
- (imap-mailbox-get-1 item mailbox))
+ (imap-mailbox-get item mailbox))
items)
- (imap-mailbox-get-1 items mailbox)))))
+ (imap-mailbox-get items mailbox)))))
(defun imap-mailbox-acl-get (&optional mailbox buffer)
"Get ACL on mailbox from server in BUFFER."
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
(imap-message-data (make-vector 2 0)))
- (when (imap-mailbox-examine mailbox)
+ (when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch "*" "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
(imap-message-data (make-vector 2 0)))
- (when (imap-mailbox-examine mailbox)
+ (when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch "*" "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
"Return number of lines in article by looking at the mime bodystructure BODY."
(if (listp body)
(if (stringp (car body))
- (cond ((and (string= (car body) "TEXT")
+ ;; upcase for bug in courier imap server
+ (cond ((and (string= (upcase (car body)) "TEXT")
(numberp (nth 7 body)))
(nth 7 body))
- ((and (string= (car body) "MESSAGE")
+ ((and (string= (upcase (car body)) "MESSAGE")
(numberp (nth 9 body)))
(nth 9 body))
(t 0))
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
(setq command nil);; abort command if no cont-req
(let ((process imap-process)
- (stream imap-stream))
+ (stream imap-stream)
+ (eol imap-client-eol))
(with-current-buffer cmd
- (when (eq stream 'kerberos4)
+ (when (not (equal eol "\r\n"))
;; XXX modifies buffer!
(goto-char (point-min))
(while (search-forward "\r\n" nil t)
- (replace-match "\n")))
+ (replace-match eol)))
(and imap-log
(with-current-buffer (get-buffer-create
imap-log)
(if (< (point-max) (+ pos len))
nil
(goto-char (+ pos len))
- (buffer-substring-no-properties pos (+ pos len))))))
+ (buffer-substring pos (+ pos len))))))
;; string = quoted / literal
;;
;; TEXT-CHAR = <any CHAR except CR and LF>
(defsubst imap-parse-string ()
- (let (strstart strend)
- (cond ((and (eq (char-after) ?\")
- (setq strstart (point))
- (setq strend (search-forward "\"" nil t 2)))
- (buffer-substring-no-properties (1+ strstart) (1- strend)))
- ((eq (char-after) ?{)
- (imap-parse-literal)))))
+ (cond ((eq (char-after) ?\")
+ (forward-char 1)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^\"\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^\"\\\\")
+ (setq name (concat name (buffer-substring p (point)))))
+ (forward-char 1)
+ name))
+ ((eq (char-after) ?{)
+ (imap-parse-literal))))
;; nil = "NIL"
;; ; revisions of this specification.
(defun imap-parse-flag-list ()
- (let ((str (buffer-substring-no-properties
- (point) (search-forward ")" nil t)))
+ (let ((str (buffer-substring (point) (search-forward ")" nil t)))
pos)
(while (setq pos (string-match "\\\\" str (and pos (+ 2 pos))))
(setq str (replace-match "\\\\" nil t str)))
imap-current-mailbox-p
imap-mailbox-select-1
imap-mailbox-select
+ imap-mailbox-examine-1
imap-mailbox-examine
imap-mailbox-unselect
imap-mailbox-expunge
projects / gnus / blobdiff