From: Gnus developers Date: Sun, 13 Feb 2011 13:44:06 +0000 (+0000) Subject: net/imap.el: Remove file. All the functionality is in nnimap.el. X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~896 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=114fe5465b72c51c7c6602edb5059143b32b3354;p=emacs.git net/imap.el: Remove file. All the functionality is in nnimap.el. nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): Fix Gcc processing on imap. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e99e4b59a93..f7361b1c108 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2011-02-13 Teodor Zlatanov + * net/imap.el: Remove file. All the functionality is in nnimap.el. + * net/imap-hash.el: Remove file. 2011-02-13 Michael Albinus diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index e484c5701fe..9c1de7da577 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2011-02-13 Tassilo Horn (tiny change) + + * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): Fix + Gcc processing on imap. + 2011-02-10 Stefan Monnier * message.el (message-bury): Don't pop up a new window when selected diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 94c8f82f507..be3f8125192 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -966,7 +966,8 @@ textual parts.") (nnimap-add-cr) (setq message (buffer-substring-no-properties (point-min) (point-max))) (with-current-buffer (nnimap-buffer) - (when (setq message (nnimap-process-quirk "OK Gimap " 'append message)) + (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message) + message)) ;; If we have this group open read-only, then unselect it ;; before appending to it. (when (equal (nnimap-examined nnimap-object) group) @@ -994,7 +995,7 @@ textual parts.") (defun nnimap-process-quirk (greeting-match type data) (when (and (nnimap-greeting nnimap-object) - (string-match "OK Gimap " (nnimap-greeting nnimap-object)) + (string-match greeting-match (nnimap-greeting nnimap-object)) (eq type 'append) (string-match "\000" data)) (let ((choice (gnus-multiple-choice diff --git a/lisp/net/imap.el b/lisp/net/imap.el deleted file mode 100644 index 6d80b97fd23..00000000000 --- a/lisp/net/imap.el +++ /dev/null @@ -1,3055 +0,0 @@ -;;; imap.el --- imap library - -;; Copyright (C) 1998-2011 Free Software Foundation, Inc. - -;; Author: Simon Josefsson -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; imap.el is an 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 these commands should be pretty self -;; explanatory for someone that know 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 -;; (with use of external program `imtest'), and RFC2971 (ID). It also -;; takes advantage of 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 a 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 it 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: ^M\r...." -;; -;; Todo: -;; -;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. -;; Use IEEE floats (which are effectively exact)? -- fx -;; o Don't use `read' at all (important places already fixed) -;; o Accept list of articles instead of message set string in most -;; imap-message-* functions. -;; o Send strings as literal if they contain, e.g., ". -;; -;; Revision history: -;; -;; - 19991218 added starttls/digest-md5 patch, -;; by Daiki Ueno -;; NB! you need SLIM for starttls.el and digest-md5.el -;; - 19991023 committed to pgnus -;; - -;;; Code: - -(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") - (autoload 'sasl-find-mechanism "sasl") - (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 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec") - (autoload 'open-tls-stream "tls")) - -;; 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 (list - (concat "gsasl %s %p " - "--mechanism GSSAPI " - "--authentication-id %l") - "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 -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" - "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)) - -(defcustom imap-process-connection-type nil - "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. -The `process-connection-type' variable controls the type of device -used to communicate with subprocesses. Values are nil to use a -pipe, or t or `pty' to use a pty. The value has no effect if the -system has no ptys or if all ptys are busy: then a pipe is used -in any case. The value takes effect when an IMAP server is -opened; changing it after that has no effect." - :version "22.1" - :group 'imap - :type 'boolean) - -(defcustom 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." - :group 'imap - :type 'boolean) - -(defcustom imap-log nil - "If non-nil, an imap session trace is placed in `imap-log-buffer'. -Note that username, passwords and other privacy sensitive -information (such as e-mail) may be stored in the buffer. -It is not written to disk, however. Do not enable this -variable unless you are comfortable with that. - -See also `imap-debug'." - :group 'imap - :type 'boolean) - -(defcustom imap-debug nil - "If non-nil, trace imap- functions into `imap-debug-buffer'. -Uses `trace-function-background', so you can turn it off with, -say, `untrace-all'. - -Note that username, passwords and other privacy sensitive -information (such as e-mail) may be stored in the buffer. -It is not written to disk, however. Do not enable this -variable unless you are comfortable with that. - -This variable only takes effect when loading the `imap' library. -See also `imap-log'." - :group 'imap - :type 'boolean) - -(defcustom imap-shell-host "gateway" - "Hostname of rlogin proxy." - :group 'imap - :type 'string) - -(defcustom imap-default-user (user-login-name) - "Default username to use." - :group 'imap - :type 'string) - -(defcustom imap-read-timeout (if (string-match - "windows-nt\\|os/2\\|cygwin" - (symbol-name system-type)) - 1.0 - 0.1) - "*How long to wait between checking for the end of output. -Shorter values mean quicker response, but is more CPU intensive." - :type 'number - :group 'imap) - -(defcustom imap-store-password nil - "If non-nil, store session password without prompting." - :group 'imap - :type 'boolean) - -;; Various variables. - -(defvar imap-fetch-data-hook nil - "Hooks called after receiving each FETCH response.") - -(defvar imap-streams '(gssapi kerberos4 starttls tls 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) - (tls imap-tls-p imap-tls-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 - ;;sasl - 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) - (sasl imap-sasl-auth-p imap-sasl-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 actual authentication.") - -(defvar imap-error nil - "Error codes from the last command.") - -(defvar imap-logout-timeout nil - "Close server immediately if it can't logout in this number of seconds. -If it is nil, never close server until logout completes. Normally, -the value of this variable will be bound to a certain value to which -an application program that uses this module specifies on a per-server -basis.") - -;; Internal constants. Change these and die. - -(defconst imap-default-port 143) -(defconst imap-default-ssl-port 993) -(defconst imap-default-tls-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-id - imap-namespace - imap-state - imap-reached-tag - imap-failed-tags - imap-tag - imap-process - imap-calculate-literal-size-first - imap-mailbox-data)) -(defconst imap-log-buffer "*imap-log*") -(defconst imap-debug-buffer "*imap-debug*") - -;; 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-last-authenticator 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-id nil - "Identity of server. -See RFC 2971.") - -(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 actual value is really the text on the continuation line.") - -(defvar imap-callbacks nil - "List of response tags and callbacks, on the form `(number . function)'. -The function should take two arguments, the first the IMAP tag and the -second the status (OK, NO, BAD etc) of the command.") - -(defvar imap-enable-exchange-bug-workaround nil - "Send FETCH UID commands as *:* instead of *. - -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 -message set is invalid.'. We don't unconditionally use this -form, since this is said to be significantly inefficient. - -This variable is set to t automatically per server if the -canonical form fails.") - - -;; Utility functions: - -(defun imap-remassoc (key alist) - "Delete by side effect any elements of ALIST whose car is `equal' to KEY. -The modified ALIST is returned. If the first member -of ALIST has a car that is `equal' to KEY, there is no way to remove it -by side effect; therefore, write `(setq foo (remassoc key foo))' to be -sure of changing the value of `foo'." - (when alist - (if (equal key (caar alist)) - (cdr alist) - (setcdr alist (imap-remassoc key (cdr alist))) - alist))) - -(defmacro imap-disable-multibyte () - "Enable multibyte in the current buffer." - (unless (featurep 'xemacs) - '(set-buffer-multibyte nil))) - -(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-log (string-or-buffer) - (when imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (if (bufferp string-or-buffer) - (insert-buffer-substring string-or-buffer) - (insert string-or-buffer))))) - -(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-connection-type imap-process-connection-type) - (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)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - ;; Athena IMTEST can output SSL verify errors - (or (while (looking-at "^verify error:num=") - (forward-line)) - t) - (or (while (looking-at "^TLS connection established") - (forward-line)) - t) - ;; 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)) - (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-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) - (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-connection-type imap-process-connection-type) - (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)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - ;; Athena IMTEST can output SSL verify errors - (or (while (looking-at "^verify error:num=") - (forward-line)) - t) - (or (while (looking-at "^TLS connection established") - (forward-line)) - t) - ;; 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) - ;; GNU SASL may print 'Trying ...' first. - (or (not (looking-at "Trying ")) - (forward-line) - t) - (not (and (imap-parse-greeting) - ;; success in imtest 1.6: - (re-search-forward - (concat "^\\(\\(Authenticat.*\\)\\|\\(" - "Client authentication " - "finished.*\\)\\)") - nil t) - (setq response (match-string 1))))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log 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-logout)) - (delete-process process) - 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) - 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))) - (when process - (while (and (memq (process-status process) '(open run)) - ;; FIXME: Per the "blue moon" comment, the process/buffer - ;; handling here, and elsewhere in functions which open - ;; streams, looks confused. Obviously we can change buffers - ;; if a different process handler kicks in from - ;; `accept-process-output' or `sit-for' below, and TRT seems - ;; to be to `save-buffer' around those calls. (I wonder why - ;; `sit-for' is used with a non-zero wait.) -- fx - (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) - (when (memq (process-status process) '(open run)) - process)))) - -(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)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log 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 (if (listp imap-shell-program) imap-shell-program - (list 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)) - (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 IMAP connection with `%s'...done" cmd) - done) - (message "imap: Opening IMAP connection with `%s'...failed" cmd) - nil))) - -(defun imap-starttls-p (buffer) - (imap-capability 'STARTTLS buffer)) - -(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 tls-info) - (message "imap: Connecting with STARTTLS...") - (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)) - (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) - done)) - -;; 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 successful authenticating itself to the server, nil otherwise. -Returns t if login was successful, nil otherwise." - (with-current-buffer buffer - (make-local-variable 'imap-username) - (make-local-variable '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 - " (using stream `" (symbol-name 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) "'): ")))) - (when (and user passwd) - (if (funcall loginfunc user passwd) - (progn - (message "imap: Login successful...") - (setq ret t - imap-username user) - (when (and (not imap-password) - (or imap-store-password - (y-or-n-p "imap: Store password for this IMAP session? "))) - (setq imap-password passwd))) - (message "imap: Login failed...") - (setq passwd nil) - (setq imap-password 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) - (eq imap-stream 'gssapi)) - -(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) - (and (imap-capability 'AUTH=KERBEROS_V4 buffer) - (eq imap-stream 'kerberos4))) - -(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-quote-specials (string) - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (re-search-forward "[\\\"]" nil t) - (forward-char -1) - (insert "\\") - (forward-char 1)) - (buffer-string))) - -(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 \"" - (imap-quote-specials user) - "\" \"" - (imap-quote-specials passwd) - "\"")))))) - -(defun imap-anonymous-p (buffer) - t) - -(defun imap-anonymous-auth (buffer) - (message "imap: Logging in anonymously...") - (with-current-buffer buffer - (imap-ok-p (imap-send-command-wait - (concat "LOGIN anonymous \"" (concat (user-login-name) "@" - (system-name)) "\""))))) - -;;; Compiler directives. - -(defvar imap-sasl-client) -(defvar imap-sasl-step) - -(defun imap-sasl-make-mechanisms (buffer) - (let ((mecs '())) - (mapc (lambda (sym) - (let ((name (symbol-name sym))) - (if (and (> (length name) 5) - (string-equal "AUTH=" (substring name 0 5 ))) - (setq mecs (cons (substring name 5) mecs))))) - (imap-capability nil buffer)) - mecs)) - -(declare-function sasl-find-mechanism "sasl" (mechanism)) -(declare-function sasl-mechanism-name "sasl" (mechanism)) -(declare-function sasl-make-client "sasl" (mechanism name service server)) -(declare-function sasl-next-step "sasl" (client step)) -(declare-function sasl-step-data "sasl" (step)) -(declare-function sasl-step-set-data "sasl" (step data)) - -(defun imap-sasl-auth-p (buffer) - (and (condition-case () - (require 'sasl) - (error nil)) - (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))) - -(defun imap-sasl-auth (buffer) - "Login to server using the SASL method." - (message "imap: Authenticating using SASL...") - (with-current-buffer buffer - (make-local-variable 'imap-username) - (make-local-variable 'imap-sasl-client) - (make-local-variable 'imap-sasl-step) - (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))) - logged user) - (while (not logged) - (setq user (or imap-username - (read-from-minibuffer - (concat "IMAP username for " imap-server " using SASL " - (sasl-mechanism-name mechanism) ": ") - (or user imap-default-user)))) - (when user - (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server) - imap-sasl-step (sasl-next-step imap-sasl-client nil)) - (let ((tag (imap-send-command - (if (sasl-step-data imap-sasl-step) - (format "AUTHENTICATE %s %s" - (sasl-mechanism-name mechanism) - (sasl-step-data imap-sasl-step)) - (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism))) - buffer))) - (while (eq (imap-wait-for-tag tag) 'INCOMPLETE) - (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation)) - (setq imap-continuation nil - imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step)) - (imap-send-command-1 (if (sasl-step-data imap-sasl-step) - (base64-encode-string (sasl-step-data imap-sasl-step) t) - ""))) - (if (imap-ok-p (imap-wait-for-tag tag)) - (setq imap-username user - logged t) - (message "Login failed...") - (sit-for 1))))) - logged))) - -(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 an 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 -necessary. 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)) - (mapc 'make-local-variable 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 (null (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer))) - (progn - (message "imap: Connecting to %s...failed" imap-server) - nil) - (when (null imap-stream) - ;; Need to choose stream. - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - ;; OK to use this stream? - (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - ;; Stream changed? - (if (not (eq imap-default-stream stream)) - (with-current-buffer (get-buffer-create - (generate-new-buffer-name " *temp*")) - (mapc 'make-local-variable 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)) - (message "imap: Reconnecting with stream `%s'..." stream) - (if (null (let ((imap-stream stream)) - (imap-open-1 (current-buffer)))) - (progn - (kill-buffer (current-buffer)) - (message - "imap: Reconnecting with stream `%s'...failed" - stream)) - ;; We're done, kill the first connection - (imap-close buffer) - (let ((name (if (stringp buffer) - buffer - (buffer-name buffer)))) - (kill-buffer buffer) - (rename-buffer name) - ;; set the passed buffer to the current one, - ;; so that (imap-opened buffer) later will work - (setq buffer (current-buffer))) - (message "imap: Reconnecting with stream `%s'...done" - stream) - (setq imap-stream stream) - (setq imap-capability nil) - (setq streams nil))) - ;; We're done - (message "imap: Connecting to %s...done" imap-server) - (setq imap-stream stream) - (setq imap-capability nil) - (setq streams nil)))))) - (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) - ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer) - (when imap-stream - buffer)))) - -(defcustom imap-ping-server t - "If non-nil, check if IMAP is open. -See the function `imap-ping-server'." - :version "23.1" ;; No Gnus - :group 'imap - :type 'boolean) - -(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)) - (if imap-ping-server - (imap-ping-server) - t))))) - -(defun imap-ping-server (&optional buffer) - "Ping the IMAP server in BUFFER with a \"NOOP\" command. -Return non-nil if the server responds, and nil if it does not -respond. If BUFFER is nil, the current buffer is used." - (condition-case () - (imap-ok-p (imap-send-command-wait "NOOP" buffer)) - (error nil))) - -(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 'selected) - (eq imap-state 'examine)) - (make-local-variable 'imap-username) - (make-local-variable 'imap-password) - (make-local-variable 'imap-last-authenticator) - (when user (setq imap-username user)) - (when passwd (setq imap-password passwd)) - (if imap-auth - (and (setq imap-last-authenticator - (assq imap-auth imap-authenticator-alist)) - (funcall (nth 2 imap-last-authenticator) (current-buffer)) - (setq imap-state 'auth)) - ;; Choose authenticator. - (let ((auths imap-authenticators) - auth) - (while (setq auth (pop auths)) - ;; OK to use authenticator? - (setq imap-last-authenticator - (assq auth imap-authenticator-alist)) - (when (funcall (nth 1 imap-last-authenticator) (current-buffer)) - (message "imap: Authenticating to `%s' using `%s'..." - imap-server auth) - (setq imap-auth auth) - (if (funcall (nth 2 imap-last-authenticator) (current-buffer)) - (progn - (message "imap: Authenticating to `%s' using `%s'...done" - imap-server auth) - ;; set imap-state correctly on successful auth attempt - (setq imap-state 'auth) - ;; stop iterating through the authenticator list - (setq auths nil)) - (message "imap: Authenticating to `%s' using `%s'...failed" - imap-server auth))))) - imap-state)))) - -(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)) - (when (imap-opened) - (condition-case nil - (imap-logout-wait) - (quit nil))) - (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-id (&optional list-of-values buffer) - "Identify client to server in BUFFER, and return server identity. -LIST-OF-VALUES is nil, or a plist with identifier and value -strings to send to the server to identify the client. - -Return a list of identifiers which server in BUFFER support, or -nil if it doesn't support ID or returns no information. - -If BUFFER is nil, the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (when (and (imap-capability 'ID) - (imap-ok-p (imap-send-command-wait - (if (null list-of-values) - "ID NIL" - (concat "ID (" (mapconcat (lambda (el) - (concat "\"" el "\"")) - list-of-values - " ") ")"))))) - imap-id))) - -(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)) - -(defun imap-logout (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (if imap-logout-timeout - (with-timeout (imap-logout-timeout - (condition-case nil - (with-current-buffer buffer - (delete-process imap-process)) - (error))) - (imap-send-command "LOGOUT" buffer)) - (imap-send-command "LOGOUT" buffer))) - -(defun imap-logout-wait (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (if imap-logout-timeout - (with-timeout (imap-logout-timeout - (condition-case nil - (with-current-buffer buffer - (delete-process imap-process)) - (error))) - (imap-send-command-wait "LOGOUT" buffer)) - (imap-send-command-wait "LOGOUT" 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 'examine))) - -(defun imap-mailbox-examine (mailbox &optional buffer) - "Examine MAILBOX on server in BUFFER." - (imap-mailbox-select mailbox 'examine 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 asynch buffer) - "Expunge articles in current folder in BUFFER. -If ASYNCH, do not wait for successful completion of the command. -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))) - (if asynch - (imap-send-command "EXPUNGE") - (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) - -(defun imap-mailbox-close (&optional asynch buffer) - "Expunge articles and close current folder in BUFFER. -If ASYNCH, do not wait for successful completion of the command. -If BUFFER is nil the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (when imap-current-mailbox - (if asynch - (imap-add-callback (imap-send-command "CLOSE") - `(lambda (tag status) - (message "IMAP mailbox `%s' closed... %s" - imap-current-mailbox status) - (when (eq ,imap-current-mailbox - imap-current-mailbox) - ;; Don't wipe out data if another mailbox - ;; was selected... - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth)))) - (when (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 -- i.e. `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 its value is returned." - (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p - (imap-send-command-wait (list "STATUS \"" - (imap-utf7-encode mailbox) - "\" " - (upcase - (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-status-asynch (mailbox items &optional buffer) - "Send status item request ITEM 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." - (with-current-buffer (or buffer (current-buffer)) - (imap-send-command (list "STATUS \"" - (imap-utf7-encode mailbox) - "\" " - (upcase - (format "%s" - (if (listp items) - items - (list items)))))))) - -(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) - "Remove any 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 these 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 message 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))) - -;; FIXME: Should this try to use CHARSET? -- fx -(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) - (progn - (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") - nil) - (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." - (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 ")")))))) - -;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 -;; Signal an error if we'd get an integer overflow. -;; -;; FIXME: Identify relevant calls to `string-to-number' and replace them with -;; `imap-string-to-integer'. -(defun imap-string-to-integer (string &optional base) - (let ((number (string-to-number string base))) - (if (> number most-positive-fixnum) - (error - (format "String %s cannot be converted to a Lisp integer" number)) - number))) - -(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) - "Like `imap-fetch', but DTRT with Exchange 2007 bug. -However, UIDS here is a cons, where the car is the canonical form -of the UIDS specification, and the cdr is the one which works with -Exchange 2007 or, potentially, other buggy servers. -See `imap-enable-exchange-bug-workaround'." - ;; The first time we get here for a given, we'll try the canonical - ;; form. If we get the known error from the buggy server, set the - ;; flag buffer-locally (to account for connections to multiple - ;; servers), then re-try with the alternative UIDS spec. We don't - ;; unconditionally use the alternative form, since the - ;; currently-used alternatives are seriously inefficient with some - ;; servers (although they are valid). - ;; - ;; FIXME: Maybe it would be cleaner to have a flag to not signal - ;; the error (which otherwise gives a message), and test - ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of - ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:* - ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not - ;; to do the same? - (condition-case data - ;; Binding `debug-on-error' allows us to get the error from - ;; `imap-parse-response' -- it's normally caught by Emacs around - ;; execution of a process filter. - (let ((debug-on-error t)) - (imap-fetch (if imap-enable-exchange-bug-workaround - (cdr uids) - (car uids)) - props receive nouidfetch buffer)) - (error - (if (and (not imap-enable-exchange-bug-workaround) - ;; This is the Exchange 2007 response. It may be more - ;; robust just to check for a BAD response to the - ;; attempted fetch. - (string-match "The specified message set is invalid" - (cadr data))) - (with-current-buffer (or buffer (current-buffer)) - (set (make-local-variable 'imap-enable-exchange-bug-workaround) - t) - (imap-fetch (cdr uids) props receive nouidfetch)) - (signal (car data) (cdr data)))))) - -(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-safe '("*" . "*:*") "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 to MAILBOX on server in BUFFER. -ARTICLES is a string message set. Create mailbox if it doesn't exist, -unless DONT-CREATE is non-nil. On success, return a list with -the UIDVALIDITY of the mailbox the article(s) was copied to as the -first element. The rest of list contains 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) - ;; removed because of buggy Oracle server - ;; that doesn't send TRYCREATE tags (which - ;; is a MUST according to specifications): - ;;(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))))))) - -;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it -;; shares most of the code? -- fx -(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-safe '("*" . "*:*") "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-add-callback (tag func) - (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) - -(defun imap-send-command-1 (cmdstr) - (setq cmdstr (concat cmdstr imap-client-eol)) - (imap-log 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 - (imap-log 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 - (setq command - (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - nil ;; abort command if no cont-req - (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)) - (let (imap-have-messaged) - (while (and (null imap-continuation) - (memq (process-status imap-process) '(open run)) - (< imap-reached-tag tag)) - (let ((len (/ (buffer-size) 1024)) - message-log-max) - (unless (< len 10) - (setq imap-have-messaged t) - (message "imap read: %dk" len)) - (accept-process-output imap-process - (truncate imap-read-timeout) - (truncate (* (- imap-read-timeout - (truncate imap-read-timeout)) - 1000))))) - ;; A process can die _before_ we have processed everything it - ;; has to say. Moreover, this can happen in between the call to - ;; accept-process-output and the call to process-status in an - ;; iteration of the loop above. - (when (and (null imap-continuation) - (< imap-reached-tag tag)) - (accept-process-output imap-process 0 0)) - (when imap-have-messaged - (message "")) - (and (memq (process-status imap-process) '(open run)) - (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." - ;; Sometimes, we are called even though the process has died. - ;; Better abstain from doing stuff in that case. - (when (buffer-name (process-buffer proc)) - (with-current-buffer (process-buffer proc) - (goto-char (point-max)) - (insert string) - (imap-log string) - (let (end) - (goto-char (point-min)) - (while (setq end (imap-find-next-line)) - (save-restriction - (narrow-to-region (point-min) end) - (delete-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 = / -;; "\" quoted-specials -;; -;; quoted-specials = DQUOTE / "\" -;; -;; TEXT-CHAR = - -(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 = -;; -;; 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))) - ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") - (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 an 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))) - ")")))) - (ID (setq imap-id (read (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)))) - (when (assq token imap-callbacks) - (funcall (cdr (assq token imap-callbacks)) token status) - (setq imap-callbacks - (imap-remassoc token imap-callbacks))))))))) - -;; resp-text = ["[" resp-text-code "]" SP] text -;; -;; text = 1*TEXT-CHAR -;; -;; TEXT-CHAR = - -(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*] -;; -;; 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* - -(defun imap-parse-resp-text-code () - ;; xxx next line for stalker communigate pro 3.3.1 bug - (when (looking-at " \\[") - (imap-forward)) - (when (eq (char-after) ?\[) - (imap-forward) - (cond ((search-forward "PERMANENTFLAGS " nil t) - (imap-mailbox-put 'permanentflags (imap-parse-flag-list))) - ((search-forward "UIDNEXT \\([0-9]+\\)" nil t) - (imap-mailbox-put 'uidnext (match-string 1))) - ((search-forward "UNSEEN " nil t) - (imap-mailbox-put 'first-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 = / -;; "\" 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 flags-empty) - ;; Courier can insert spurious blank characters which will - ;; confuse `read', so skip past them. - (while (let ((moved (skip-chars-forward " \t"))) - (prog1 (not (eq (char-after) ?\))) - (unless (= moved 0) (backward-char)))) - (imap-forward) - (let ((token (read (current-buffer)))) - (imap-forward) - (cond ((eq token 'UID) - (setq uid (condition-case () - (read (current-buffer)) - (error)))) - ((eq token 'FLAGS) - (setq flags (imap-parse-flag-list)) - (if (not flags) - (setq flags-empty 't))) - ((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 (or flags flags-empty) (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))) - (if (eq (char-after) ? ) - (forward-char)) - (when (and mailbox (eq (char-after) ?\()) - (while (and (not (eq (char-after) ?\))) - (or (forward-char) t) - (looking-at "\\([A-Za-z]+\\) ")) - (let ((token (upcase (match-string 1)))) - (goto-char (match-end 0)) - (cond ((string= token "MESSAGES") - (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) - ((string= token "RECENT") - (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) - ((string= token "UIDNEXT") - (and (looking-at "[0-9]+") - (imap-mailbox-put 'uidnext (match-string 0) mailbox) - (goto-char (match-end 0)))) - ((string= token "UIDVALIDITY") - (and (looking-at "[0-9]+") - (imap-mailbox-put 'uidvalidity (match-string 0) mailbox) - (goto-char (match-end 0)))) - ((string= token "UNSEEN") - (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) - (t - (message "Unknown status data %s in mailbox %s ignored" - token mailbox) - (read (current-buffer))))))))) - -;; 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) ?\() nil "In imap-parse-flag-list 1") - (while (and (not (eq (char-after) ?\))) - (setq start (progn - (imap-forward) - ;; next line for Courier IMAP bug. - (skip-chars-forward " ") - (point))) - (> (skip-chars-forward "^ )" (point-at-eol)) 0)) - (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") - (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) ?\)) nil "In imap-parse-body-extension") - (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)) - ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") - (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 inserts 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) ?\)) nil "In imap-parse-body") - (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 regards body-fld-enc as a - ;; nstring and returns nil instead of defaulting back to 7BIT - ;; as the standard says. - ;; Exchange (2007, at least) does this as well. - (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc - (imap-forward) - ;; Exchange 2007 can return -1, contrary to the spec... - (if (eq (char-after) ?-) - (progn - (skip-chars-forward "-0-9") - (push nil body)) - (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) ?\)) nil "In imap-parse-body 2") - (imap-forward) - (nreverse body))))) - -(when imap-debug ; (untrace-all) - (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - 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-ping-server - 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-fetch-safe - 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