;;; imap.el --- imap library
-;; Copyright (C) 1998-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: mail
;; imap-body-lines
;;
;; It is my hope that these commands should be pretty self
-;; explanatory for someone that know IMAP. All functions have
+;; explanatory for someone who knows IMAP. All functions have
;; additional documentation on how to invoke them.
;;
;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1). The implemented
;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
-;; LOGINDISABLED) (with use of external library starttls.el and
-;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731
+;; LOGINDISABLED), and the GSSAPI / Kerberos V4 sections of RFC1731
;; (with use of external program `imtest'), and RFC2971 (ID). It also
;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
;;
(eval-when-compile (require 'cl))
(eval-and-compile
;; For Emacs <22.2 and XEmacs.
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
- (autoload 'starttls-open-stream "starttls")
- (autoload 'starttls-negotiate "starttls")
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))
(autoload 'sasl-find-mechanism "sasl")
(autoload 'digest-md5-parse-digest-challenge "digest-md5")
(autoload 'digest-md5-digest-response "digest-md5")
(autoload 'utf7-encode "utf7")
(autoload 'utf7-decode "utf7")
(autoload 'format-spec "format-spec")
- (autoload 'format-spec-make "format-spec")
- (autoload 'open-tls-stream "tls"))
+ (autoload 'format-spec-make "format-spec"))
;; User variables.
:group 'imap
:type '(repeat string))
-(defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
- "openssl s_client -quiet -ssl2 -connect %s:%p"
- "s_client -quiet -ssl3 -connect %s:%p"
- "s_client -quiet -ssl2 -connect %s:%p")
- "A string, or list of strings, containing commands for SSL connections.
-Within a string, %s is replaced with the server address and %p with
-port number on server. The program should accept IMAP commands on
-stdin and return responses to stdout. Each entry in the list is tried
-until a successful connection is made."
- :group 'imap
- :type '(choice string
- (repeat string)))
-
(defcustom imap-shell-program '("ssh %s imapd"
"rsh %s imapd"
"ssh %g ssh %s imapd"
'((gssapi imap-gssapi-stream-p imap-gssapi-open)
(kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
(tls imap-tls-p imap-tls-open)
- (ssl imap-ssl-p imap-ssl-open)
+ (ssl imap-tls-p imap-tls-open)
(network imap-network-p imap-network-open)
(shell imap-shell-p imap-shell-open)
(starttls imap-starttls-p imap-starttls-open))
When non-nil, use an alternative UIDS form. Enabling appears to
be required for some servers (e.g., Microsoft Exchange 2007)
-which otherwise would trigger a response 'BAD The specified
+which otherwise would trigger a response `BAD The specified
message set is invalid.'. We don't unconditionally use this
form, since this is said to be significantly inefficient.
nil)))))
done))
-(defun imap-ssl-p (buffer)
- nil)
-
-(defun imap-ssl-open (name buffer server port)
- "Open an SSL connection to SERVER."
- (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
- (list imap-ssl-program)))
- cmd done)
- (while (and (not done) (setq cmd (pop cmds)))
- (message "imap: Opening SSL connection with `%s'..." cmd)
- (erase-buffer)
- (let* ((port (or port imap-default-ssl-port))
- (coding-system-for-read imap-coding-system-for-read)
- (coding-system-for-write imap-coding-system-for-write)
- (process-connection-type imap-process-connection-type)
- (set-process-query-on-exit-flag
- (if (fboundp 'set-process-query-on-exit-flag)
- 'set-process-query-on-exit-flag
- 'process-kill-without-query))
- process)
- (when (progn
- (setq process (start-process
- name buffer shell-file-name
- shell-command-switch
- (format-spec cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)))))
- (funcall set-process-query-on-exit-flag process nil)
- process)
- (with-current-buffer buffer
- (goto-char (point-min))
- (while (and (memq (process-status process) '(open run))
- (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
- (goto-char (point-max))
- (forward-line -1)
- (not (imap-parse-greeting)))
- (accept-process-output process 1)
- (sit-for 1))
- (imap-log buffer)
- (erase-buffer)
- (when (memq (process-status process) '(open run))
- (setq done process))))))
- (if done
- (progn
- (message "imap: Opening SSL connection with `%s'...done" cmd)
- done)
- (message "imap: Opening SSL connection with `%s'...failed" cmd)
- nil)))
-
-(defun imap-tls-p (buffer)
+(defun imap-tls-p (_buffer)
nil)
(defun imap-tls-open (name buffer server port)
(let* ((port (or port imap-default-tls-port))
(coding-system-for-read imap-coding-system-for-read)
(coding-system-for-write imap-coding-system-for-write)
- (process (open-tls-stream name buffer server port)))
+ (process (open-network-stream name buffer server port
+ :type 'tls)))
(when process
(while (and (memq (process-status process) '(open run))
;; FIXME: Per the "blue moon" comment, the process/buffer
(when (memq (process-status process) '(open run))
process))))
-(defun imap-network-p (buffer)
+(defun imap-network-p (_buffer)
t)
(defun imap-network-open (name buffer server port)
(when (memq (process-status process) '(open run))
process))))
-(defun imap-shell-p (buffer)
+(defun imap-shell-p (_buffer)
nil)
(defun imap-shell-open (name buffer server port)
(imap-capability 'STARTTLS buffer))
(defun imap-starttls-open (name buffer server port)
+ (message "imap: Connecting with STARTTLS...")
(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 (starttls-open-stream name buffer server port))
- done tls-info)
- (message "imap: Connecting with STARTTLS...")
+ (process (open-network-stream
+ name buffer server port
+ :type 'starttls
+ :capability-command "1 CAPABILITY\r\n"
+ :always-query-capabilities t
+ :end-of-command "\r\n"
+ :success "^1 OK "
+ :starttls-function
+ #'(lambda (capabilities)
+ (when (string-match-p "STARTTLS" capabilities)
+ "1 STARTTLS\r\n"))))
+ done)
(when process
- (while (and (memq (process-status process) '(open run))
- (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
- (goto-char (point-max))
- (forward-line -1)
- (not (imap-parse-greeting)))
- (accept-process-output process 1)
- (sit-for 1))
- (imap-send-command "STARTTLS")
- (while (and (memq (process-status process) '(open run))
- (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
- (goto-char (point-max))
- (forward-line -1)
- (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
- (accept-process-output process 1)
- (sit-for 1))
(imap-log buffer)
- (when (and (setq tls-info (starttls-negotiate process))
- (memq (process-status process) '(open run)))
- (setq done process)))
- (if (stringp tls-info)
- (message "imap: STARTTLS info: %s" tls-info))
+ (when (memq (process-status process) '(open run))
+ (setq done process)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (imap-parse-greeting))))
(message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
done))
(defun imap-interactive-login (buffer loginfunc)
"Login to server in BUFFER.
-LOGINFUNC is passed a username and a password, it should return t if
-it where successful authenticating itself to the server, nil otherwise.
-Returns t if login was successful, nil otherwise."
+Return t if login was successful, nil otherwise.
+
+LOGINFUNC is passed a username and a password. It should return
+t if it successfully authenticates, nil otherwise."
(with-current-buffer buffer
(make-local-variable 'imap-username)
(make-local-variable 'imap-password)
(while (or (not user) (not passwd))
(setq user (or imap-username
(read-from-minibuffer
- (concat "imap: username for " imap-server
- " (using stream `" (symbol-name imap-stream)
- "'): ")
+ (format-message
+ "imap: username for %s (using stream `%s'): "
+ imap-server imap-stream)
(or user imap-default-user))))
- (setq passwd (or imap-password
- (read-passwd
- (concat "imap: password for " user "@"
- imap-server " (using authenticator `"
- (symbol-name imap-auth) "'): "))))
+ (setq passwd
+ (or imap-password
+ (read-passwd
+ (format-message
+ "imap: password for %s@%s (using authenticator `%s'): "
+ user imap-server imap-auth))))
(when (and user passwd)
(if (funcall loginfunc user passwd)
(progn
;; passwd nil))))
ret)))
-(defun imap-gssapi-auth-p (buffer)
+(defun imap-gssapi-auth-p (_buffer)
(eq imap-stream 'gssapi))
-(defun imap-gssapi-auth (buffer)
+(defun imap-gssapi-auth (_buffer)
(message "imap: Authenticating using GSSAPI...%s"
(if (eq imap-stream 'gssapi) "done" "failed"))
(eq imap-stream 'gssapi))
(and (imap-capability 'AUTH=KERBEROS_V4 buffer)
(eq imap-stream 'kerberos4)))
-(defun imap-kerberos4-auth (buffer)
+(defun imap-kerberos4-auth (_buffer)
(message "imap: Authenticating using Kerberos 4...%s"
(if (eq imap-stream 'kerberos4) "done" "failed"))
(eq imap-stream 'kerberos4))
(imap-quote-specials passwd)
"\""))))))
-(defun imap-anonymous-p (buffer)
+(defun imap-anonymous-p (_buffer)
t)
(defun imap-anonymous-auth (buffer)
(defun imap-authenticate (&optional user passwd buffer)
"Authenticate to server in BUFFER, using current buffer if nil.
-It uses the authenticator specified when opening the server. If the
-authenticator requires username/passwords, they are queried from the
-user and optionally stored in the buffer. If USER and/or PASSWD is
-specified, the user will not be questioned and the username and/or
-password is remembered in the buffer."
+It uses the authenticator specified when opening the server.
+
+Optional arguments USER and PASSWD specify the username and
+password to use if the authenticator requires a username and/or
+password. If omitted or nil, the authenticator may query the
+user for a username and/or password."
(with-current-buffer (or buffer (current-buffer))
(if (not (eq imap-state 'nonauth))
(or (eq imap-state 'auth)
(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
"Return a list of subscribed mailboxes on server in BUFFER.
If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
-non-nil, a hierarchy delimiter is added to root. REFERENCE is a
+non-nil, a hierarchy delimiter is added to root. REFERENCE is an
implementation-specific string that has to be passed to lsub command."
(with-current-buffer (or buffer (current-buffer))
;; Make sure we know the hierarchy separator for root's hierarchy
(defun imap-mailbox-list (root &optional reference add-delimiter buffer)
"Return a list of mailboxes matching ROOT on server in BUFFER.
If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
-root. REFERENCE is a implementation-specific string that has to be
+root. REFERENCE is an implementation-specific string that has to be
passed to list command."
(with-current-buffer (or buffer (current-buffer))
;; Make sure we know the hierarchy separator for root's hierarchy
(imap-mailbox-get items mailbox)))))
(defun imap-mailbox-status-asynch (mailbox items &optional buffer)
- "Send status item request ITEM on MAILBOX to server in BUFFER.
+ "Send status item requests ITEMS on MAILBOX to server in BUFFER.
ITEMS can be a symbol or a list of symbols, valid symbols are one of
-the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity
-or 'unseen. The IMAP command tag is returned."
+the STATUS data items -- i.e., `messages', `recent', `uidnext', `uidvalidity'
+or `unseen'. The IMAP command tag is returned."
(with-current-buffer (or buffer (current-buffer))
(imap-send-command (list "STATUS \""
(imap-utf7-encode mailbox)
rights))))))
(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
- "Remove any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
+ "Remove <id,rights> pairs for IDENTIFIER from MAILBOX on server in BUFFER."
(let ((mailbox (imap-utf7-encode mailbox)))
(with-current-buffer (or buffer (current-buffer))
(imap-ok-p
(defun imap-fetch (uids props &optional receive nouidfetch buffer)
"Fetch properties PROPS from message set UIDS from server in BUFFER.
-UIDS can be a string, number or a list of numbers. If RECEIVE
-is non-nil return these properties."
+UIDS can be a string, number or a list of numbers. If RECEIVE is
+non-nil, return these properties."
(with-current-buffer (or buffer (current-buffer))
(when (imap-ok-p (imap-send-command-wait
(format "%sFETCH %s %s" (if nouidfetch "" "UID ")
(imap-mailbox-get-1 'search imap-current-mailbox)))))
(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
- "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
+ "Return t if FLAG can be permanently saved on articles.
+MAILBOX specifies a mailbox on the server in BUFFER."
(with-current-buffer (or buffer (current-buffer))
(or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
(member flag (imap-mailbox-get 'permanentflags mailbox)))))
(and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
- (lambda (uid prop) uid) 'UID))))
+ (lambda (uid _prop) uid) 'UID))))
(if old-mailbox
(imap-mailbox-select old-mailbox (eq state 'examine))
(imap-mailbox-unselect)))))))
(and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
- (lambda (uid prop) uid) 'UID))))
+ (lambda (uid _prop) uid) 'UID))))
(if old-mailbox
(imap-mailbox-select old-mailbox (eq state 'examine))
(imap-mailbox-unselect)))))))
(with-current-buffer (or buffer (current-buffer))
(imap-message-appenduid-1 (imap-utf7-encode mailbox))))
-(defun imap-message-append (mailbox article &optional flags date-time buffer)
+(defun imap-message-append (mailbox article &optional _flags _date-time buffer)
"Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
FLAGS and DATE-TIME is currently not used. Return a cons holding
uidvalidity of MAILBOX and UID the newly created article got, or nil
0))
(defun imap-envelope-from (from)
- "Return a from string line."
+ "Return a FROM string line."
(and from
(concat (aref from 0)
(if (aref from 0) " <")
;; ; capability.
(defun imap-parse-response ()
- "Parse a IMAP command response."
+ "Parse an IMAP command response."
(let (token)
(case (setq token (read (current-buffer)))
(+ (setq imap-continuation
imap-error-text
imap-kerberos4s-p
imap-kerberos4-open
- imap-ssl-p
- imap-ssl-open
imap-network-p
imap-network-open
imap-interactive-login