Mercurial > emacs
view lisp/gnus/imap.el @ 36419:50998d3dd0bb
(lpr-page-header-switches, print-region-1): Undo 2000-07-06 change.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Tue, 27 Feb 2001 19:07:09 +0000 |
parents | be95f43e08db |
children | c545df001cd2 |
line wrap: on
line source
;;; imap.el --- imap library ;; Copyright (C) 1998, 1999, 2000 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson <jas@pdc.kth.se> ;; Keywords: mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; imap.el is a elisp library providing an interface for talking to ;; IMAP servers. ;; ;; imap.el is roughly divided in two parts, one that parses IMAP ;; responses from the server and storing data into buffer-local ;; variables, and one for utility functions which send commands to ;; server, waits for an answer, and return information. The latter ;; part is layered on top of the previous. ;; ;; The imap.el API consist of the following functions, other functions ;; in this file should not be called directly and the result of doing ;; so are at best undefined. ;; ;; Global commands: ;; ;; imap-open, imap-opened, imap-authenticate, imap-close, ;; imap-capability, imap-namespace, imap-error-text ;; ;; Mailbox commands: ;; ;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox, ;; imap-current-mailbox-p, imap-search, imap-mailbox-select, ;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge ;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete ;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status ;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete ;; ;; Message commands: ;; ;; imap-fetch-asynch, imap-fetch, ;; imap-current-message, imap-list-to-message-set, ;; imap-message-get, imap-message-map ;; imap-message-envelope-date, imap-message-envelope-subject, ;; imap-message-envelope-from, imap-message-envelope-sender, ;; imap-message-envelope-reply-to, imap-message-envelope-to, ;; imap-message-envelope-cc, imap-message-envelope-bcc ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id ;; imap-message-body, imap-message-flag-permanent-p ;; imap-message-flags-set, imap-message-flags-del ;; imap-message-flags-add, imap-message-copyuid ;; imap-message-copy, imap-message-appenduid ;; imap-message-append, imap-envelope-from ;; imap-body-lines ;; ;; It is my hope that theese commands should be pretty self ;; explanatory for someone that know IMAP. All functions have ;; additional documentation on how to invoke them. ;; ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), 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 ;; (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. ;; ;; This is a transcript of short interactive session for demonstration ;; purposes. ;; ;; (imap-open "my.mail.server") ;; => " *imap* my.mail.server:0" ;; ;; The rest are invoked with current buffer as the buffer returned by ;; `imap-open'. It is possible to do all without this, but it would ;; look ugly here since `buffer' is always the last argument for all ;; imap.el API functions. ;; ;; (imap-authenticate "myusername" "mypassword") ;; => auth ;; ;; (imap-mailbox-lsub "*") ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam") ;; ;; (imap-mailbox-list "INBOX.n%") ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq") ;; ;; (imap-mailbox-select "INBOX.nnimap") ;; => "INBOX.nnimap" ;; ;; (imap-mailbox-get 'exists) ;; => 166 ;; ;; (imap-mailbox-get 'uidvalidity) ;; => "908992622" ;; ;; (imap-search "FLAGGED SINCE 18-DEC-98") ;; => (235 236) ;; ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822) ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...." ;; ;; Todo: ;; ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. ;; 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. ;; ;; Revision history: ;; ;; - 19991218 added starttls/digest-md5 patch, ;; by Daiki Ueno <ueno@ueda.info.waseda.ac.jp> ;; NB! you need SLIM for starttls.el and digest-md5.el ;; - 19991023 commited to pgnus ;; ;;; Code: (eval-when-compile (require 'cl)) (eval-and-compile (autoload 'open-ssl-stream "ssl") (autoload 'base64-decode-string "base64") (autoload 'base64-encode-string "base64") (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") (autoload 'digest-md5-parse-digest-challenge "digest-md5") (autoload 'digest-md5-digest-response "digest-md5") (autoload 'digest-md5-digest-uri "digest-md5") (autoload 'digest-md5-challenge "digest-md5") (autoload 'rfc2104-hash "rfc2104") (autoload 'md5 "md5") (autoload 'utf7-encode "utf7") (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These ;; days we have point-at-eol anyhow. (if (fboundp 'point-at-eol) (defalias 'imap-point-at-eol 'point-at-eol) (defun imap-point-at-eol () (save-excursion (end-of-line) (point))))) ;; User variables. (defgroup imap nil "Low-level IMAP issues." :version "21.1" :group 'mail) (defcustom 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. Each entry in the list is tried until a successful connection is made." :group 'imap :type '(repeat string)) (defcustom 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. Each entry in the list is tried until a successful connection is made." :group 'imap :type '(repeat string)) (defcustom imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p" "openssl s_client -ssl2 -connect %s:%p" "s_client -ssl3 -connect %s:%p" "s_client -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" "rsh %g rsh %s imapd") "A list of strings, containing commands for IMAP connection. Within a string, %s is replaced with the server address, %p with port number on server, %g with `imap-shell-host', and %l with `imap-default-user'. The program should read IMAP commands from stdin and write IMAP response to stdout. Each entry in the list is tried until a successful connection is made." :group 'imap :type '(repeat string)) (defvar imap-shell-host "gateway" "Hostname of rlogin proxy.") (defvar imap-default-user (user-login-name) "Default username to use.") (defvar imap-error nil "Error codes from the last command.") ;; Various variables. (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") (defvar imap-streams '(gssapi kerberos4 starttls ssl network shell) "Priority of streams to consider when opening connection to server.") (defvar imap-stream-alist '((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) (shell imap-shell-p imap-shell-open) (starttls imap-starttls-p imap-starttls-open)) "Definition of network streams. (NAME CHECK OPEN) NAME names the stream, CHECK is a function returning non-nil if the server support the stream and OPEN is a function for opening the stream.") (defvar imap-authenticators '(gssapi kerberos4 digest-md5 cram-md5 login anonymous) "Priority of authenticators to consider when authenticating to server.") (defvar imap-authenticator-alist '((gssapi imap-gssapi-auth-p imap-gssapi-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) NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function for doing the actuall authentification.") (defvar imap-use-utf7 t "If non-nil, do utf7 encoding/decoding of mailbox names. Since the UTF7 decoding currently only decodes into ISO-8859-1 characters, you may disable this decoding if you need to access UTF7 encoded mailboxes which doesn't translate into ISO-8859-1.") ;; Internal constants. Change theese and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) (defconst imap-default-stream 'network) (defconst imap-coding-system-for-read 'binary) (defconst imap-coding-system-for-write 'binary) (defconst imap-local-variables '(imap-server imap-port imap-client-eol imap-server-eol imap-auth imap-stream imap-username imap-password imap-current-mailbox imap-current-target-mailbox imap-message-data imap-capability imap-namespace imap-state imap-reached-tag imap-failed-tags imap-tag imap-process imap-calculate-literal-size-first imap-mailbox-data)) ;; Internal variables. (defvar imap-stream nil) (defvar imap-auth nil) (defvar imap-server nil) (defvar imap-port nil) (defvar imap-username nil) (defvar imap-password nil) (defvar imap-calculate-literal-size-first nil) (defvar imap-state 'closed "IMAP state. Valid states are `closed', `initial', `nonauth', `auth', `selected' and `examine'.") (defvar imap-server-eol "\r\n" "The EOL string sent from the server.") (defvar imap-client-eol "\r\n" "The EOL string we send to the server.") (defvar imap-current-mailbox nil "Current mailbox name.") (defvar imap-current-target-mailbox nil "Current target mailbox for COPY and APPEND commands.") (defvar imap-mailbox-data nil "Obarray with mailbox data.") (defvar imap-mailbox-prime 997 "Length of imap-mailbox-data.") (defvar imap-current-message nil "Current message number.") (defvar imap-message-data nil "Obarray with message data.") (defvar imap-message-prime 997 "Length of imap-message-data.") (defvar imap-capability nil "Capability for server.") (defvar imap-namespace nil "Namespace for current server.") (defvar imap-reached-tag 0 "Lower limit on command tags that have been parsed.") (defvar imap-failed-tags nil "Alist of tags that failed. Each element is a list with four elements; tag (a integer), response state (a symbol, `OK', `NO' or `BAD'), response code (a string), and human readable response text (a string).") (defvar imap-tag 0 "Command tag number.") (defvar imap-process nil "Process.") (defvar imap-continuation nil "Non-nil indicates that the server emitted a continuation request. The actually value is really the text on the continuation line.") (defvar imap-log nil "Name of buffer for imap session trace. For example: (setq imap-log \"*imap-log*\")") (defvar imap-debug nil ;"*imap-debug*" "Name of buffer for random debug spew. For example: (setq imap-debug \"*imap-debug*\")") ;; Utility functions: (defsubst imap-disable-multibyte () "Enable multibyte in the current buffer." (when (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil))) (defun imap-read-passwd (prompt &rest args) "Read a password using PROMPT. If ARGS, PROMPT is used as an argument to `format'." (let ((prompt (if args (apply 'format prompt args) prompt))) (funcall (if (or (fboundp 'read-passwd) (and (load "subr" t) (fboundp 'read-passwd)) (and (load "passwd" t) (fboundp 'read-passwd))) 'read-passwd (autoload 'ange-ftp-read-passwd "ange-ftp") 'ange-ftp-read-passwd) prompt))) (defsubst imap-utf7-encode (string) (if imap-use-utf7 (and string (condition-case () (utf7-encode string t) (error (message "imap: Could not UTF7 encode `%s', using it unencoded..." string) string))) string)) (defsubst imap-utf7-decode (string) (if imap-use-utf7 (and string (condition-case () (utf7-decode string t) (error (message "imap: Could not UTF7 decode `%s', using it undecoded..." string) string))) string)) (defsubst imap-ok-p (status) (if (eq status 'OK) t (setq imap-error status) nil)) (defun imap-error-text (&optional buffer) (with-current-buffer (or buffer (current-buffer)) (nth 3 (car imap-failed-tags)))) ;; Server functions; stream stuff: (defun imap-kerberos4-stream-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) (defun imap-kerberos4-open (name buffer server port) (let ((cmds imap-kerberos4-program) cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd) (erase-buffer) (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" imap-calculate-literal-size-first t) (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 "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd (if response (concat "done, " 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.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: (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) (defun imap-ssl-open (name buffer server port) "Open a 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) (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) (ssl-program-name shell-file-name) (ssl-program-arguments (list shell-command-switch (format-spec cmd (format-spec-make ?s server ?p (number-to-string port))))) process) (when (setq process (ignore-errors (open-ssl-stream name buffer server port))) (with-current-buffer buffer (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) (goto-char (point-max)) (forward-line -1) (not (imap-parse-greeting))) (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) (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-network-p (buffer) t) (defun imap-network-open (name buffer server port) (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 (open-network-stream name buffer server port))) (when process (while (and (memq (process-status process) '(open run)) (goto-char (point-min)) (not (imap-parse-greeting))) (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))) (when (memq (process-status process) '(open run)) process)))) (defun imap-shell-p (buffer) nil) (defun imap-shell-open (name buffer server port) (let ((cmds imap-shell-program) cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening IMAP connection with `%s'..." cmd) (setq imap-client-eol "\n") (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 ?g imap-shell-host ?p (number-to-string port) ?l imap-default-user))))) (when process (while (and (memq (process-status process) '(open run)) (goto-char (point-min)) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) (erase-buffer) (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))) (when (memq (process-status process) '(open run)) (setq done process))))) (if done (progn (message "imap: Opening IMAP connection with `%s'...done" cmd) done) (message "imap: Opening IMAP connection with `%s'...failed" cmd) nil))) (defun imap-starttls-p (buffer) (and (imap-capability 'STARTTLS buffer) (condition-case () (progn (require 'starttls) (call-process "starttls")) (error nil)))) (defun imap-starttls-open (name buffer server port) (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) (message "imap: Connecting with STARTTLS...") (when process (while (and (memq (process-status process) '(open run)) (goto-char (point-min)) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) (and imap-log (with-current-buffer (get-buffer-create imap-log) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) (let ((imap-process process)) (unwind-protect (progn (set-process-filter imap-process 'imap-arrival-filter) (when (and (eq imap-stream 'starttls) (imap-ok-p (imap-send-command-wait "STARTTLS"))) (starttls-negotiate imap-process))) (set-process-filter imap-process nil))) (when (memq (process-status process) '(open run)) (setq done process))) (if done (progn (message "imap: Connecting with STARTTLS...done") done) (message "imap: Connecting with STARTTLS...failed") nil))) ;; Server functions; authenticator stuff: (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 sucessful authenticating itself to the server, nil otherwise. Returns t if login was successful, nil otherwise." (with-current-buffer buffer (make-variable-buffer-local 'imap-username) (make-variable-buffer-local 'imap-password) (let (user passwd ret) ;; (condition-case () (while (or (not user) (not passwd)) (setq user (or imap-username (read-from-minibuffer (concat "IMAP username for " imap-server ": ") (or user imap-default-user)))) (setq passwd (or imap-password (imap-read-passwd (concat "IMAP password for " user "@" imap-server ": ")))) (when (and user passwd) (if (funcall loginfunc user passwd) (progn (setq ret t imap-username user) (if (and (not imap-password) (y-or-n-p "Store password for this session? ")) (setq imap-password passwd))) (message "Login failed...") (setq passwd nil) (sit-for 1)))) ;; (quit (with-current-buffer buffer ;; (setq user nil ;; passwd nil))) ;; (error (with-current-buffer buffer ;; (setq user nil ;; passwd nil)))) ret))) (defun imap-gssapi-auth-p (buffer) (imap-capability 'AUTH=GSSAPI buffer)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" (if (eq imap-stream 'gssapi) "done" "failed")) (eq imap-stream 'gssapi)) (defun imap-kerberos4-auth-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) (defun imap-kerberos4-auth (buffer) (message "imap: Authenticating using Kerberos 4...%s" (if (eq imap-stream 'kerberos4) "done" "failed")) (eq imap-stream 'kerberos4)) (defun imap-cram-md5-p (buffer) (imap-capability 'AUTH=CRAM-MD5 buffer)) (defun imap-cram-md5-auth (buffer) "Login to server using the AUTH CRAM-MD5 method." (message "imap: Authenticating using CRAM-MD5...") (let ((done (imap-interactive-login buffer (lambda (user passwd) (imap-ok-p (imap-send-command-wait (list "AUTHENTICATE CRAM-MD5" (lambda (challenge) (let* ((decoded (base64-decode-string challenge)) (hash (rfc2104-hash 'md5 64 16 passwd decoded)) (response (concat user " " hash)) (encoded (base64-encode-string response))) encoded))))))))) (if done (message "imap: Authenticating using CRAM-MD5...done") (message "imap: Authenticating using CRAM-MD5...failed")))) (defun imap-login-p (buffer) (and (not (imap-capability 'LOGINDISABLED buffer)) (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) (defun imap-login-auth (buffer) "Login to server using the LOGIN command." (message "imap: Plaintext authentication...") (imap-interactive-login buffer (lambda (user passwd) (imap-ok-p (imap-send-command-wait (concat "LOGIN \"" user "\" \"" passwd "\"")))))) (defun imap-anonymous-p (buffer) t) (defun imap-anonymous-auth (buffer) (message "imap: Loging in anonymously...") (with-current-buffer buffer (imap-ok-p (imap-send-command-wait (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) (defun imap-digest-md5-p (buffer) (and (imap-capability 'AUTH=DIGEST-MD5 buffer) (condition-case () (require 'digest-md5) (error nil)))) (defun imap-digest-md5-auth (buffer) "Login to server using the AUTH DIGEST-MD5 method." (message "imap: Authenticating using DIGEST-MD5...") (imap-interactive-login buffer (lambda (user passwd) (let ((tag (imap-send-command (list "AUTHENTICATE DIGEST-MD5" (lambda (challenge) (digest-md5-parse-digest-challenge (base64-decode-string challenge)) (let* ((digest-uri (digest-md5-digest-uri "imap" (digest-md5-challenge 'realm))) (response (digest-md5-digest-response user passwd digest-uri))) (base64-encode-string response 'no-line-break)))) ))) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) nil (setq imap-continuation nil) (imap-send-command-1 "") (imap-ok-p (imap-wait-for-tag tag))))))) ;; Server functions: (defun imap-open-1 (buffer) (with-current-buffer buffer (erase-buffer) (setq imap-current-mailbox nil imap-current-message nil imap-state 'initial imap-process (condition-case () (funcall (nth 2 (assq imap-stream imap-stream-alist)) "imap" buffer imap-server imap-port) ((error quit) nil))) (when imap-process (set-process-filter imap-process 'imap-arrival-filter) (set-process-sentinel imap-process 'imap-sentinel) (while (and (eq imap-state 'initial) (memq (process-status imap-process) '(open run))) (message "Waiting for response from %s..." imap-server) (accept-process-output imap-process 1)) (message "Waiting for response from %s...done" imap-server) (and (memq (process-status imap-process) '(open run)) imap-process)))) (defun imap-open (server &optional port stream auth buffer) "Open a IMAP connection to host SERVER at PORT returning a buffer. If PORT is unspecified, a default value is used (143 except for SSL which use 993). STREAM indicates the stream to use, see `imap-streams' for available streams. If nil, it choices the best stream the server is capable of. AUTH indicates authenticator to use, see `imap-authenticators' for available authenticators. If nil, it choices the best stream the server is capable of. BUFFER can be a buffer or a name of a buffer, which is created if necessery. If nil, the buffer name is generated." (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0)))) (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) (mapcar 'make-variable-buffer-local imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) (setq imap-port (or port imap-port)) (setq imap-auth (or auth imap-auth)) (setq imap-stream (or stream imap-stream)) (message "imap: Connecting to %s..." imap-server) (if (let ((imap-stream (or imap-stream imap-default-stream))) (imap-open-1 buffer)) ;; Choose stream. (let (stream-changed) (message "imap: Connecting to %s...done" imap-server) (when (null imap-stream) (let ((streams imap-streams)) (while (setq stream (pop streams)) (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) (setq stream-changed (not (eq (or imap-stream imap-default-stream) stream)) imap-stream stream streams nil))) (unless imap-stream (error "Couldn't figure out a stream for server")))) (when stream-changed (message "imap: Reconnecting with stream `%s'..." imap-stream) (imap-close buffer) (if (imap-open-1 buffer) (message "imap: Reconnecting with stream `%s'...done" imap-stream) (message "imap: Reconnecting with stream `%s'...failed" imap-stream)) (setq imap-capability nil)) (if (imap-opened buffer) ;; Choose authenticator (when (and (null imap-auth) (not (eq imap-state 'auth))) (let ((auths imap-authenticators)) (while (setq auth (pop auths)) (if (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) (setq imap-auth auth auths nil))) (unless imap-auth (error "Couldn't figure out authenticator for server")))))) (message "imap: Connecting to %s...failed" imap-server)) (when (imap-opened buffer) (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) buffer))) (defun imap-opened (&optional buffer) "Return non-nil if connection to imap server in BUFFER is open. If BUFFER is nil then the current buffer is used." (and (setq buffer (get-buffer (or buffer (current-buffer)))) (buffer-live-p buffer) (with-current-buffer buffer (and imap-process (memq (process-status imap-process) '(open run)))))) (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." (with-current-buffer (or buffer (current-buffer)) (if (not (eq imap-state 'nonauth)) (or (eq imap-state 'auth) (eq imap-state 'select) (eq imap-state 'examine)) (make-variable-buffer-local 'imap-username) (make-variable-buffer-local 'imap-password) (if user (setq imap-username user)) (if passwd (setq imap-password passwd)) (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) (setq imap-state 'auth))))) (defun imap-close (&optional buffer) "Close connection to server in BUFFER. If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) (and (imap-opened) (not (imap-ok-p (imap-send-command-wait "LOGOUT"))) (message "Server %s didn't let me log out" imap-server)) (when (and imap-process (memq (process-status imap-process) '(open run))) (delete-process imap-process)) (setq imap-current-mailbox nil imap-current-message nil imap-process nil) (erase-buffer) t)) (defun imap-capability (&optional identifier buffer) "Return a list of identifiers which server in BUFFER support. If IDENTIFIER, return non-nil if it's among the servers capabilities. If BUFFER is nil, the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (unless imap-capability (unless (imap-ok-p (imap-send-command-wait "CAPABILITY")) (setq imap-capability '(IMAP2)))) (if identifier (memq (intern (upcase (symbol-name identifier))) imap-capability) imap-capability))) (defun imap-namespace (&optional buffer) "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil, the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (unless imap-namespace (when (imap-capability 'NAMESPACE) (imap-send-command-wait "NAMESPACE"))) imap-namespace)) (defun imap-send-command-wait (command &optional buffer) (imap-wait-for-tag (imap-send-command command buffer) buffer)) ;; Mailbox functions: (defun imap-mailbox-put (propname value &optional mailbox buffer) (with-current-buffer (or buffer (current-buffer)) (if imap-mailbox-data (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) propname value) (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" propname value mailbox (current-buffer))) t)) (defsubst imap-mailbox-get-1 (propname &optional mailbox) (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data) propname)) (defun imap-mailbox-get (propname &optional mailbox buffer) (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox))))) (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) (with-current-buffer (or buffer (current-buffer)) (let (result) (mapatoms (lambda (s) (push (funcall func (if mailbox-decoder (funcall mailbox-decoder (symbol-name s)) (symbol-name s))) result)) imap-mailbox-data) result))) (defun imap-mailbox-map (func &optional buffer) "Map a function across each mailbox in `imap-mailbox-data', returning a list. Function should take a mailbox name (a string) as the only argument." (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) (defun imap-current-mailbox (&optional buffer) (with-current-buffer (or buffer (current-buffer)) (imap-utf7-decode imap-current-mailbox))) (defun imap-current-mailbox-p-1 (mailbox &optional examine) (and (string= mailbox imap-current-mailbox) (or (and examine (eq imap-state 'examine)) (and (not examine) (eq imap-state 'selected))))) (defun imap-current-mailbox-p (mailbox &optional examine buffer) (with-current-buffer (or buffer (current-buffer)) (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine))) (defun imap-mailbox-select-1 (mailbox &optional examine) "Select MAILBOX on server in BUFFER. If EXAMINE is non-nil, do a read-only select." (if (imap-current-mailbox-p-1 mailbox examine) imap-current-mailbox (setq imap-current-mailbox mailbox) (if (imap-ok-p (imap-send-command-wait (concat (if examine "EXAMINE" "SELECT") " \"" mailbox "\""))) (progn (setq imap-message-data (make-vector imap-message-prime 0) imap-state (if examine 'examine 'selected)) imap-current-mailbox) ;; Failed SELECT/EXAMINE unselects current mailbox (setq imap-current-mailbox nil)))) (defun imap-mailbox-select (mailbox &optional examine buffer) (with-current-buffer (or buffer (current-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)) (defun imap-mailbox-unselect (&optional buffer) "Close current folder in BUFFER, without expunging articles." (with-current-buffer (or buffer (current-buffer)) (when (or (eq imap-state 'auth) (and (imap-capability 'UNSELECT) (imap-ok-p (imap-send-command-wait "UNSELECT"))) (and (imap-ok-p (imap-send-command-wait (concat "EXAMINE \"" imap-current-mailbox "\""))) (imap-ok-p (imap-send-command-wait "CLOSE")))) (setq imap-current-mailbox nil imap-message-data nil imap-state 'auth) t))) (defun imap-mailbox-expunge (&optional buffer) "Expunge articles in current folder in BUFFER. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (not (eq imap-state 'examine))) (imap-ok-p (imap-send-command-wait "EXPUNGE"))))) (defun imap-mailbox-close (&optional buffer) "Expunge articles and close current folder in BUFFER. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (imap-ok-p (imap-send-command-wait "CLOSE"))) (setq imap-current-mailbox nil imap-message-data nil imap-state 'auth) t))) (defun imap-mailbox-create-1 (mailbox) (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\"")))) (defun imap-mailbox-create (mailbox &optional buffer) "Create MAILBOX on server in BUFFER. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (imap-mailbox-create-1 (imap-utf7-encode mailbox)))) (defun imap-mailbox-delete (mailbox &optional buffer) "Delete MAILBOX on server in BUFFER. If BUFFER is nil the current buffer is assumed." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (list "DELETE \"" mailbox "\"")))))) (defun imap-mailbox-rename (oldname newname &optional buffer) "Rename mailbox OLDNAME to NEWNAME on server in BUFFER. If BUFFER is nil the current buffer is assumed." (let ((oldname (imap-utf7-encode oldname)) (newname (imap-utf7-encode newname))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (list "RENAME \"" oldname "\" " "\"" newname "\"")))))) (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 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 (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root))) (imap-send-command-wait (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) "\""))) ;; clear list data (NB not delimiter and other stuff) (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'lsub nil mailbox))) (when (imap-ok-p (imap-send-command-wait (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) (let (out) (imap-mailbox-map-1 (lambda (mailbox) (when (imap-mailbox-get-1 'lsub mailbox) (push (imap-utf7-decode mailbox) out)))) (nreverse out))))) (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 passed to list command." (with-current-buffer (or buffer (current-buffer)) ;; Make sure we know the hierarchy separator for root's hierarchy (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root))) (imap-send-command-wait (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) "\""))) ;; clear list data (NB not delimiter and other stuff) (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'list nil mailbox))) (when (imap-ok-p (imap-send-command-wait (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) (let (out) (imap-mailbox-map-1 (lambda (mailbox) (when (imap-mailbox-get-1 'list mailbox) (push (imap-utf7-decode mailbox) out)))) (nreverse out))))) (defun imap-mailbox-subscribe (mailbox &optional buffer) "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" (imap-utf7-encode mailbox) "\""))))) (defun imap-mailbox-unsubscribe (mailbox &optional buffer) "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " (imap-utf7-encode mailbox) "\""))))) (defun imap-mailbox-status (mailbox items &optional buffer) "Get status items ITEM in MAILBOX from server in BUFFER. ITEMS can be a symbol or a list of symbols, valid symbols are one of the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity or 'unseen. If ITEMS is a list of symbols, a list of values is returned, if ITEMS is a symbol only it's value is returned." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (list "STATUS \"" (imap-utf7-encode mailbox) "\" " (format "%s" (if (listp items) items (list items)))))) (if (listp items) (mapcar (lambda (item) (imap-mailbox-get item mailbox)) items) (imap-mailbox-get items mailbox))))) (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (list "GETACL \"" (or mailbox imap-current-mailbox) "\""))) (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox)))))) (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer) "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (list "SETACL \"" (or mailbox imap-current-mailbox) "\" " identifier " " rights)))))) (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (list "DELETEACL \"" (or mailbox imap-current-mailbox) "\" " identifier)))))) ;; Message functions: (defun imap-current-message (&optional buffer) (with-current-buffer (or buffer (current-buffer)) imap-current-message)) (defun imap-list-to-message-set (list) (mapconcat (lambda (item) (number-to-string item)) (if (listp list) list (list list)) ",")) (defun imap-range-to-message-set (range) (mapconcat (lambda (item) (if (consp item) (format "%d:%d" (car item) (cdr item)) (format "%d" item))) (if (and (listp range) (not (listp (cdr range)))) (list range) ;; make (1 . 2) into ((1 . 2)) range) ",")) (defun imap-fetch-asynch (uids props &optional nouidfetch buffer) (with-current-buffer (or buffer (current-buffer)) (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ") (if (listp uids) (imap-list-to-message-set uids) uids) props)))) (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 theese properties." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (format "%sFETCH %s %s" (if nouidfetch "" "UID ") (if (listp uids) (imap-list-to-message-set uids) uids) props))) (if (or (null receive) (stringp uids)) t (if (listp uids) (mapcar (lambda (uid) (if (listp receive) (mapcar (lambda (prop) (imap-message-get uid prop)) receive) (imap-message-get uid receive))) uids) (imap-message-get uids receive)))))) (defun imap-message-put (uid propname value &optional buffer) (with-current-buffer (or buffer (current-buffer)) (if imap-message-data (put (intern (number-to-string uid) imap-message-data) propname value) (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" uid propname value (current-buffer))) t)) (defun imap-message-get (uid propname &optional buffer) (with-current-buffer (or buffer (current-buffer)) (get (intern-soft (number-to-string uid) imap-message-data) propname))) (defun imap-message-map (func propname &optional buffer) "Map a function across each mailbox in `imap-message-data', returning a list." (with-current-buffer (or buffer (current-buffer)) (let (result) (mapatoms (lambda (s) (push (funcall func (get s 'UID) (get s propname)) result)) imap-message-data) result))) (defmacro imap-message-envelope-date (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 0))) (defmacro imap-message-envelope-subject (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 1))) (defmacro imap-message-envelope-from (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 2))) (defmacro imap-message-envelope-sender (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 3))) (defmacro imap-message-envelope-reply-to (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 4))) (defmacro imap-message-envelope-to (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 5))) (defmacro imap-message-envelope-cc (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 6))) (defmacro imap-message-envelope-bcc (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 7))) (defmacro imap-message-envelope-in-reply-to (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 8))) (defmacro imap-message-envelope-message-id (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (elt (imap-message-get ,uid 'ENVELOPE) 9))) (defmacro imap-message-body (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) (imap-message-get ,uid 'BODY))) (defun imap-search (predicate &optional buffer) (with-current-buffer (or buffer (current-buffer)) (imap-mailbox-put 'search 'dummy) (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) (error "Missing SEARCH response to a SEARCH command") (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER." (with-current-buffer (or buffer (current-buffer)) (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox)) (member flag (imap-mailbox-get 'permanentflags mailbox))))) (defun imap-message-flags-set (articles flags &optional silent buffer) (when (and articles flags) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "UID STORE " articles " FLAGS" (if silent ".SILENT") " (" flags ")")))))) (defun imap-message-flags-del (articles flags &optional silent buffer) (when (and articles flags) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "UID STORE " articles " -FLAGS" (if silent ".SILENT") " (" flags ")")))))) (defun imap-message-flags-add (articles flags &optional silent buffer) (when (and articles flags) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "UID STORE " articles " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) (defun imap-message-copyuid-1 (mailbox) (if (imap-capability 'UIDPLUS) (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) (let ((old-mailbox imap-current-mailbox) (state imap-state) (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) (defun imap-message-copyuid (mailbox &optional buffer) (with-current-buffer (or buffer (current-buffer)) (imap-message-copyuid-1 (imap-utf7-decode mailbox)))) (defun imap-message-copy (articles mailbox &optional dont-create no-copyuid buffer) "Copy ARTICLES (a string message set) to MAILBOX on server in BUFFER, creating mailbox if it doesn't exist. If dont-create is non-nil, it will not create a mailbox. On success, return a list with the UIDVALIDITY of the mailbox the article(s) was copied to as the first element, rest of list contain the saved articles' UIDs." (when articles (with-current-buffer (or buffer (current-buffer)) (let ((mailbox (imap-utf7-encode mailbox))) (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\"")) (imap-current-target-mailbox mailbox)) (if (imap-ok-p (imap-send-command-wait cmd)) t (when (and (not dont-create) (imap-mailbox-get-1 'trycreate mailbox)) (imap-mailbox-create-1 mailbox) (imap-ok-p (imap-send-command-wait cmd))))) (or no-copyuid (imap-message-copyuid-1 mailbox))))))) (defun imap-message-appenduid-1 (mailbox) (if (imap-capability 'UIDPLUS) (imap-mailbox-get-1 'appenduid mailbox) (let ((old-mailbox imap-current-mailbox) (state imap-state) (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) (defun imap-message-appenduid (mailbox &optional buffer) (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) "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 on failure." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (and (let ((imap-current-target-mailbox mailbox)) (imap-ok-p (imap-send-command-wait (list "APPEND \"" mailbox "\" " article)))) (imap-message-appenduid-1 mailbox))))) (defun imap-body-lines (body) "Return number of lines in article by looking at the mime bodystructure BODY." (if (listp body) (if (stringp (car body)) (cond ((and (string= (upcase (car body)) "TEXT") (numberp (nth 7 body))) (nth 7 body)) ((and (string= (upcase (car body)) "MESSAGE") (numberp (nth 9 body))) (nth 9 body)) (t 0)) (apply '+ (mapcar 'imap-body-lines body))) 0)) (defun imap-envelope-from (from) "Return a from string line." (and from (concat (aref from 0) (if (aref from 0) " <") (aref from 2) "@" (aref from 3) (if (aref from 0) ">")))) ;; Internal functions. (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) (and imap-log (with-current-buffer (get-buffer-create imap-log) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert cmdstr))) (process-send-string imap-process cmdstr)) (defun imap-send-command (command &optional buffer) (with-current-buffer (or buffer (current-buffer)) (if (not (listp command)) (setq command (list command))) (let ((tag (setq imap-tag (1+ imap-tag))) cmd cmdstr) (setq cmdstr (concat (number-to-string imap-tag) " ")) (while (setq cmd (pop command)) (cond ((stringp cmd) (setq cmdstr (concat cmdstr cmd))) ((bufferp cmd) (let ((eol imap-client-eol) (calcfirst imap-calculate-literal-size-first) size) (with-current-buffer cmd (if calcfirst (setq size (buffer-size))) (when (not (equal eol "\r\n")) ;; XXX modifies buffer! (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match eol))) (if (not calcfirst) (setq size (buffer-size)))) (setq cmdstr (concat cmdstr (format "{%d}" size)))) (unwind-protect (progn (imap-send-command-1 cmdstr) (setq cmdstr nil) (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) (eol imap-client-eol)) (with-current-buffer cmd (and imap-log (with-current-buffer (get-buffer-create imap-log) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring cmd))) (process-send-region process (point-min) (point-max))) (process-send-string process imap-client-eol)))) (setq imap-continuation nil))) ((functionp cmd) (imap-send-command-1 cmdstr) (setq cmdstr nil) (unwind-protect (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil);; abort command if no cont-req (setq command (cons (funcall cmd imap-continuation) command))) (setq imap-continuation nil))) (t (error "Unknown command type")))) (if cmdstr (imap-send-command-1 cmdstr)) tag))) (defun imap-wait-for-tag (tag &optional buffer) (with-current-buffer (or buffer (current-buffer)) (while (and (null imap-continuation) (< imap-reached-tag tag)) (or (and (not (memq (process-status imap-process) '(open run))) (sit-for 1)) (accept-process-output imap-process 1))) (or (assq tag imap-failed-tags) (if imap-continuation 'INCOMPLETE 'OK)))) (defun imap-sentinel (process string) (delete-process process)) (defun imap-find-next-line () "Return point at end of current line, taking into account literals. Return nil if no complete line has arrived." (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}" imap-server-eol) nil t) (if (match-string 1) (if (< (point-max) (+ (point) (string-to-number (match-string 1)))) nil (goto-char (+ (point) (string-to-number (match-string 1)))) (imap-find-next-line)) (point)))) (defun imap-arrival-filter (proc string) "IMAP process filter." (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert string) (and imap-log (with-current-buffer (get-buffer-create imap-log) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert string))) (let (end) (goto-char (point-min)) (while (setq end (imap-find-next-line)) (save-restriction (narrow-to-region (point-min) end) (delete-backward-char (length imap-server-eol)) (goto-char (point-min)) (unwind-protect (cond ((eq imap-state 'initial) (imap-parse-greeting)) ((or (eq imap-state 'auth) (eq imap-state 'nonauth) (eq imap-state 'selected) (eq imap-state 'examine)) (imap-parse-response)) (t (message "Unknown state %s in arrival filter" imap-state))) (delete-region (point-min) (point-max)))))))) ;; Imap parser. (defsubst imap-forward () (or (eobp) (forward-char))) ;; number = 1*DIGIT ;; ; Unsigned 32-bit integer ;; ; (0 <= n < 4,294,967,296) (defsubst imap-parse-number () (when (looking-at "[0-9]+") (prog1 (string-to-number (match-string 0)) (goto-char (match-end 0))))) ;; literal = "{" number "}" CRLF *CHAR8 ;; ; Number represents the number of CHAR8s (defsubst imap-parse-literal () (when (looking-at "{\\([0-9]+\\)}\r\n") (let ((pos (match-end 0)) (len (string-to-number (match-string 1)))) (if (< (point-max) (+ pos len)) nil (goto-char (+ pos len)) (buffer-substring pos (+ pos len)))))) ;; string = quoted / literal ;; ;; quoted = DQUOTE *QUOTED-CHAR DQUOTE ;; ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> / ;; "\" quoted-specials ;; ;; quoted-specials = DQUOTE / "\" ;; ;; TEXT-CHAR = <any CHAR except CR and LF> (defsubst imap-parse-string () (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" (defsubst imap-parse-nil () (if (looking-at "NIL") (goto-char (match-end 0)))) ;; nstring = string / nil (defsubst imap-parse-nstring () (or (imap-parse-string) (and (imap-parse-nil) nil))) ;; astring = atom / string ;; ;; atom = 1*ATOM-CHAR ;; ;; ATOM-CHAR = <any CHAR except atom-specials> ;; ;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards / ;; quoted-specials ;; ;; list-wildcards = "%" / "*" ;; ;; quoted-specials = DQUOTE / "\" (defsubst imap-parse-astring () (or (imap-parse-string) (buffer-substring (point) (if (re-search-forward "[(){ \r\n%*\"\\]" nil t) (goto-char (1- (match-end 0))) (end-of-line) (point))))) ;; address = "(" addr-name SP addr-adl SP addr-mailbox SP ;; addr-host ")" ;; ;; addr-adl = nstring ;; ; Holds route from [RFC-822] route-addr if ;; ; non-NIL ;; ;; addr-host = nstring ;; ; NIL indicates [RFC-822] group syntax. ;; ; Otherwise, holds [RFC-822] domain name ;; ;; addr-mailbox = nstring ;; ; NIL indicates end of [RFC-822] group; if ;; ; non-NIL and addr-host is NIL, holds ;; ; [RFC-822] group name. ;; ; Otherwise, holds [RFC-822] local-part ;; ; after removing [RFC-822] quoting ;; ;; addr-name = nstring ;; ; If non-NIL, holds phrase from [RFC-822] ;; ; mailbox after removing [RFC-822] quoting ;; (defsubst imap-parse-address () (let (address) (when (eq (char-after) ?\() (imap-forward) (setq address (vector (prog1 (imap-parse-nstring) (imap-forward)) (prog1 (imap-parse-nstring) (imap-forward)) (prog1 (imap-parse-nstring) (imap-forward)) (imap-parse-nstring))) (when (eq (char-after) ?\)) (imap-forward) address)))) ;; address-list = "(" 1*address ")" / nil ;; ;; nil = "NIL" (defsubst imap-parse-address-list () (if (eq (char-after) ?\() (let (address addresses) (imap-forward) (while (and (not (eq (char-after) ?\))) ;; next line for MS Exchange bug (progn (and (eq (char-after) ? ) (imap-forward)) t) (setq address (imap-parse-address))) (setq addresses (cons address addresses))) (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) (assert (imap-parse-nil)))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of ;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX ;; ; not as an astring. An astring which consists of ;; ; the case-insensitive sequence "I" "N" "B" "O" "X" ;; ; is considered to be INBOX and not an astring. ;; ; Refer to section 5.1 for further ;; ; semantic details of mailbox names. (defsubst imap-parse-mailbox () (let ((mailbox (imap-parse-astring))) (if (string-equal "INBOX" (upcase mailbox)) "INBOX" mailbox))) ;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF ;; ;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text ;; ; Authentication condition ;; ;; resp-cond-bye = "BYE" SP resp-text (defun imap-parse-greeting () "Parse a IMAP greeting." (cond ((looking-at "\\* OK ") (setq imap-state 'nonauth)) ((looking-at "\\* PREAUTH ") (setq imap-state 'auth)) ((looking-at "\\* BYE ") (setq imap-state 'closed)))) ;; response = *(continue-req / response-data) response-done ;; ;; continue-req = "+" SP (resp-text / base64) CRLF ;; ;; response-data = "*" SP (resp-cond-state / resp-cond-bye / ;; mailbox-data / message-data / capability-data) CRLF ;; ;; response-done = response-tagged / response-fatal ;; ;; response-fatal = "*" SP resp-cond-bye CRLF ;; ; Server closes connection immediately ;; ;; response-tagged = tag SP resp-cond-state CRLF ;; ;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text ;; ; Status condition ;; ;; resp-cond-bye = "BYE" SP resp-text ;; ;; mailbox-data = "FLAGS" SP flag-list / ;; "LIST" SP mailbox-list / ;; "LSUB" SP mailbox-list / ;; "SEARCH" *(SP nz-number) / ;; "STATUS" SP mailbox SP "(" ;; [status-att SP number *(SP status-att SP number)] ")" / ;; number SP "EXISTS" / ;; number SP "RECENT" ;; ;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att)) ;; ;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1" ;; *(SP capability) ;; ; IMAP4rev1 servers which offer RFC 1730 ;; ; compatibility MUST list "IMAP4" as the first ;; ; capability. (defun imap-parse-response () "Parse a IMAP command response." (let (token) (case (setq token (read (current-buffer))) (+ (setq imap-continuation (or (buffer-substring (min (point-max) (1+ (point))) (point-max)) t))) (* (case (prog1 (setq token (read (current-buffer))) (imap-forward)) (OK (imap-parse-resp-text)) (NO (imap-parse-resp-text)) (BAD (imap-parse-resp-text)) (BYE (imap-parse-resp-text)) (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) (LIST (imap-parse-data-list 'list)) (LSUB (imap-parse-data-list 'lsub)) (SEARCH (imap-mailbox-put 'search (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (imap-parse-status)) (CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) (EXISTS (imap-mailbox-put 'exists token)) (RECENT (imap-mailbox-put 'recent token)) (EXPUNGE t) (FETCH (imap-parse-fetch token)) (t (message "Garbage: %s" (buffer-string))))))) (t (let (status) (if (not (integerp token)) (message "Garbage: %s" (buffer-string)) (case (prog1 (setq status (read (current-buffer))) (imap-forward)) (OK (progn (setq imap-reached-tag (max imap-reached-tag token)) (imap-parse-resp-text))) (NO (progn (setq imap-reached-tag (max imap-reached-tag token)) (save-excursion (imap-parse-resp-text)) (let (code text) (when (eq (char-after) ?\[) (setq code (buffer-substring (point) (search-forward "]"))) (imap-forward)) (setq text (buffer-substring (point) (point-max))) (push (list token status code text) imap-failed-tags)))) (BAD (progn (setq imap-reached-tag (max imap-reached-tag token)) (save-excursion (imap-parse-resp-text)) (let (code text) (when (eq (char-after) ?\[) (setq code (buffer-substring (point) (search-forward "]"))) (imap-forward)) (setq text (buffer-substring (point) (point-max))) (push (list token status code text) imap-failed-tags) (error "Internal error, tag %s status %s code %s text %s" token status code text)))) (t (message "Garbage: %s" (buffer-string)))))))))) ;; resp-text = ["[" resp-text-code "]" SP] text ;; ;; text = 1*TEXT-CHAR ;; ;; TEXT-CHAR = <any CHAR except CR and LF> (defun imap-parse-resp-text () (imap-parse-resp-text-code)) ;; resp-text-code = "ALERT" / ;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] / ;; "NEWNAME" SP string SP string / ;; "PARSE" / ;; "PERMANENTFLAGS" SP "(" ;; [flag-perm *(SP flag-perm)] ")" / ;; "READ-ONLY" / ;; "READ-WRITE" / ;; "TRYCREATE" / ;; "UIDNEXT" SP nz-number / ;; "UIDVALIDITY" SP nz-number / ;; "UNSEEN" SP nz-number / ;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">] ;; ;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid ;; ;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set ;; ;; set = sequence-num / (sequence-num ":" sequence-num) / ;; (set "," set) ;; ; Identifies a set of messages. For message ;; ; sequence numbers, these are consecutive ;; ; numbers from 1 to the number of messages in ;; ; the mailbox ;; ; Comma delimits individual numbers, colon ;; ; delimits between two numbers inclusive. ;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13, ;; ; 14,15 for a mailbox with 15 messages. ;; ;; sequence-num = nz-number / "*" ;; ; * is the largest number in use. For message ;; ; sequence numbers, it is the number of messages ;; ; in the mailbox. For unique identifiers, it is ;; ; the unique identifier of the last message in ;; ; the mailbox. ;; ;; flag-perm = flag / "\*" ;; ;; flag = "\Answered" / "\Flagged" / "\Deleted" / ;; "\Seen" / "\Draft" / flag-keyword / flag-extension ;; ; Does not include "\Recent" ;; ;; flag-extension = "\" atom ;; ; Future expansion. Client implementations ;; ; MUST accept flag-extension flags. Server ;; ; implementations MUST NOT generate ;; ; flag-extension flags except as defined by ;; ; future standard or standards-track ;; ; revisions of this specification. ;; ;; flag-keyword = atom ;; ;; resp-text-atom = 1*<any ATOM-CHAR except "]"> (defun imap-parse-resp-text-code () (when (eq (char-after) ?\[) (imap-forward) (cond ((search-forward "PERMANENTFLAGS " nil t) (imap-mailbox-put 'permanentflags (imap-parse-flag-list))) ((search-forward "UIDNEXT " nil t) (imap-mailbox-put 'uidnext (read (current-buffer)))) ((search-forward "UNSEEN " nil t) (imap-mailbox-put 'unseen (read (current-buffer)))) ((looking-at "UIDVALIDITY \\([0-9]+\\)") (imap-mailbox-put 'uidvalidity (match-string 1))) ((search-forward "READ-ONLY" nil t) (imap-mailbox-put 'read-only t)) ((search-forward "NEWNAME " nil t) (let (oldname newname) (setq oldname (imap-parse-string)) (imap-forward) (setq newname (imap-parse-string)) (imap-mailbox-put 'newname newname oldname))) ((search-forward "TRYCREATE" nil t) (imap-mailbox-put 'trycreate t imap-current-target-mailbox)) ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)") (imap-mailbox-put 'appenduid (list (match-string 1) (string-to-number (match-string 2))) imap-current-target-mailbox)) ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)") (imap-mailbox-put 'copyuid (list (match-string 1) (match-string 2) (match-string 3)) imap-current-target-mailbox)) ((search-forward "ALERT] " nil t) (message "Imap server %s information: %s" imap-server (buffer-substring (point) (point-max))))))) ;; mailbox-list = "(" [mbx-list-flags] ")" SP ;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox ;; ;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag ;; *(SP mbx-list-oflag) / ;; mbx-list-oflag *(SP mbx-list-oflag) ;; ;; mbx-list-oflag = "\Noinferiors" / flag-extension ;; ; Other flags; multiple possible per LIST response ;; ;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked" ;; ; Selectability flags; only one per LIST response ;; ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> / ;; "\" quoted-specials ;; ;; quoted-specials = DQUOTE / "\" (defun imap-parse-data-list (type) (let (flags delimiter mailbox) (setq flags (imap-parse-flag-list)) (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"") (setq delimiter (match-string 1)) (goto-char (1+ (match-end 0))) (when (setq mailbox (imap-parse-mailbox)) (imap-mailbox-put type t mailbox) (imap-mailbox-put 'list-flags flags mailbox) (imap-mailbox-put 'delimiter delimiter mailbox))))) ;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope / ;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" / ;; "INTERNALDATE" SPACE date_time / ;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring / ;; "RFC822.SIZE" SPACE number / ;; "BODY" ["STRUCTURE"] SPACE body / ;; "BODY" section ["<" number ">"] SPACE nstring / ;; "UID" SPACE uniqueid) ")" ;; ;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year ;; SPACE time SPACE zone <"> ;; ;; section ::= "[" [section_text / (nz_number *["." nz_number] ;; ["." (section_text / "MIME")])] "]" ;; ;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"] ;; SPACE header_list / "TEXT" ;; ;; header_fld_name ::= astring ;; ;; header_list ::= "(" 1#header_fld_name ")" (defsubst imap-parse-header-list () (when (eq (char-after) ?\() (let (strlist) (while (not (eq (char-after) ?\))) (imap-forward) (push (imap-parse-astring) strlist)) (imap-forward) (nreverse strlist)))) (defsubst imap-parse-fetch-body-section () (let ((section (buffer-substring (point) (1- (re-search-forward "[] ]" nil t))))) (if (eq (char-before) ? ) (prog1 (mapconcat 'identity (cons section (imap-parse-header-list)) " ") (search-forward "]" nil t)) section))) (defun imap-parse-fetch (response) (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure) (while (not (eq (char-after) ?\))) (imap-forward) (let ((token (read (current-buffer)))) (imap-forward) (cond ((eq token 'UID) (setq uid (ignore-errors (read (current-buffer))))) ((eq token 'FLAGS) (setq flags (imap-parse-flag-list))) ((eq token 'ENVELOPE) (setq envelope (imap-parse-envelope))) ((eq token 'INTERNALDATE) (setq internaldate (imap-parse-string))) ((eq token 'RFC822) (setq rfc822 (imap-parse-nstring))) ((eq token 'RFC822.HEADER) (setq rfc822header (imap-parse-nstring))) ((eq token 'RFC822.TEXT) (setq rfc822text (imap-parse-nstring))) ((eq token 'RFC822.SIZE) (setq rfc822size (read (current-buffer)))) ((eq token 'BODY) (if (eq (char-before) ?\[) (push (list (upcase (imap-parse-fetch-body-section)) (and (eq (char-after) ?<) (buffer-substring (1+ (point)) (search-forward ">" nil t))) (progn (imap-forward) (imap-parse-nstring))) bodydetail) (setq body (imap-parse-body)))) ((eq token 'BODYSTRUCTURE) (setq bodystructure (imap-parse-body)))))) (when uid (setq imap-current-message uid) (imap-message-put uid 'UID uid) (and flags (imap-message-put uid 'FLAGS flags)) (and envelope (imap-message-put uid 'ENVELOPE envelope)) (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) (and rfc822 (imap-message-put uid 'RFC822 rfc822)) (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header)) (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text)) (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size)) (and body (imap-message-put uid 'BODY body)) (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail)) (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure)) (run-hooks 'imap-fetch-data-hook))))) ;; mailbox-data = ... ;; "STATUS" SP mailbox SP "(" ;; [status-att SP number ;; *(SP status-att SP number)] ")" ;; ... ;; ;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" / ;; "UNSEEN" (defun imap-parse-status () (let ((mailbox (imap-parse-mailbox))) (when (and mailbox (search-forward "(" nil t)) (while (not (eq (char-after) ?\))) (let ((token (read (current-buffer)))) (cond ((eq token 'MESSAGES) (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) ((eq token 'RECENT) (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) ((eq token 'UIDNEXT) (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox)) ((eq token 'UIDVALIDITY) (and (looking-at " \\([0-9]+\\)") (imap-mailbox-put 'uidvalidity (match-string 1) mailbox) (goto-char (match-end 1)))) ((eq token 'UNSEEN) (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) (t (message "Unknown status data %s in mailbox %s ignored" token mailbox)))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE ;; rights) ;; ;; identifier ::= astring ;; ;; rights ::= astring (defun imap-parse-acl () (let ((mailbox (imap-parse-mailbox)) identifier rights acl) (while (eq (char-after) ?\ ) (imap-forward) (setq identifier (imap-parse-astring)) (imap-forward) (setq rights (imap-parse-astring)) (setq acl (append acl (list (cons identifier rights))))) (imap-mailbox-put 'acl acl mailbox))) ;; flag-list = "(" [flag *(SP flag)] ")" ;; ;; flag = "\Answered" / "\Flagged" / "\Deleted" / ;; "\Seen" / "\Draft" / flag-keyword / flag-extension ;; ; Does not include "\Recent" ;; ;; flag-keyword = atom ;; ;; flag-extension = "\" atom ;; ; Future expansion. Client implementations ;; ; MUST accept flag-extension flags. Server ;; ; implementations MUST NOT generate ;; ; flag-extension flags except as defined by ;; ; future standard or standards-track ;; ; revisions of this specification. (defun imap-parse-flag-list () (let (flag-list start) (assert (eq (char-after) ?\()) (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) (point))) (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) (assert (eq (char-after) ?\))) (imap-forward) (nreverse flag-list))) ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP ;; env-reply-to SP env-to SP env-cc SP env-bcc SP ;; env-in-reply-to SP env-message-id ")" ;; ;; env-bcc = "(" 1*address ")" / nil ;; ;; env-cc = "(" 1*address ")" / nil ;; ;; env-date = nstring ;; ;; env-from = "(" 1*address ")" / nil ;; ;; env-in-reply-to = nstring ;; ;; env-message-id = nstring ;; ;; env-reply-to = "(" 1*address ")" / nil ;; ;; env-sender = "(" 1*address ")" / nil ;; ;; env-subject = nstring ;; ;; env-to = "(" 1*address ")" / nil (defun imap-parse-envelope () (when (eq (char-after) ?\() (imap-forward) (vector (prog1 (imap-parse-nstring);; date (imap-forward)) (prog1 (imap-parse-nstring);; subject (imap-forward)) (prog1 (imap-parse-address-list);; from (imap-forward)) (prog1 (imap-parse-address-list);; sender (imap-forward)) (prog1 (imap-parse-address-list);; reply-to (imap-forward)) (prog1 (imap-parse-address-list);; to (imap-forward)) (prog1 (imap-parse-address-list);; cc (imap-forward)) (prog1 (imap-parse-address-list);; bcc (imap-forward)) (prog1 (imap-parse-nstring);; in-reply-to (imap-forward)) (prog1 (imap-parse-nstring);; message-id (imap-forward))))) ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil (defsubst imap-parse-string-list () (cond ((eq (char-after) ?\();; body-fld-param (let (strlist str) (imap-forward) (while (setq str (imap-parse-string)) (push str strlist) ;; buggy stalker communigate pro 3.0 doesn't print SPC ;; between body-fld-param's sometimes (or (eq (char-after) ?\") (imap-forward))) (nreverse strlist))) ((imap-parse-nil) nil))) ;; body-extension = nstring / number / ;; "(" body-extension *(SP body-extension) ")" ;; ; Future expansion. Client implementations ;; ; MUST accept body-extension fields. Server ;; ; implementations MUST NOT generate ;; ; body-extension fields except as defined by ;; ; future standard or standards-track ;; ; revisions of this specification. (defun imap-parse-body-extension () (if (eq (char-after) ?\() (let (b-e) (imap-forward) (push (imap-parse-body-extension) b-e) (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) (assert (eq (char-after) ?\))) (imap-forward) (nreverse b-e)) (or (imap-parse-number) (imap-parse-nstring)))) ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang ;; *(SP body-extension)]] ;; ; MUST NOT be returned on non-extensible ;; ; "BODY" fetch ;; ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang ;; *(SP body-extension)]] ;; ; MUST NOT be returned on non-extensible ;; ; "BODY" fetch (defsubst imap-parse-body-ext () (let (ext) (when (eq (char-after) ?\ );; body-fld-dsp (imap-forward) (let (dsp) (if (eq (char-after) ?\() (progn (imap-forward) (push (imap-parse-string) dsp) (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) (assert (imap-parse-nil))) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ );; body-fld-lang (imap-forward) (if (eq (char-after) ?\() (push (imap-parse-string-list) ext) (push (imap-parse-nstring) ext)) (while (eq (char-after) ?\ );; body-extension (imap-forward) (setq ext (append (imap-parse-body-extension) ext))))) ext)) ;; body = "(" body-type-1part / body-type-mpart ")" ;; ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang ;; *(SP body-extension)]] ;; ; MUST NOT be returned on non-extensible ;; ; "BODY" fetch ;; ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang ;; *(SP body-extension)]] ;; ; MUST NOT be returned on non-extensible ;; ; "BODY" fetch ;; ;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP ;; body-fld-enc SP body-fld-octets ;; ;; body-fld-desc = nstring ;; ;; body-fld-dsp = "(" string SP body-fld-param ")" / nil ;; ;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/ ;; "QUOTED-PRINTABLE") DQUOTE) / string ;; ;; body-fld-id = nstring ;; ;; body-fld-lang = nstring / "(" string *(SP string) ")" ;; ;; body-fld-lines = number ;; ;; body-fld-md5 = nstring ;; ;; body-fld-octets = number ;; ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil ;; ;; body-type-1part = (body-type-basic / body-type-msg / body-type-text) ;; [SP body-ext-1part] ;; ;; body-type-basic = media-basic SP body-fields ;; ; MESSAGE subtype MUST NOT be "RFC822" ;; ;; body-type-msg = media-message SP body-fields SP envelope ;; SP body SP body-fld-lines ;; ;; body-type-text = media-text SP body-fields SP body-fld-lines ;; ;; body-type-mpart = 1*body SP media-subtype ;; [SP body-ext-mpart] ;; ;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" / ;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype ;; ; Defined in [MIME-IMT] ;; ;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE ;; ; Defined in [MIME-IMT] ;; ;; media-subtype = string ;; ; Defined in [MIME-IMT] ;; ;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype ;; ; Defined in [MIME-IMT] (defun imap-parse-body () (let (body) (when (eq (char-after) ?\() (imap-forward) (if (eq (char-after) ?\() (let (subbody) (while (and (eq (char-after) ?\() (setq subbody (imap-parse-body))) ;; buggy stalker communigate pro 3.0 insert a SPC between ;; parts in multiparts (when (and (eq (char-after) ?\ ) (eq (char-after (1+ (point))) ?\()) (imap-forward)) (push subbody body)) (imap-forward) (push (imap-parse-string) body);; media-subtype (when (eq (char-after) ?\ );; body-ext-mpart: (imap-forward) (if (eq (char-after) ?\();; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body)));; body-ext-... (assert (eq (char-after) ?\))) (imap-forward) (nreverse body)) (push (imap-parse-string) body);; media-type (imap-forward) (push (imap-parse-string) body);; media-subtype (imap-forward) ;; next line for Sun SIMS bug (and (eq (char-after) ? ) (imap-forward)) (if (eq (char-after) ?\();; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (imap-forward) (push (imap-parse-nstring) body);; body-fld-id (imap-forward) (push (imap-parse-nstring) body);; body-fld-desc (imap-forward) ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a ;; nstring and return NIL instead of defaulting back to 7BIT ;; as the standard says. (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc (imap-forward) (push (imap-parse-number) body);; body-fld-octets ;; ok, we're done parsing the required parts, what comes now is one ;; of three things: ;; ;; envelope (then we're parsing body-type-msg) ;; body-fld-lines (then we're parsing body-type-text) ;; body-ext-1part (then we're parsing body-type-basic) ;; ;; the problem is that the two first are in turn optionally followed ;; by the third. So we parse the first two here (if there are any)... (when (eq (char-after) ?\ ) (imap-forward) (let (lines) (cond ((eq (char-after) ?\();; body-type-msg: (push (imap-parse-envelope) body);; envelope (imap-forward) (push (imap-parse-body) body);; body ;; buggy stalker communigate pro 3.0 doesn't print ;; number of lines in message/rfc822 attachment (if (eq (char-after) ?\)) (push 0 body) (imap-forward) (push (imap-parse-number) body))) ;; body-fld-lines ((setq lines (imap-parse-number)) ;; body-type-text: (push lines body)) ;; body-fld-lines (t (backward-char))))) ;; no match... ;; ...and then parse the third one here... (when (eq (char-after) ?\ );; body-ext-1part: (imap-forward) (push (imap-parse-nstring) body);; body-fld-md5 (setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. (assert (eq (char-after) ?\))) (imap-forward) (nreverse body))))) (when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug)) (mapcar (lambda (f) (trace-function-background f imap-debug)) '( imap-read-passwd imap-utf7-encode imap-utf7-decode imap-error-text imap-kerberos4s-p imap-kerberos4-open imap-ssl-p imap-ssl-open imap-network-p imap-network-open imap-interactive-login imap-kerberos4a-p imap-kerberos4-auth imap-cram-md5-p imap-cram-md5-auth imap-login-p imap-login-auth imap-anonymous-p imap-anonymous-auth imap-open-1 imap-open imap-opened imap-authenticate imap-close imap-capability imap-namespace imap-send-command-wait imap-mailbox-put imap-mailbox-get imap-mailbox-map-1 imap-mailbox-map imap-current-mailbox imap-current-mailbox-p-1 imap-current-mailbox-p imap-mailbox-select-1 imap-mailbox-select imap-mailbox-examine-1 imap-mailbox-examine imap-mailbox-unselect imap-mailbox-expunge imap-mailbox-close imap-mailbox-create-1 imap-mailbox-create imap-mailbox-delete imap-mailbox-rename imap-mailbox-lsub imap-mailbox-list imap-mailbox-subscribe imap-mailbox-unsubscribe imap-mailbox-status imap-mailbox-acl-get imap-mailbox-acl-set imap-mailbox-acl-delete imap-current-message imap-list-to-message-set imap-fetch-asynch imap-fetch imap-message-put imap-message-get imap-message-map imap-search imap-message-flag-permanent-p imap-message-flags-set imap-message-flags-del imap-message-flags-add imap-message-copyuid-1 imap-message-copyuid imap-message-copy imap-message-appenduid-1 imap-message-appenduid imap-message-append imap-body-lines imap-envelope-from imap-send-command-1 imap-send-command imap-wait-for-tag imap-sentinel imap-find-next-line imap-arrival-filter imap-parse-greeting imap-parse-response imap-parse-resp-text imap-parse-resp-text-code imap-parse-data-list imap-parse-fetch imap-parse-status imap-parse-acl imap-parse-flag-list imap-parse-envelope imap-parse-body-extension imap-parse-body ))) (provide 'imap) ;;; imap.el ends here