Using saved parent location: http://bzr.savannah.gnu.org/r/emacs/trunk/ Now on revision 103270. ------------------------------------------------------------ revno: 103270 author: Lars Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2011-02-14 04:23:59 +0000 message: nnimap.el (nnimap-inhibit-logging): New variable. (nnimap-log-command): Don't log login commands. auth-source.el (auth-source-netrc-search): The asserts seem to want to have more parameters. nnimap.el (nnimap-send-command): Mark the command time for each command, so that we don't get NOOPs stepping on our toes. gnus-art.el (article-date-ut): Get the date from the Date header on `t'. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-02-14 01:38:00 +0000 +++ lisp/gnus/ChangeLog 2011-02-14 04:23:59 +0000 @@ -1,3 +1,17 @@ +2011-02-14 Lars Ingebrigtsen + + * nnimap.el (nnimap-inhibit-logging): New variable. + (nnimap-log-command): Don't log login commands. + + * auth-source.el (auth-source-netrc-search): The asserts seem to want + to have more parameters. + + * nnimap.el (nnimap-send-command): Mark the command time for each + command, so that we don't get NOOPs stepping on our toes. + + * gnus-art.el (article-date-ut): Get the date from the Date header on + `t'. + 2011-02-14 Katsumi Yamaoka * auth-source.el (auth-source-search): Use copy-sequence instead of === modified file 'lisp/gnus/auth-source.el' --- lisp/gnus/auth-source.el 2011-02-14 01:38:00 +0000 +++ lisp/gnus/auth-source.el 2011-02-14 04:23:59 +0000 @@ -483,7 +483,7 @@ (assert (or (eq t create) (listp create)) t - "Invalid auth-source :create parameter (must be nil, t, or a list)") + "Invalid auth-source :create parameter (must be nil, t, or a list): %s %s") (setq filtered-backends (copy-sequence backends)) (dolist (backend backends) @@ -779,7 +779,7 @@ See `auth-source-search' for details on SPEC." ;; just in case, check that the type is correct (null or same as the backend) (assert (or (null type) (eq type (oref backend type))) - t "Invalid netrc search") + t "Invalid netrc search: %s %s") (let ((results (auth-source-netrc-normalize (auth-source-netrc-parse === modified file 'lisp/gnus/gnus-art.el' --- lisp/gnus/gnus-art.el 2011-02-13 23:30:55 +0000 +++ lisp/gnus/gnus-art.el 2011-02-14 04:23:59 +0000 @@ -3404,6 +3404,7 @@ (inhibit-read-only t) (inhibit-point-motion-hooks t) (first t) + (visible-date (mail-fetch-field "Date")) pos date bface eface) (save-excursion (save-restriction @@ -3427,6 +3428,9 @@ (delete-region (point-at-bol) (progn (gnus-article-forward-header) (point)))) + (when (and (not date) + visible-date) + (setq date visible-date)) (when date (article-transform-date date type bface eface))))))) === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2011-02-13 13:44:06 +0000 +++ lisp/gnus/nnimap.el 2011-02-14 04:23:59 +0000 @@ -142,6 +142,8 @@ (defvar nnimap-quirks '(("QRESYNC" "Zimbra" "QRESYNC "))) +(defvar nnimap-inhibit-logging nil) + (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -389,8 +391,9 @@ nnimap-address) ports t)))) (setq nnimap-object nil) - (setq login-result - (nnimap-login (car credentials) (cadr credentials))) + (let ((nnimap-inhibit-logging t)) + (setq login-result + (nnimap-login (car credentials) (cadr credentials)))) (unless (car login-result) ;; If the login failed, then forget the credentials ;; that are now possibly cached. @@ -1565,6 +1568,7 @@ (defvar nnimap-sequence 0) (defun nnimap-send-command (&rest args) + (setf (nnimap-last-command-time nnimap-object) (current-time)) (process-send-string (get-buffer-process (current-buffer)) (nnimap-log-command @@ -1583,12 +1587,14 @@ (defun nnimap-log-command (command) (with-current-buffer (get-buffer-create "*imap log*") (goto-char (point-max)) - (insert (format-time-string "%H:%M:%S") " " command)) + (insert (format-time-string "%H:%M:%S") " " + (if nnimap-inhibit-logging + "(inhibited)" + command))) command) (defun nnimap-command (&rest args) (erase-buffer) - (setf (nnimap-last-command-time nnimap-object) (current-time)) (let* ((sequence (apply #'nnimap-send-command args)) (response (nnimap-get-response sequence))) (if (equal (caar response) "OK") ------------------------------------------------------------ revno: 103269 committer: Glenn Morris branch nick: trunk timestamp: Sun 2011-02-13 18:52:02 -0800 message: * admin/notes/bzr: Add section on undoing a bzr remove. diff: === modified file 'admin/notes/bzr' --- admin/notes/bzr 2011-02-12 23:43:42 +0000 +++ admin/notes/bzr 2011-02-14 02:52:02 +0000 @@ -134,3 +134,27 @@ choosing either the trunk or branch version, then run `make -C lisp autoloads' to update the md5sums to the correct trunk value before committing. + +* Re-adding a file that has been removed from the repository + +It's easy to get this wrong. Let's suppose you've done: + +bzr remove file; bzr commit + +and now, sometime later, you realize this was a mistake and file needs +to be brought back. DON'T just do: + +bzr add file; bzr commit + +This restores file, but without its history (`bzr log file' will be +very short). This is because file gets re-added with a new file-id +(use `bzr file-id file' to see the id). + +Insteading of adding the file, try: + +bzr revert -rN file; bzr commit + +where revision N+1 is the one where file was removed. + +You could also try `bzr add --file-ids-from', if you have a copy of +another branch where file still exists. ------------------------------------------------------------ revno: 103268 committer: Glenn Morris branch nick: trunk timestamp: Sun 2011-02-13 17:51:59 -0800 message: * list/net/imap.el: Hopefully restore file-id and history. diff: === added file 'lisp/net/imap.el' --- lisp/net/imap.el 1970-01-01 00:00:00 +0000 +++ lisp/net/imap.el 2011-02-14 01:51:59 +0000 @@ -0,0 +1,3055 @@ +;;; 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 === removed file 'lisp/net/imap.el' --- lisp/net/imap.el 2011-02-14 00:57:10 +0000 +++ lisp/net/imap.el 1970-01-01 00:00:00 +0000 @@ -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 ------------------------------------------------------------ revno: 103267 committer: Chong Yidong branch nick: trunk timestamp: Sun 2011-02-13 20:49:24 -0500 message: Add Log View toggle and log format customization for Git and Hg. * lisp/vc/vc-git.el (vc-git-root-log-format): New option for customizing log format. (vc-git-print-log, vc-git-log-outgoing, vc-git-log-incoming) (vc-git-log-view-mode): Use it. (vc-git-expanded-log-entry): New function. (vc-git-log-view-mode): Use it. Truncate lines in root log. * lisp/vc/vc-hg.el (vc-hg-root-log-template): New option for customizing log format. (vc-hg-print-log): Use it. (vc-hg-expanded-log-entry): New function. (vc-hg-log-view-mode): Use vc-hg-root-log-template and vc-hg-expanded-log-entry. Truncate lines in root log. * lisp/vc/vc-bzr.el (vc-bzr-log-view-mode): Truncate lines in root log. * lisp/vc/log-view.el (log-view-mode-menu): Add log-view-toggle-entry-display. diff: === modified file 'etc/NEWS' --- etc/NEWS 2011-02-13 20:04:33 +0000 +++ etc/NEWS 2011-02-14 01:49:24 +0000 @@ -606,14 +606,14 @@ This merges another branch into the current one. This command prompts the user for specifics, e.g. a merge source. -**** Currently supported by Bzr, Git, and Mercurial. +**** Currently supported for Bzr, Git, and Mercurial. *** Log entries in some Log View buffers can be toggled to display a longer description by typing RET (log-view-toggle-entry-display). In the Log View buffers made by `C-x v L' (vc-print-root-log), you can use this to display the full log entry for the revision at point. -**** Currently supported by Bzr. +**** Currently supported for Bzr, Git, and Mercurial. **** Packages using Log View mode can enable this functionality by binding `log-view-expanded-log-entry-function' to a suitable function. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-14 01:27:56 +0000 +++ lisp/ChangeLog 2011-02-14 01:49:24 +0000 @@ -1,3 +1,24 @@ +2011-02-14 Chong Yidong + + * vc/vc-git.el (vc-git-root-log-format): New option for + customizing log format. + (vc-git-print-log, vc-git-log-outgoing, vc-git-log-incoming) + (vc-git-log-view-mode): Use it. + (vc-git-expanded-log-entry): New function. + (vc-git-log-view-mode): Use it. Truncate lines in root log. + + * vc/vc-hg.el (vc-hg-root-log-template): New option for + customizing log format. + (vc-hg-print-log): Use it. + (vc-hg-expanded-log-entry): New function. + (vc-hg-log-view-mode): Use vc-hg-root-log-template and + vc-hg-expanded-log-entry. Truncate lines in root log. + + * vc/vc-bzr.el (vc-bzr-log-view-mode): Truncate lines in root log. + + * vc/log-view.el (log-view-mode-menu): Add + log-view-toggle-entry-display. + 2011-02-14 Glenn Morris * dired-x.el: Don't require man when compiling. === modified file 'lisp/vc/log-view.el' --- lisp/vc/log-view.el 2011-02-13 20:04:33 +0000 +++ lisp/vc/log-view.el 2011-02-14 01:49:24 +0000 @@ -168,6 +168,8 @@ :help "Annotate the version at point"] ["Modify Log Comment" log-view-modify-change-comment :help "Edit the change comment displayed at point"] + ["Toggle Details at Point" log-view-toggle-entry-display + :active log-view-expanded-log-entry-function] "-----" ["Next Log Entry" log-view-msg-next :help "Go to the next count'th log message"] === modified file 'lisp/vc/vc-bzr.el' --- lisp/vc/vc-bzr.el 2011-02-13 20:04:33 +0000 +++ lisp/vc/vc-bzr.el 2011-02-14 01:49:24 +0000 @@ -603,6 +603,7 @@ "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)")) ;; Allow expanding short log entries (when (eq vc-log-view-type 'short) + (setq truncate-lines t) (set (make-local-variable 'log-view-expanded-log-entry-function) 'vc-bzr-expanded-log-entry)) (set (make-local-variable 'log-view-font-lock-keywords) === modified file 'lisp/vc/vc-git.el' --- lisp/vc/vc-git.el 2011-01-29 21:19:21 +0000 +++ lisp/vc/vc-git.el 2011-02-14 01:49:24 +0000 @@ -119,6 +119,27 @@ :version "23.1" :group 'vc) +(defcustom vc-git-root-log-format + '("%d%h..: %an %ad %s" + ;; The first shy group matches the characters drawn by --graph. + ;; We use numbered groups because `log-view-message-re' wants the + ;; revision number to be group 1. + "^\\(?:[*/\\| ]+ \\)?\\(?2: ([^)]+)\\)?\\(?1:[0-9a-z]+\\)..: \ +\\(?3:.*?\\)[ \t]+\\(?4:[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)" + ((1 'log-view-message-face) + (2 'change-log-list nil lax) + (3 'change-log-name) + (4 'change-log-date))) + "Git log format for `vc-print-root-log'. +This should be a list (FORMAT REGEXP KEYWORDS), where FORMAT is a +format string (which is passed to \"git log\" via the argument +\"--pretty=tformat:FORMAT\"), REGEXP is a regular expression +matching the resulting Git log output, and KEYWORDS is a list of +`font-lock-keywords' for highlighting the Log View buffer." + :type '(list string string (repeat sexp)) + :group 'vc + :version "24.1") + (defvar vc-git-commits-coding-system 'utf-8 "Default coding system for git commits.") @@ -666,8 +687,10 @@ (append '("log" "--no-color") (when shortlog - '("--graph" "--decorate" "--date=short" - "--pretty=tformat:%d%h %ad %s" "--abbrev-commit")) + `("--graph" "--decorate" "--date=short" + ,(format "--pretty=tformat:%s" + (car vc-git-root-log-format)) + "--abbrev-commit")) (when limit (list "-n" (format "%s" limit))) (when start-revision (list start-revision)) '("--"))))))) @@ -678,7 +701,8 @@ buffer 0 nil "log" "--no-color" "--graph" "--decorate" "--date=short" - "--pretty=tformat:%d%h %ad %s" "--abbrev-commit" + (format "--pretty=tformat:%s" (car vc-git-root-log-format)) + "--abbrev-commit" (concat (if (string= remote-location "") "@{upstream}" remote-location) @@ -689,9 +713,10 @@ (vc-git-command nil 0 nil "fetch") (vc-git-command buffer 0 nil - "log" + "log" "--no-color" "--graph" "--decorate" "--date=short" - "--pretty=tformat:%d%h %ad %s" "--abbrev-commit" + (format "--pretty=tformat:%s" (car vc-git-root-log-format)) + "--abbrev-commit" (concat "HEAD.." (if (string= remote-location "") "@{upstream}" remote-location)))) @@ -700,6 +725,7 @@ (defvar log-view-file-re) (defvar log-view-font-lock-keywords) (defvar log-view-per-file-logs) +(defvar log-view-expanded-log-entry-function) (define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View" (require 'add-log) ;; We need the faces add-log. @@ -708,37 +734,37 @@ (set (make-local-variable 'log-view-per-file-logs) nil) (set (make-local-variable 'log-view-message-re) (if (not (eq vc-log-view-type 'long)) - "^\\(?:[*/\\| ]+ \\)?\\(?: ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)" + (cadr vc-git-root-log-format) "^commit *\\([0-9a-z]+\\)")) + ;; Allow expanding short log entries + (when (eq vc-log-view-type 'short) + (setq truncate-lines t) + (set (make-local-variable 'log-view-expanded-log-entry-function) + 'vc-git-expanded-log-entry)) (set (make-local-variable 'log-view-font-lock-keywords) (if (not (eq vc-log-view-type 'long)) - '( - ;; Same as log-view-message-re, except that we don't - ;; want the shy group for the tag name. - ("^\\(?:[*/\\| ]+ \\)?\\( ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)" - (1 'highlight nil lax) - (2 'change-log-acknowledgement) - (3 'change-log-date))) - (append - `((,log-view-message-re (1 'change-log-acknowledgement))) - ;; Handle the case: - ;; user: foo@bar - '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" - (1 'change-log-email)) - ;; Handle the case: - ;; user: FirstName LastName - ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" - (1 'change-log-name)) - ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" - (1 'change-log-acknowledgement) - (2 'change-log-acknowledgement)) - ("^Date: \\(.+\\)" (1 'change-log-date)) + (list (cons (nth 1 vc-git-root-log-format) + (nth 2 vc-git-root-log-format))) + (append + `((,log-view-message-re (1 'change-log-acknowledgement))) + ;; Handle the case: + ;; user: foo@bar + '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" + (1 'change-log-email)) + ;; Handle the case: + ;; user: FirstName LastName + ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + (1 'change-log-name) + (2 'change-log-email)) + ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" + (1 'change-log-name)) + ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + (1 'change-log-name) + (2 'change-log-email)) + ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" + (1 'change-log-acknowledgement) + (2 'change-log-acknowledgement)) + ("^Date: \\(.+\\)" (1 'change-log-date)) ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) @@ -758,6 +784,15 @@ (t nil)))) (beginning-of-line))) +(defun vc-git-expanded-log-entry (revision) + (with-temp-buffer + (apply 'vc-git-command t nil nil (list "log" revision "-1")) + (goto-char (point-min)) + (unless (eobp) + ;; Indent the expanded log entry. + (indent-region (point-min) (point-max) 2) + (buffer-string)))) + (defun vc-git-diff (files &optional rev1 rev2 buffer) "Get a difference report using Git between two revisions of FILES." (let (process-file-side-effects) === modified file 'lisp/vc/vc-hg.el' --- lisp/vc/vc-hg.el 2011-02-03 07:33:16 +0000 +++ lisp/vc/vc-hg.el 2011-02-14 01:49:24 +0000 @@ -138,6 +138,24 @@ "Name of the Mercurial executable (excluding any arguments)." :type 'string :group 'vc) + +(defcustom vc-hg-root-log-format + '("{rev}:{tags}: {author|person} {date|shortdate} {desc|firstline}\\n" + "^\\([0-9]+\\):\\([^:]*\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)" + ((1 'log-view-message-face) + (2 'change-log-list) + (3 'change-log-name) + (4 'change-log-date))) + "Mercurial log template for `vc-print-root-log'. +This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE +is the \"--template\" argument string to pass to Mercurial, +REGEXP is a regular expression matching the resulting Mercurial +output, and KEYWORDS is a list of `font-lock-keywords' for +highlighting the Log View buffer." + :type '(list string string (repeat sexp)) + :group 'vc + :version "24.1") + ;;; Properties of the backend @@ -266,13 +284,14 @@ (nconc (when start-revision (list (format "-r%s:" start-revision))) (when limit (list "-l" (format "%s" limit))) - (when shortlog (list "--style" "compact")) + (when shortlog (list "--template" (car vc-hg-root-log-format))) vc-hg-log-switches))))) (defvar log-view-message-re) (defvar log-view-file-re) (defvar log-view-font-lock-keywords) (defvar log-view-per-file-logs) +(defvar log-view-expanded-log-entry-function) (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View" (require 'add-log) ;; we need the add-log faces @@ -280,33 +299,34 @@ (set (make-local-variable 'log-view-per-file-logs) nil) (set (make-local-variable 'log-view-message-re) (if (eq vc-log-view-type 'short) - "^\\([0-9]+\\)\\(\\[.*\\]\\)? +\\([0-9a-z]\\{12\\}\\) +\\(\\(?:[0-9]+\\)-\\(?:[0-9]+\\)-\\(?:[0-9]+\\) \\(?:[0-9]+\\):\\(?:[0-9]+\\) \\(?:[-+0-9]+\\)\\) +\\(.*\\)$" + (cadr vc-hg-root-log-format) "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")) + ;; Allow expanding short log entries + (when (eq vc-log-view-type 'short) + (setq truncate-lines t) + (set (make-local-variable 'log-view-expanded-log-entry-function) + 'vc-hg-expanded-log-entry)) (set (make-local-variable 'log-view-font-lock-keywords) (if (eq vc-log-view-type 'short) - (append `((,log-view-message-re - (1 'log-view-message-face) - (2 'highlight nil lax) - (3 'log-view-message-face) - (4 'change-log-date) - (5 'change-log-name)))) - (append - log-view-font-lock-keywords - '( - ;; Handle the case: - ;; user: FirstName LastName - ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ;; Handle the cases: - ;; user: foo@bar - ;; and - ;; user: foo - ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)" - (1 'change-log-email)) - ("^date: \\(.+\\)" (1 'change-log-date)) - ("^tag: +\\([^ ]+\\)$" (1 'highlight)) - ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) + (list (cons (nth 1 vc-hg-root-log-format) + (nth 2 vc-hg-root-log-format))) + (append + log-view-font-lock-keywords + '( + ;; Handle the case: + ;; user: FirstName LastName + ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + (1 'change-log-name) + (2 'change-log-email)) + ;; Handle the cases: + ;; user: foo@bar + ;; and + ;; user: foo + ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)" + (1 'change-log-email)) + ("^date: \\(.+\\)" (1 'change-log-date)) + ("^tag: +\\([^ ]+\\)$" (1 'highlight)) + ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) (defun vc-hg-diff (files &optional oldvers newvers buffer) "Get a difference report using hg between two revisions of FILES." @@ -324,6 +344,16 @@ (list "-r" oldvers "-r" newvers) (list "-r" oldvers))))))) +(defun vc-hg-expanded-log-entry (revision) + (with-temp-buffer + (vc-hg-command t nil nil "log" "-r" revision) + (goto-char (point-min)) + (unless (eobp) + ;; Indent the expanded log entry. + (indent-region (point-min) (point-max) 2) + (goto-char (point-max)) + (buffer-string)))) + (defun vc-hg-revision-table (files) (let ((default-directory (file-name-directory (car files)))) (with-temp-buffer ------------------------------------------------------------ revno: 103266 committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2011-02-14 01:38:00 +0000 message: auth-source.el (auth-source-search): Use copy-sequence instead of the cl.el copy-list. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-02-13 23:30:55 +0000 +++ lisp/gnus/ChangeLog 2011-02-14 01:38:00 +0000 @@ -1,3 +1,8 @@ +2011-02-14 Katsumi Yamaoka + + * auth-source.el (auth-source-search): Use copy-sequence instead of + the cl.el copy-list. + 2011-02-13 Adam Sjøgren * gnus-delay.el (gnus-delay-article) Fix number of seconds per day. === modified file 'lisp/gnus/auth-source.el' --- lisp/gnus/auth-source.el 2011-02-13 00:25:29 +0000 +++ lisp/gnus/auth-source.el 2011-02-14 01:38:00 +0000 @@ -485,7 +485,7 @@ (or (eq t create) (listp create)) t "Invalid auth-source :create parameter (must be nil, t, or a list)") - (setq filtered-backends (copy-list backends)) + (setq filtered-backends (copy-sequence backends)) (dolist (backend backends) (dolist (key keys) ;; ignore invalid slots ------------------------------------------------------------ revno: 103265 committer: Glenn Morris branch nick: trunk timestamp: Sun 2011-02-13 17:27:56 -0800 message: dired-x.el misc cleanup. * lisp/dired-x.el: Simplify commentary. Don't require man when compiling. (dired-omit-extensions, dired-local-variables-file) (dired-x-hands-off-my-keys): Make them defcustoms. (Man-support-local-filenames, Man-getpage-in-background): Declare. (vm-visit-folder): Declare rather than defining. (dired-x-help-address, dired-x-variable-list): Remove. (dired-x-submit-report): Make it an obsolete alias. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-14 01:02:31 +0000 +++ lisp/ChangeLog 2011-02-14 01:27:56 +0000 @@ -1,3 +1,13 @@ +2011-02-14 Glenn Morris + + * dired-x.el: Don't require man when compiling. + (dired-omit-extensions, dired-local-variables-file) + (dired-x-hands-off-my-keys): Make them defcustoms. + (Man-support-local-filenames, Man-getpage-in-background): Declare. + (vm-visit-folder): Declare rather than defining. + (dired-x-help-address, dired-x-variable-list): Remove. + (dired-x-submit-report): Make it an obsolete alias. + 2011-02-14 Juanma Barranquero * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el. === modified file 'lisp/dired-x.el' --- lisp/dired-x.el 2011-01-25 04:08:28 +0000 +++ lisp/dired-x.el 2011-02-14 01:27:56 +0000 @@ -25,91 +25,47 @@ ;;; Commentary: -;; This is Sebastian Kremer's excellent dired-x.el (Dired Extra), version -;; 1.191, hacked up for GNU Emacs. Redundant or conflicting material has -;; been removed or renamed in order to work properly with dired of GNU -;; Emacs. All suggestions or comments are most welcomed. - -;; -;; Please, PLEASE, *PLEASE* see the info pages. -;; - -;; BUGS: Type M-x dired-x-submit-report and a report will be generated. - -;; INSTALLATION: In your ~/.emacs, +;; This is based on Sebastian Kremer's excellent dired-x.el (Dired Extra), +;; version 1.191, adapted for GNU Emacs. See the `dired-x' info pages. + +;; USAGE: In your ~/.emacs, ;; ;; (add-hook 'dired-load-hook -;; (function (lambda () -;; (load "dired-x") +;; (lambda () +;; (require 'dired-x) ;; ;; Set global variables here. For example: ;; ;; (setq dired-guess-shell-gnutar "gtar") -;; ))) +;; )) ;; (add-hook 'dired-mode-hook -;; (function (lambda () +;; (lambda () ;; ;; Set buffer-local variables here. For example: ;; ;; (dired-omit-mode 1) -;; ))) +;; )) ;; ;; At load time dired-x.el will install itself, redefine some functions, and -;; bind some dired keys. *Please* see the info pages for more details. - -;; *Please* see the info pages for more details. - -;; User defined variables: -;; -;; dired-bind-vm -;; dired-vm-read-only-folders -;; dired-bind-jump -;; dired-bind-info -;; dired-bind-man -;; dired-x-hands-off-my-keys -;; dired-find-subdir -;; dired-enable-local-variables -;; dired-local-variables-file -;; dired-guess-shell-gnutar -;; dired-guess-shell-gzip-quiet -;; dired-guess-shell-znew-switches -;; dired-guess-shell-alist-user -;; dired-clean-up-buffers-too -;; dired-omit-mode -;; dired-omit-files -;; dired-omit-extensions -;; dired-omit-size-limit -;; -;; To find out more about these variables, load this file, put your cursor at -;; the end of any of the variable names, and hit C-h v [RET]. *Please* see -;; the info pages for more details. - -;; When loaded this code redefines the following functions of GNU Emacs -;; -;; Function Found in this file of GNU Emacs -;; -------- ------------------------------- -;; dired-clean-up-after-deletion ../lisp/dired.el -;; dired-find-buffer-nocreate ../lisp/dired.el -;; dired-initial-position ../lisp/dired.el -;; -;; dired-add-entry ../lisp/dired-aux.el -;; dired-read-shell-command ../lisp/dired-aux.el +;; bind some dired keys. + +;; User customization: M-x customize-group RET dired-x RET. + +;; When loaded this code redefines the following functions of GNU Emacs: +;; From dired.el: dired-clean-up-after-deletion, dired-find-buffer-nocreate, +;; and dired-initial-position. +;; From dired-aux.el: dired-add-entry and dired-read-shell-command. + +;; *Please* see the `dired-x' info pages for more details. ;;; Code: ;; LOAD. -;; This is a no-op if dired-x is being loaded via `dired-load-hook'. It is -;; here in case the user has autoloaded dired-x via the dired-jump key binding -;; (instead of autoloading to dired as is suggested in the info-pages). - +;; This is a no-op if dired-x is being loaded via `dired-load-hook', +;; but maybe not if a dired-x function is being autoloaded. (require 'dired) -;; We will redefine some functions and also need some macros so we need to -;; load dired stuff of GNU Emacs. - +;; We will redefine some functions and also need some macros. (require 'dired-aux) -(defvar vm-folder-directory) -(eval-when-compile (require 'man)) - ;;; User-defined variables. (defgroup dired-x nil @@ -340,10 +296,9 @@ 'dashes))) ;;; GLOBAL BINDING. -(if dired-bind-jump - (progn - (define-key global-map "\C-x\C-j" 'dired-jump) - (define-key global-map "\C-x4\C-j" 'dired-jump-other-window))) +(when dired-bind-jump + (define-key global-map "\C-x\C-j" 'dired-jump) + (define-key global-map "\C-x4\C-j" 'dired-jump-other-window)) ;; Install into appropriate hooks. @@ -589,7 +544,7 @@ (let ((dired-omit-mode nil)) (revert-buffer)) ;; Show omitted files (dired-mark-unmarked-files (dired-omit-regexp) nil nil dired-omit-localp)) -(defvar dired-omit-extensions +(defcustom dired-omit-extensions (append completion-ignored-extensions dired-latex-unclean-extensions dired-bibtex-unclean-extensions @@ -600,7 +555,9 @@ `dired-texinfo-unclean-extensions'. See interactive function `dired-omit-mode' \(\\[dired-omit-mode]\) and -variables `dired-omit-mode' and `dired-omit-files'.") +variables `dired-omit-mode' and `dired-omit-files'." + :type '(repeat string) + :group 'dired-x) (defun dired-omit-expunge (&optional regexp) "Erases all unmarked files matching REGEXP. @@ -896,12 +853,15 @@ ;;; `dired-enable-local-variables' and run `hack-local-variables' on the ;;; Dired Buffer. -(defvar dired-local-variables-file (convert-standard-filename ".dired") +;; FIXME do standard dir-locals obsolete this? +(defcustom dired-local-variables-file (convert-standard-filename ".dired") "Filename, as string, containing local dired buffer variables to be hacked. If this file found in current directory, then it will be inserted into dired buffer and `hack-local-variables' will be run. See Info node `(emacs)File Variables' for more information on local variables. -See also `dired-enable-local-variables'.") +See also `dired-enable-local-variables'." + :type 'file + :group 'dired) (defun dired-hack-local-variables () "Evaluate local variables in `dired-local-variables-file' for dired buffer." @@ -980,6 +940,8 @@ ;; NOTE: Use `gunzip -c' instead of `zcat' on `.gz' files. Some do not ;; install GNU zip's version of zcat. +(declare-function Man-support-local-filenames "man" ()) + (defvar dired-guess-shell-alist-default (list (list "\\.tar$" @@ -1429,6 +1391,8 @@ ;; Run man on files. +(declare-function Man-getpage-in-background "man" (topic)) + (defun dired-man () "Run man on this file. Display old buffer if buffer name matches filename. Uses `man.el' of \\[manual-entry] fame." @@ -1449,11 +1413,8 @@ ;; Run mail on mail folders. -;; Avoid compiler warning. -(eval-when-compile - (when (not (fboundp 'vm-visit-folder)) - (defun vm-visit-folder (file &optional arg) - nil))) +(declare-function vm-visit-folder "ext:vm" (folder &optional read-only)) +(defvar vm-folder-directory) (defun dired-vm (&optional read-only) "Run VM on this file. @@ -1659,11 +1620,17 @@ ;;; FIND FILE AT POINT. -(defvar dired-x-hands-off-my-keys t - "*Non-nil means don't bind `dired-x-find-file' over `find-file' on keyboard. +(defcustom dired-x-hands-off-my-keys t + "Non-nil means don't bind `dired-x-find-file' over `find-file' on keyboard. Similarly for `dired-x-find-file-other-window' over `find-file-other-window'. -If you change this variable after `dired-x.el' is loaded then do -\\[dired-x-bind-find-file].") +If you change this variable without using \\[customize] after `dired-x.el' +is loaded then call \\[dired-x-bind-find-file]." + :type 'boolean + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set sym val) + (dired-x-bind-find-file)) + :group 'dired-x) ;; Bind `dired-x-find-file{-other-window}' over wherever ;; `find-file{-other-window}' is bound? @@ -1777,48 +1744,7 @@ ;;; BUG REPORTS -;; Fixme: get rid of this later. - -;; This section is provided for reports. It uses Barry A. Warsaw's -;; reporter.el which is bundled with GNU Emacs v19. - -(defconst dired-x-help-address "bug-gnu-emacs@gnu.org" - "Address(es) accepting submission of reports on dired-x.el.") - -(defconst dired-x-variable-list - (list - 'dired-bind-vm - 'dired-vm-read-only-folders - 'dired-bind-jump - 'dired-bind-info - 'dired-bind-man - 'dired-find-subdir - 'dired-enable-local-variables - 'dired-local-variables-file - 'dired-guess-shell-gnutar - 'dired-guess-shell-gzip-quiet - 'dired-guess-shell-znew-switches - 'dired-guess-shell-alist-user - 'dired-clean-up-buffers-too - 'dired-omit-mode - 'dired-omit-files - 'dired-omit-extensions - ) - "List of variables to be appended to reports sent by `dired-x-submit-report'.") - -(defun dired-x-submit-report () - "Submit via `reporter.el' a bug report on program. -Send report on `dired-x-file' version `dired-x-version', to -`dired-x-maintainer' at address `dired-x-help-address' listing -variables `dired-x-variable-list' in the message." - (interactive) - - (reporter-submit-bug-report - dired-x-help-address ; address - "dired-x" ; pkgname - dired-x-variable-list ; varlist - nil nil ; pre-/post-hooks - "")) +(define-obsolete-function-alias 'dired-x-submit-report 'report-emacs-bug "24.1") ;; As Barry Warsaw would say: "This might be useful..." ------------------------------------------------------------ revno: 103264 committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2011-02-14 01:02:31 +0000 message: Fix last change. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-14 00:57:10 +0000 +++ lisp/ChangeLog 2011-02-14 01:02:31 +0000 @@ -4,8 +4,7 @@ 2011-02-13 Teodor Zlatanov - * net/imap.el: Bring it back (revert - 84d800cd31de3064f0ed39617d725709a2f8f42f). + * net/imap.el: Bring it back. 2011-02-13 Alan Mackenzie ------------------------------------------------------------ revno: 103263 author: Teodor Zlatanov committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2011-02-14 00:57:10 +0000 message: net/imap.el: Bring it back. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-14 00:23:11 +0000 +++ lisp/ChangeLog 2011-02-14 00:57:10 +0000 @@ -2,6 +2,11 @@ * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el. +2011-02-13 Teodor Zlatanov + + * net/imap.el: Bring it back (revert + 84d800cd31de3064f0ed39617d725709a2f8f42f). + 2011-02-13 Alan Mackenzie * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a === added file 'lisp/net/imap.el' --- lisp/net/imap.el 1970-01-01 00:00:00 +0000 +++ lisp/net/imap.el 2011-02-14 00:57:10 +0000 @@ -0,0 +1,3055 @@ +;;; 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 ------------------------------------------------------------ revno: 103262 committer: Juanma Barranquero branch nick: trunk timestamp: Mon 2011-02-14 01:23:11 +0100 message: lisp/makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 20:25:15 +0000 +++ lisp/ChangeLog 2011-02-14 00:23:11 +0000 @@ -1,3 +1,7 @@ +2011-02-14 Juanma Barranquero + + * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el. + 2011-02-13 Alan Mackenzie * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a @@ -581,7 +585,7 @@ 2011-01-31 Deniz Dogan - * net/rcirc.el: New customizable nick completion format. (Bug#6314) + * net/rcirc.el: New customizable nick completion format. (Bug#6314) (rcirc-nick-completion-format): New defcustom. (rcirc-complete): Use it. @@ -886,7 +890,7 @@ * calc/calc.el (calc-default-power-reference-level) (calc-default-field-reference-level): New variables. - * calc/calc-units.el (math-standard-units): Add dB and Np. + * calc/calc-units.el (math-standard-units): Add dB and Np. (math-logunits): New variable. (math-extract-logunits, math-logcombine, calcFunc-luplus) (calcFunc-luminus, calc-luplus, calc-luminus, math-logunit-level) @@ -896,7 +900,7 @@ * calc/calc-help.el (calc-u-prefix-help): Add logarithmic help. (calc-ul-prefix-help): New function. * calc/calc-ext.el (calc-init-extensions): Autoload new units - functions. Add keybindings for new units functions. + functions. Add keybindings for new units functions. 2011-01-22 Giorgos Keramidas (tiny change) @@ -1002,7 +1006,7 @@ 2011-01-20 Ken Manheimer - * allout.el: (allout-institute-keymap): Use fset instead of + * allout.el (allout-institute-keymap): Use fset instead of reapplying defalias. (allout-hotspot-key-handler): Check for non-control-modified @@ -1130,7 +1134,7 @@ (info-xref-output-heading): Rename from info-xref-filename-heading. (info-xref-good, info-xref-bad, info-xref-xfile-alist) (info-xref-filename-heading): Move to output managing section. - (info-xref-docstrings): New command checking "Info node `(foo)Bar'" + (info-xref-docstrings): New command checking "Info node `(foo)Bar'" (info-xref-lock-file-p, info-xref-with-file): New helpers for it. (info-xref-subfile-p): Move to generic section with those two. (info-xref-check-node): New function split from @@ -1140,7 +1144,7 @@ (info-xref-check-node): Use it. (info-xref-with-output): Show count of unavailables at end of output. (info-xref-all-info-files): Exclude ".*" dotfiles. Ignore broken - symlinks. Exclude .texi files. Exclude Emacs backup files. + symlinks. Exclude .texi files. Exclude Emacs backup files. (info-xref-check-all-custom): Fix quietening viper-mode and gnus-registry-install -- use setq not let so as not to unbind after load. @@ -1985,7 +1989,7 @@ (allout-toggle-subtree-encryption): Adjust docstrings to reflect defaulting policy and other changes. Change fetch-pass to keymode-cue, for simpler universal argument interpretation. - (allout-toggle-subtree-encryption): Adjust docstring to describe + (allout-toggle-subtree-encryption): Adjust docstring to describe changed encryption provisions. Change fetch-pass to keymode-cue, for simpler universal argument interpretation. Remove provisions for handling key type and identity - they'll all be within @@ -2601,8 +2605,8 @@ and "psftp". Exchange "%k" marker with options. (tramp-do-copy-or-rename-file, tramp-sh-handle-file-local-copy): Compute size of link target. - (tramp-do-copy-or-rename-file-out-of-band). Move setting of - `tramp-current-*' up due to gateway methods. Optimze computing of + (tramp-do-copy-or-rename-file-out-of-band): Move setting of + `tramp-current-*' up due to gateway methods. Optimize computing of copy arguments. Use `tramp-get-connection-name' and `tramp-get-connection-buffer'. Improve debug messages. (tramp-compute-multi-hops): Remove port determination. @@ -3854,7 +3858,7 @@ * international/characters.el (char-acronym-table): New variable. (glyphless-char-control): New variable. - (update-glyphless-char-display): New funciton. + (update-glyphless-char-display): New function. * faces.el (glyphless-char): New face. @@ -3925,7 +3929,7 @@ 2010-10-31 Jan Djärv * term/x-win.el (x-get-selection-value): New function that gets - PRIMARY with type as specified in x-select-request-type. (Bug#6802). + PRIMARY with type as specified in x-select-request-type. (Bug#6802) 2010-10-31 Michael Albinus @@ -5707,7 +5711,7 @@ (sql-postgres-login-params): Add user and database defaults. (sql-buffer-live-p): Bug fix. (sql-product-history): New variable. - (sql-read-product): New function. Use it. + (sql-read-product): New function. Use it. (sql-set-product, sql-product-interactive): Use it. (sql-connection-history): New variable. (sql-read-connection): New function. Use it. === modified file 'lisp/makefile.w32-in' --- lisp/makefile.w32-in 2011-01-25 04:08:28 +0000 +++ lisp/makefile.w32-in 2011-02-14 00:23:11 +0000 @@ -443,9 +443,9 @@ TRAMP_SRC = $(lisp)/net/tramp.el $(lisp)/net/tramp-cache.el \ $(lisp)/net/tramp-cmds.el $(lisp)/net/tramp-compat.el \ $(lisp)/net/tramp-ftp.el $(lisp)/net/tramp-gvfs.el \ - $(lisp)/net/tramp-gw.el $(lisp)/net/tramp-imap.el \ - $(lisp)/net/tramp-sh.el $(lisp)/net/tramp-smb.el \ - $(lisp)/net/tramp-uu.el $(lisp)/net/trampver.el + $(lisp)/net/tramp-gw.el $(lisp)/net/tramp-sh.el \ + $(lisp)/net/tramp-smb.el $(lisp)/net/tramp-uu.el \ + $(lisp)/net/trampver.el $(lisp)/net/tramp-loaddefs.el: $(TRAMP_SRC) "$(EMACS)" $(EMACSOPT) \ ------------------------------------------------------------ revno: 103261 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Sun 2011-02-13 23:30:55 +0000 message: gnus-delay.el (gnus-delay-article) Fix number of seconds per day. Improve prompt. gnus-art.el (gnus-article-mode-line-format): Remove the article washing status from the default format. It isn't very informative. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-02-13 13:44:06 +0000 +++ lisp/gnus/ChangeLog 2011-02-13 23:30:55 +0000 @@ -1,3 +1,13 @@ +2011-02-13 Adam Sjøgren + + * gnus-delay.el (gnus-delay-article) Fix number of seconds per day. + Improve prompt. + +2011-02-13 Lars Ingebrigtsen + + * gnus-art.el (gnus-article-mode-line-format): Remove the article + washing status from the default format. It isn't very informative. + 2011-02-13 Tassilo Horn (tiny change) * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): Fix === modified file 'lisp/gnus/gnus-art.el' --- lisp/gnus/gnus-art.el 2011-02-03 23:43:22 +0000 +++ lisp/gnus/gnus-art.el 2011-02-13 23:30:55 +0000 @@ -683,7 +683,7 @@ :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" +(defcustom gnus-article-mode-line-format "Gnus: %g %S%m" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description. @@ -691,6 +691,7 @@ %w The article washing status. %m The number of MIME parts in the article." + :version "24.1" :type 'string :group 'gnus-article-various) === modified file 'lisp/gnus/gnus-delay.el' --- lisp/gnus/gnus-delay.el 2011-01-26 08:36:39 +0000 +++ lisp/gnus/gnus-delay.el 2011-02-13 23:30:55 +0000 @@ -78,7 +78,7 @@ time, then the deadline is tomorrow, else today." (interactive (list (read-string - "Target date (YYYY-MM-DD) or length of delay (units in [mhdwMY]): " + "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): " gnus-delay-default-delay))) (let (num unit days year month day hour minute deadline) (cond ((string-match @@ -105,7 +105,7 @@ (append deadline nil)))) ;; If this time has passed already, add a day. (when (< deadline (gnus-float-time)) - (setq deadline (+ 3600 deadline))) ;3600 secs/day + (setq deadline (+ 86400 deadline))) ; 86400 secs/day ;; Convert seconds to date header. (setq deadline (message-make-date (seconds-to-time deadline)))) ------------------------------------------------------------ revno: 103260 author: Alan Mackenzie committer: Chong Yidong branch nick: trunk timestamp: Sun 2011-02-13 15:25:15 -0500 message: Proper fix for CC mode Bug#7722. * lisp/progmodes/cc-fonts.el (c-font-lock-declarations): Remove a narrow-to-region call that cuts context off the end (Bug#7722). * lisp/progmodes/cc-engine.el (c-forward-<>-arglist-recur): Refactor nested if-forms with a simple cond. (c-forward-<>-arglist): Revert 2011-01-31 change. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 20:04:33 +0000 +++ lisp/ChangeLog 2011-02-13 20:25:15 +0000 @@ -1,3 +1,12 @@ +2011-02-13 Alan Mackenzie + + * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a + narrow-to-region call that cuts context off the end (Bug#7722). + + * progmodes/cc-engine.el (c-forward-<>-arglist-recur): Refactor + nested if-forms with a simple cond. + (c-forward-<>-arglist): Revert 2011-01-31 change. + 2011-02-13 Chong Yidong * vc/log-view.el: New command log-view-toggle-entry-display for === modified file 'lisp/progmodes/cc-engine.el' --- lisp/progmodes/cc-engine.el 2011-01-31 23:54:50 +0000 +++ lisp/progmodes/cc-engine.el 2011-02-13 20:25:15 +0000 @@ -5371,8 +5371,6 @@ ;; cc-mode requires cc-fonts. (declare-function c-fontify-recorded-types-and-refs "cc-fonts" ()) -(defvar c-forward-<>-arglist-recur-depth) - (defun c-forward-<>-arglist (all-types) ;; The point is assumed to be at a "<". Try to treat it as the open ;; paren of an angle bracket arglist and move forward to the @@ -5398,8 +5396,7 @@ ;; If `c-record-type-identifiers' is set then activate ;; recording of any found types that constitute an argument in ;; the arglist. - (c-record-found-types (if c-record-type-identifiers t)) - (c-forward-<>-arglist-recur--depth 0)) + (c-record-found-types (if c-record-type-identifiers t))) (if (catch 'angle-bracket-arglist-escape (setq c-record-found-types (c-forward-<>-arglist-recur all-types))) @@ -5416,14 +5413,6 @@ nil))) (defun c-forward-<>-arglist-recur (all-types) - - ;; Temporary workaround for Bug#7722. - (when (boundp 'c-forward-<>-arglist-recur--depth) - (if (> c-forward-<>-arglist-recur--depth 200) - (error "Max recursion depth reached in <> arglist") - (setq c-forward-<>-arglist-recur--depth - (1+ c-forward-<>-arglist-recur--depth)))) - ;; Recursive part of `c-forward-<>-arglist'. ;; ;; This function might do hidden buffer changes. @@ -5455,9 +5444,11 @@ (goto-char start) nil)) - (forward-char) + (forward-char) ; Forward over the opening '<'. (unless (looking-at c-<-op-cont-regexp) + ;; go forward one non-alphanumeric character (group) per iteration of + ;; this loop. (while (and (progn (c-forward-syntactic-ws) @@ -5486,7 +5477,7 @@ (c-forward-type) (c-forward-syntactic-ws)))))) - (setq pos (point)) + (setq pos (point)) ; e.g. first token inside the '<' ;; Note: These regexps exploit the match order in \| so ;; that "<>" is matched by "<" rather than "[^>:-]>". @@ -5522,37 +5513,35 @@ ;; Either an operator starting with '<' or a nested arglist. (setq pos (point)) (let (id-start id-end subres keyword-match) - (if (if (looking-at c-<-op-cont-regexp) - (setq tmp (match-end 0)) - (setq tmp pos) - (backward-char) - (not - (and - - (save-excursion - ;; There's always an identifier before an angle - ;; bracket arglist, or a keyword in - ;; `c-<>-type-kwds' or `c-<>-arglist-kwds'. - (c-backward-syntactic-ws) - (setq id-end (point)) - (c-simple-skip-symbol-backward) - (when (or (setq keyword-match - (looking-at c-opt-<>-sexp-key)) - (not (looking-at c-keywords-regexp))) - (setq id-start (point)))) - - (setq subres - (let ((c-promote-possible-types t) - (c-record-found-types t)) - (c-forward-<>-arglist-recur - (and keyword-match - (c-keyword-member - (c-keyword-sym (match-string 1)) - 'c-<>-type-kwds))))) - ))) - - ;; It was not an angle bracket arglist. - (goto-char tmp) + (cond + ;; The '<' begins a multi-char operator. + ((looking-at c-<-op-cont-regexp) + (setq tmp (match-end 0)) + (goto-char (match-end 0))) + ;; We're at a nested <.....> + ((progn + (setq tmp pos) + (backward-char) ; to the '<' + (and + (save-excursion + ;; There's always an identifier before an angle + ;; bracket arglist, or a keyword in `c-<>-type-kwds' + ;; or `c-<>-arglist-kwds'. + (c-backward-syntactic-ws) + (setq id-end (point)) + (c-simple-skip-symbol-backward) + (when (or (setq keyword-match + (looking-at c-opt-<>-sexp-key)) + (not (looking-at c-keywords-regexp))) + (setq id-start (point)))) + (setq subres + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-<>-arglist-recur + (and keyword-match + (c-keyword-member + (c-keyword-sym (match-string 1)) + 'c-<>-type-kwds))))))) ;; It was an angle bracket arglist. (setq c-record-found-types subres) @@ -5567,8 +5556,13 @@ (c-forward-syntactic-ws) (looking-at c-opt-identifier-concat-key))) (c-record-ref-id (cons id-start id-end)) - (c-record-type-id (cons id-start id-end)))))) - t) + (c-record-type-id (cons id-start id-end))))) + + ;; At a "less than" operator. + (t + (forward-char) + ))) + t) ; carry on looping. ((and (not c-restricted-<>-arglists) (or (and (eq (char-before) ?&) === modified file 'lisp/progmodes/cc-fonts.el' --- lisp/progmodes/cc-fonts.el 2011-01-25 04:08:28 +0000 +++ lisp/progmodes/cc-fonts.el 2011-02-13 20:25:15 +0000 @@ -1082,7 +1082,7 @@ (boundp 'parse-sexp-lookup-properties)))) ;; Below we fontify a whole declaration even when it crosses the limit, - ;; to avoid gaps when lazy-lock fontifies the file a screenful at a + ;; to avoid gaps when jit/lazy-lock fontifies the file a block at a ;; time. That is however annoying during editing, e.g. the following is ;; a common situation while the first line is being written: ;; @@ -1094,9 +1094,9 @@ ;; "some_other_variable" as an identifier, and the latter will not ;; correct itself until the second line is changed. To avoid that we ;; narrow to the limit if the region to fontify is a single line. - (narrow-to-region - (point-min) - (if (<= limit (c-point 'bonl)) + (if (<= limit (c-point 'bonl)) + (narrow-to-region + (point-min) (save-excursion ;; Narrow after any operator chars following the limit though, ;; since those characters can be useful in recognizing a @@ -1104,8 +1104,7 @@ ;; after the header). (goto-char limit) (skip-chars-forward c-nonsymbol-chars) - (point)) - limit)) + (point)))) (c-find-decl-spots limit ------------------------------------------------------------ revno: 103259 committer: Chong Yidong branch nick: trunk timestamp: Sun 2011-02-13 15:04:33 -0500 message: Bind RET in Log View mode to a command that toggles a more detailed display. * lisp/vc/log-view.el: New command log-view-toggle-entry-display for toggling log entries between concise and detailed forms. (log-view-toggle-entry-display): New command. (log-view-mode-map): Bind RET to it. (log-view-expanded-log-entry-function): New variable. (log-view-current-entry, log-view-inside-comment-p) (log-view-current-tag): New functions. (log-view-toggle-mark-entry): Use log-view-current-entry and log-view-end-of-defun instead of searching directly with log-view-message-re. (log-view-end-of-defun): Likewise. Add optional ARG for compatibility with end-of-defun. (log-view-end-of-defun): Ignore comments and VC buttons. * lisp/vc/vc-bzr.el (vc-bzr-expanded-log-entry): New function. (vc-bzr-log-view-mode): Use log-view-expanded-log-entry-function. diff: === modified file 'etc/NEWS' --- etc/NEWS 2011-02-13 12:57:41 +0000 +++ etc/NEWS 2011-02-13 20:04:33 +0000 @@ -608,6 +608,16 @@ **** Currently supported by Bzr, Git, and Mercurial. +*** Log entries in some Log View buffers can be toggled to display a +longer description by typing RET (log-view-toggle-entry-display). +In the Log View buffers made by `C-x v L' (vc-print-root-log), you can +use this to display the full log entry for the revision at point. + +**** Currently supported by Bzr. + +**** Packages using Log View mode can enable this functionality by +binding `log-view-expanded-log-entry-function' to a suitable function. + ** Miscellaneous --- === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 13:44:06 +0000 +++ lisp/ChangeLog 2011-02-13 20:04:33 +0000 @@ -1,3 +1,22 @@ +2011-02-13 Chong Yidong + + * vc/log-view.el: New command log-view-toggle-entry-display for + toggling log entries between concise and detailed forms. + (log-view-toggle-entry-display): New command. + (log-view-mode-map): Bind RET to it. + (log-view-expanded-log-entry-function): New variable. + (log-view-current-entry, log-view-inside-comment-p) + (log-view-current-tag): New functions. + (log-view-toggle-mark-entry): Use log-view-current-entry and + log-view-end-of-defun instead of searching directly with + log-view-message-re. + (log-view-end-of-defun): Likewise. Add optional ARG for + compatibility with end-of-defun. + (log-view-end-of-defun): Ignore comments and VC buttons. + + * vc/vc-bzr.el (vc-bzr-expanded-log-entry): New function. + (vc-bzr-log-view-mode): Use log-view-expanded-log-entry-function. + 2011-02-13 Teodor Zlatanov * net/imap.el: Remove file. All the functionality is in nnimap.el. === modified file 'lisp/vc/log-view.el' --- lisp/vc/log-view.el 2011-02-13 03:07:53 +0000 +++ lisp/vc/log-view.el 2011-02-13 20:04:33 +0000 @@ -130,6 +130,7 @@ ("z" . kill-this-buffer) ("q" . quit-window) ("g" . revert-buffer) + ("\C-m" . log-view-toggle-entry-display) ("m" . log-view-toggle-mark-entry) ("e" . log-view-modify-change-comment) @@ -180,6 +181,12 @@ (defvar log-view-mode-hook nil "Hook run at the end of `log-view-mode'.") +(defvar log-view-expanded-log-entry-function nil + "Function returning the detailed description of a Log View entry. +It is called by the command `log-view-toggle-entry-display' with +one arg, the revision tag (a string), and should return a string. +If it is nil, `log-view-toggle-entry-display' does nothing.") + (defface log-view-file '((((class color) (background light)) (:background "grey70" :weight bold)) @@ -299,15 +306,36 @@ (when cvsdir (setq dir (expand-file-name cvsdir dir)))) (expand-file-name file dir)))) -(defun log-view-current-tag (&optional where) - (save-excursion - (when where (goto-char where)) - (forward-line 1) - (let ((pt (point))) - (when (re-search-backward log-view-message-re nil t) - (let ((rev (match-string-no-properties 1))) - (unless (re-search-forward log-view-file-re pt t) - rev)))))) +(defun log-view-current-entry (&optional pos move) + "Return the position and revision tag of the Log View entry at POS. +This is a list (BEG TAG), where BEG is a buffer position and TAG +is a string. If POS is nil or omitted, it defaults to point. +If there is no entry at POS, return nil. + +If optional arg MOVE is non-nil, move point to BEG if found. +Otherwise, don't move point." + (let ((looping t) + result) + (save-excursion + (when pos (goto-char pos)) + (forward-line 1) + (while looping + (setq pos (re-search-backward log-view-message-re nil 'move) + looping (and pos (log-view-inside-comment-p (point))))) + (when pos + (setq result + (list pos (match-string-no-properties 1))))) + (and move result (goto-char pos)) + result)) + +(defun log-view-inside-comment-p (pos) + "Return non-nil if POS lies inside an expanded log entry." + (eq (get-text-property pos 'log-view-comment) t)) + +(defun log-view-current-tag (&optional pos) + "Return the revision tag (a string) of the Log View entry at POS. +if POS is omitted or nil, it defaults to point." + (cadr (log-view-current-entry pos))) (defun log-view-toggle-mark-entry () "Toggle the marked state for the log entry at point. @@ -317,29 +345,24 @@ log entries." (interactive) (save-excursion - (forward-line 1) - (let ((pt (point))) - (when (re-search-backward log-view-message-re nil t) - (let ((beg (match-beginning 0)) - end ov ovlist found tag) - (unless (re-search-forward log-view-file-re pt t) - ;; Look to see if the current entry is marked. - (setq found (get-char-property (point) 'log-view-self)) - (if found - (delete-overlay found) - ;; Create an overlay that covers this entry and change - ;; its color. - (setq tag (log-view-current-tag (point))) - (forward-line 1) - (setq end - (if (re-search-forward log-view-message-re nil t) - (match-beginning 0) - (point-max))) - (setq ov (make-overlay beg end)) - (overlay-put ov 'face 'log-view-file) - ;; This is used to check if the overlay is present. - (overlay-put ov 'log-view-self ov) - (overlay-put ov 'log-view-marked tag)))))))) + (let* ((entry (log-view-current-entry nil t)) + (beg (car entry)) + found) + (when entry + ;; Look to see if the current entry is marked. + (setq found (get-char-property beg 'log-view-self)) + (if found + (delete-overlay found) + ;; Create an overlay covering this entry and change its color. + (let* ((end (if (get-text-property beg 'log-view-entry-expanded) + (next-single-property-change beg 'log-view-comment) + (log-view-end-of-defun) + (point))) + (ov (make-overlay beg end))) + (overlay-put ov 'face 'log-view-file) + ;; This is used to check if the overlay is present. + (overlay-put ov 'log-view-self ov) + (overlay-put ov 'log-view-marked (nth 1 entry)))))))) (defun log-view-get-marked () "Return the list of tags for the marked log entries." @@ -352,50 +375,74 @@ (setq pos (overlay-end ov)))) marked-list))) -(defun log-view-beginning-of-defun () - ;; This assumes that a log entry starts with a line matching - ;; `log-view-message-re'. Modes that derive from `log-view-mode' - ;; for which this assumption is not valid will have to provide - ;; another implementation of this function. `log-view-msg-prev' - ;; does a similar job to this function, we can't use it here - ;; directly because it prints messages that are not appropriate in - ;; this context and it does not move to the beginning of the buffer - ;; when the point is before the first log entry. - - ;; `log-view-beginning-of-defun' and `log-view-end-of-defun' have - ;; been checked to work with logs produced by RCS, CVS, git, - ;; mercurial and subversion. - - (re-search-backward log-view-message-re nil 'move)) +(defun log-view-toggle-entry-display () + (interactive) + ;; Don't do anything unless `log-view-expanded-log-entry-function' + ;; is defined in this mode. + (when (functionp log-view-expanded-log-entry-function) + (let* ((opoint (point)) + (entry (log-view-current-entry nil t)) + (beg (car entry)) + (buffer-read-only nil)) + (when entry + (if (get-text-property beg 'log-view-entry-expanded) + ;; If the entry is expanded, collapse it. + (let ((pos (next-single-property-change beg 'log-view-comment))) + (unless (and pos (log-view-inside-comment-p pos)) + (error "Broken markup in `log-view-toggle-entry-display'")) + (delete-region pos + (next-single-property-change pos 'log-view-comment)) + (put-text-property beg (1+ beg) 'log-view-entry-expanded nil) + (if (< opoint pos) + (goto-char opoint))) + ;; Otherwise, expand the entry. + (let ((long-entry (funcall log-view-expanded-log-entry-function + (nth 1 entry)))) + (when long-entry + (put-text-property beg (1+ beg) 'log-view-entry-expanded t) + (log-view-end-of-defun) + (setq beg (point)) + (insert long-entry "\n") + (add-text-properties + beg (point) + '(font-lock-face font-lock-comment-face log-view-comment t)) + (goto-char opoint)))))))) + +(defun log-view-beginning-of-defun (&optional arg) + "Move backward to the beginning of a Log View entry. +With ARG, do it that many times. Negative ARG means move forward +to the beginning of the ARGth following entry. + +This is Log View mode's default `beginning-of-defun-function'. +It assumes that a log entry starts with a line matching +`log-view-message-re'." + (if (or (null arg) (zerop arg)) + (setq arg 1)) + (if (< arg 0) + (dotimes (n (- arg)) + (log-view-end-of-defun)) + (catch 'beginning-of-buffer + (dotimes (n arg) + (or (log-view-current-entry nil t) + (throw 'beginning-of-buffer nil))) + (point)))) (defun log-view-end-of-defun () - ;; The idea in this function is to search for the beginning of the - ;; next log entry using `log-view-message-re' and then go back one - ;; line when finding it. Modes that derive from `log-view-mode' for - ;; which this assumption is not valid will have to provide another - ;; implementation of this function. - - ;; Look back and if there is no entry there it means we are before - ;; the first log entry, so go forward until finding one. - (unless (save-excursion (re-search-backward log-view-message-re nil t)) - (re-search-forward log-view-message-re nil t)) - - ;; In case we are at the end of log entry going forward a line will - ;; make us find the next entry when searching. If we are inside of - ;; an entry going forward a line will still keep the point inside - ;; the same entry. - (forward-line 1) - - ;; In case we are at the beginning of an entry, move past it. - (when (looking-at log-view-message-re) - (goto-char (match-end 0)) - (forward-line 1)) - - ;; Search for the start of the next log entry. Go to the end of the - ;; buffer if we could not find a next entry. - (when (re-search-forward log-view-message-re nil 'move) - (goto-char (match-beginning 0)) - (forward-line -1))) + "Move forward to the next Log View entry." + (let ((looping t)) + (if (looking-at log-view-message-re) + (goto-char (match-end 0))) + (while looping + (cond + ((re-search-forward log-view-message-re nil 'move) + (unless (log-view-inside-comment-p (point)) + (setq looping nil) + (goto-char (match-beginning 0)))) + ;; Don't advance past the end buttons inserted by + ;; `vc-print-log-setup-buttons'. + ((looking-back "Show 2X entries Show unlimited entries") + (setq looping nil) + (forward-line -1)))))) (defvar cvs-minor-current-files) (defvar cvs-branch-prefix) === modified file 'lisp/vc/vc-bzr.el' --- lisp/vc/vc-bzr.el 2011-01-29 21:19:21 +0000 +++ lisp/vc/vc-bzr.el 2011-02-13 20:04:33 +0000 @@ -590,6 +590,7 @@ (defvar log-view-font-lock-keywords) (defvar log-view-current-tag-function) (defvar log-view-per-file-logs) +(defvar log-view-expanded-log-entry-function) (define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View" (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack. @@ -600,6 +601,10 @@ (if (eq vc-log-view-type 'short) "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?" "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)")) + ;; Allow expanding short log entries + (when (eq vc-log-view-type 'short) + (set (make-local-variable 'log-view-expanded-log-entry-function) + 'vc-bzr-expanded-log-entry)) (set (make-local-variable 'log-view-font-lock-keywords) ;; log-view-font-lock-keywords is careful to use the buffer-local ;; value of log-view-message-re only since Emacs-23. @@ -637,6 +642,16 @@ (list vc-bzr-log-switches) vc-bzr-log-switches))))) +(defun vc-bzr-expanded-log-entry (revision) + (with-temp-buffer + (apply 'vc-bzr-command "log" t nil nil + (list (format "-r%s" revision))) + (goto-char (point-min)) + (when (looking-at "^-+\n") + ;; Indent the expanded log entry. + (indent-region (match-end 0) (point-max) 2) + (buffer-substring (match-end 0) (point-max))))) + (defun vc-bzr-log-incoming (buffer remote-location) (apply 'vc-bzr-command "missing" buffer 'async nil (list "--theirs-only" (unless (string= remote-location "") remote-location)))) ------------------------------------------------------------ revno: 103258 committer: Andreas Schwab branch nick: emacs timestamp: Sun 2011-02-13 19:35:05 +0100 message: Don't ignore files that are no longer generated diff: === modified file '.bzrignore' --- .bzrignore 2011-02-09 18:59:55 +0000 +++ .bzrignore 2011-02-13 18:35:05 +0000 @@ -43,21 +43,17 @@ lib/unistd.h lib/warn-on-use.h lib-src/stamp-* -lib-src/b2m lib-src/ctags lib-src/ctags.c -lib-src/digest-doc lib-src/ebrowse lib-src/echolisp.tmp lib-src/emacsclient lib-src/etags lib-src/fakemail -lib-src/getopt.h lib-src/hexl lib-src/make-docfile lib-src/movemail lib-src/profile -lib-src/sorted-doc lib-src/test-distrib lib-src/update-game-score lisp/**/*-loaddefs.el === modified file 'lib-src/.gitignore' --- lib-src/.gitignore 2011-01-15 23:16:57 +0000 +++ lib-src/.gitignore 2011-02-13 18:35:05 +0000 @@ -1,6 +1,5 @@ DOC ctags.c -getopt.h stamp_BLD echolisp.tmp ------------------------------------------------------------ revno: 103257 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Sun 2011-02-13 13:44:06 +0000 message: 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: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 13:16:37 +0000 +++ lisp/ChangeLog 2011-02-13 13:44:06 +0000 @@ -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 === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-02-13 00:25:29 +0000 +++ lisp/gnus/ChangeLog 2011-02-13 13:44:06 +0000 @@ -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 === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2011-02-13 00:25:29 +0000 +++ lisp/gnus/nnimap.el 2011-02-13 13:44:06 +0000 @@ -966,7 +966,8 @@ (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 @@ (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 === removed file 'lisp/net/imap.el' --- lisp/net/imap.el 2011-01-25 04:08:28 +0000 +++ lisp/net/imap.el 1970-01-01 00:00:00 +0000 @@ -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 ------------------------------------------------------------ revno: 103256 committer: Ted Zlatanov branch nick: quickfixes timestamp: Sun 2011-02-13 07:16:37 -0600 message: Remove imap-hash.el now that tramp-imap.el is gone. * net/imap-hash.el: Remove file. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 12:25:45 +0000 +++ lisp/ChangeLog 2011-02-13 13:16:37 +0000 @@ -1,3 +1,7 @@ +2011-02-13 Teodor Zlatanov + + * net/imap-hash.el: Remove file. + 2011-02-13 Michael Albinus * Makefile.in (TRAMP_SRC): Remove tramp-imap.el. === removed file 'lisp/net/imap-hash.el' --- lisp/net/imap-hash.el 2011-02-12 17:51:02 +0000 +++ lisp/net/imap-hash.el 1970-01-01 00:00:00 +0000 @@ -1,374 +0,0 @@ -;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox - -;; Copyright (C) 2009-2011 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov -;; Keywords: mail - -;; This program 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. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; This module provides hashtable-like functions on top of imap.el -;; functionality. All the authentication is handled by auth-source so -;; there are no authentication options here, only the server and -;; mailbox names are needed. - -;; Create a IHT (imap-hash table) object with `imap-hash-make'. Then -;; use it with `imap-hash-map' to map a function across all the -;; messages. Use `imap-hash-get' and `imap-hash-rem' to operate on -;; individual messages. See the tramp-imap.el library in Tramp if you -;; need to see practical examples. - -;; This only works with IMAP4r1. Sorry to everyone without it, but -;; the compatibility code is too annoying and it's 2009. - -;; TODO: Use SEARCH instead of FETCH when a test is specified. List -;; available mailboxes. Don't select an invalid mailbox. - -;;; Code: - -(require 'assoc) -(require 'imap) -(require 'sendmail) ; for mail-header-separator -(require 'message) -(autoload 'auth-source-search "auth-source") - -;; retrieve these headers -(defvar imap-hash-headers - (append '(Subject From Date Message-Id References In-Reply-To Xref))) - -;; from nnheader.el -(defsubst imap-hash-remove-cr-followed-by-lf () - (goto-char (point-max)) - (while (search-backward "\r\n" nil t) - (delete-char 1))) - -;; from nnheader.el -(defun imap-hash-ms-strip-cr (&optional string) - "Strip ^M from the end of all lines in current buffer or STRING." - (if string - (with-temp-buffer - (insert string) - (imap-hash-remove-cr-followed-by-lf) - (buffer-string)) - (save-excursion - (imap-hash-remove-cr-followed-by-lf)))) - -(defun imap-hash-make (server port mailbox &optional user password ssl) - "Make a new imap-hash object using SERVER, PORT, and MAILBOX. -USER, PASSWORD and SSL are optional. -The test is set to t, meaning all messages are considered." - (when (and server port mailbox) - (list :server server :port port :mailbox mailbox - :ssl ssl :user user :password password - :test t))) - -(defun imap-hash-p (iht) - "Check whether IHT is a valid imap-hash." - (and - (imap-hash-server iht) - (imap-hash-port iht) - (imap-hash-mailbox iht) - (imap-hash-test iht))) - -(defmacro imap-hash-gather (uid) - `(imap-message-get ,uid 'BODYDETAIL)) - -(defmacro imap-hash-data-body (details) - `(nth 2 (nth 1 ,details))) - -(defmacro imap-hash-data-headers (details) - `(nth 2 (nth 0 ,details))) - -(defun imap-hash-get (key iht &optional refetch) - "Get the value for KEY in the imap-hash IHT. -Requires either `imap-hash-fetch' to be called beforehand -\(e.g. by `imap-hash-map'), or REFETCH to be t. -Returns a list of the headers (an alist, see `imap-hash-map') and -the body of the message as a string. -Also see `imap-hash-test'." - (with-current-buffer (imap-hash-get-buffer iht) - (when refetch - (imap-hash-fetch iht nil key)) - (let ((details (imap-hash-gather key))) - (list - (imap-hash-get-headers - (imap-hash-data-headers details)) - (imap-hash-get-body - (imap-hash-data-body details)))))) - -(defun imap-hash-put (value iht &optional key) - "Put VALUE in the imap-hash IHT. Return the new key. -If KEY is given, removes it. -VALUE can be a list of the headers (an alist, see `imap-hash-map') -and the body of the message as a string. It can also be a uid, -in which case `imap-hash-get' will be called to get the value. -Also see `imap-hash-test'." - (let ((server-buffer (imap-hash-get-buffer iht)) - (value (if (listp value) value (imap-hash-get value iht))) - newuid) - (when value - (with-temp-buffer - (funcall 'imap-hash-make-message - (nth 0 value) - (nth 1 value) - nil) - (setq newuid (nth 1 (imap-message-append - (imap-hash-mailbox iht) - (current-buffer) nil nil server-buffer))) - (when key (imap-hash-rem key iht)))) - newuid)) - -(defun imap-hash-make-message (headers body &optional overrides) - "Make a message with HEADERS and BODY suitable for `imap-append', -using `message-setup'. -Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'." - ;; don't insert a signature no matter what - (let (message-signature) - (message-setup - (append overrides headers)) - (message-generate-headers message-required-mail-headers) - (message-remove-header "X-Draft-From") - (message-goto-body) - (insert (or (aget overrides 'body) - body - "")) - (goto-char (point-min)) - ;; TODO: make this search better - (if (search-forward mail-header-separator nil t) - (delete-region (line-beginning-position) (line-end-position)) - (error "Could not find the body separator in the encoded message!")))) - -(defun imap-hash-rem (key iht) - "Remove KEY in the imap-hash IHT. -Also see `imap-hash-test'. Requires `imap-hash-fetch' to have -been called and the imap-hash server buffer to be current, -so it's best to use it inside `imap-hash-map'. -The key will not be found on the next `imap-hash-map' call." - (with-current-buffer (imap-hash-get-buffer iht) - (imap-message-flags-add - (imap-range-to-message-set (list key)) - "\\Deleted" 'silent) - (imap-mailbox-expunge t))) - -(defun imap-hash-clear (iht) - "Remove all keys in the imap-hash IHT. -Also see `imap-hash-test'." - (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht)) - -(defun imap-hash-get-headers (text-headers) - (with-temp-buffer - (insert (or text-headers "")) - (imap-hash-remove-cr-followed-by-lf) - (mapcar (lambda (header) - (cons header - (message-fetch-field (format "%s" header)))) - imap-hash-headers))) - -(defun imap-hash-get-body (text) - (with-temp-buffer - (insert (or text "")) - (imap-hash-remove-cr-followed-by-lf) - (buffer-string))) - -(defun imap-hash-map (function iht &optional headers-only &rest messages) - "Call FUNCTION for all entries in IHT and pass it the message uid, -the headers (an alist, see `imap-hash-headers'), and the body -contents as a string. If HEADERS-ONLY is not nil, the body will be nil. -Returns results of evaluating, as would `mapcar'. -If MESSAGES are given, iterate only over those UIDs. -Also see `imap-hash-test'." - (imap-hash-fetch iht headers-only) - (let ((test (imap-hash-test iht))) - (with-current-buffer (imap-hash-get-buffer iht) - (delq nil - (imap-message-map (lambda (message ignored-parameter) - (let* ((details (imap-hash-gather message)) - (headers (imap-hash-data-headers details)) - (hlist (imap-hash-get-headers headers)) - (runit (cond - ((stringp test) - (string-match - test - (format "%s" (aget hlist 'Subject)))) - ((functionp test) - (funcall test hlist)) - ;; otherwise, return test itself - (t test)))) - ;;(debug message headers) - (when runit - (funcall function - message - (imap-hash-get-headers - headers) - (imap-hash-get-body - (imap-hash-data-body details)))))) - "UID"))))) - -(defun imap-hash-count (iht) - "Count the number of messages in the imap-hash IHT. -Also see `imap-hash-test'. It uses `imap-hash-map' so just use that -function if you want to do more than count the elements." - (length (imap-hash-map (lambda (a b c)) iht t))) - -(defalias 'imap-hash-size 'imap-hash-count) - -(defun imap-hash-test (iht) - "Return the test used by `imap-hash-map' for IHT. -When the test is t, any key will be a candidate. -When the test is a string, messages will be filtered on that string as a -regexp against the subject. -When the test is a function, messages will be filtered with it. -The function is passed the message headers (see `imap-hash-get-headers')." - (plist-get iht :test)) - -(defun imap-hash-server (iht) - "Return the server used by the imap-hash IHT." - (plist-get iht :server)) - -(defun imap-hash-port (iht) - "Return the port used by the imap-hash IHT." - (plist-get iht :port)) - -(defun imap-hash-ssl (iht) - "Return the SSL need for the imap-hash IHT." - (plist-get iht :ssl)) - -(defun imap-hash-mailbox (iht) - "Return the mailbox used by the imap-hash IHT." - (plist-get iht :mailbox)) - -(defun imap-hash-user (iht) - "Return the username used by the imap-hash IHT." - (plist-get iht :user)) - -(defun imap-hash-password (iht) - "Return the password used by the imap-hash IHT." - (plist-get iht :password)) - -(defun imap-hash-open-connection (iht) - "Open the connection used for IMAP interactions with the imap-hash IHT." - (let* ((server (imap-hash-server iht)) - (port (imap-hash-port iht)) - (ssl-need (imap-hash-ssl iht)) - (auth-need (not (and (imap-hash-user iht) - (imap-hash-password iht)))) - ;; this will not be needed if auth-need is t - (auth-info (when auth-need - (nth 0 (auth-source-search :host server :port port)))) - (auth-user (or (imap-hash-user iht) - (plist-get auth-info :user))) - (auth-passwd (or (imap-hash-password iht) - (plist-get auth-info :secret))) - (auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (imap-logout-timeout nil)) - - ;; (debug "opening server: opened+state" (imap-opened) imap-state) - ;; this is the only place where IMAP vs IMAPS matters - (if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer)) - (progn - ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state) - ;; (debug "authenticating" auth-user auth-passwd) - (if (not (imap-capability 'IMAP4rev1)) - (error "IMAP server does not support IMAP4r1, it won't work, sorry") - (imap-authenticate auth-user auth-passwd) - (imap-id) - ;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state) - (imap-opened (current-buffer)))) - (error "Could not open the IMAP buffer")))) - -(defun imap-hash-get-buffer (iht) - "Get or create the connection buffer to be used for the imap-hash IHT." - (let* ((name (imap-hash-buffer-name iht)) - (buffer (get-buffer name))) - (if (and buffer (imap-opened buffer)) - buffer - (when buffer (kill-buffer buffer)) - (with-current-buffer (get-buffer-create name) - (setq buffer-undo-list t) - (when (imap-hash-open-connection iht) - (current-buffer)))))) - -(defun imap-hash-buffer-name (iht) - "Get the connection buffer to be used for the imap-hash IHT." - (when (imap-hash-p iht) - (let ((server (imap-hash-server iht)) - (port (imap-hash-port iht)) - (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL"))) - (format "*imap-hash/%s:%s:%s*" server port ssl-text)))) - -(defun imap-hash-fetch (iht &optional headers-only &rest messages) - "Fetch all the messages for imap-hash IHT. -Get only the headers if HEADERS-ONLY is not nil." - (with-current-buffer (imap-hash-get-buffer iht) - (let ((range (if messages - (list - (imap-range-to-message-set messages) - (imap-range-to-message-set messages)) - '("1:*" . "1,*:*")))) - - ;; (with-current-buffer "*imap-debug*" - ;; (erase-buffer)) - (imap-mailbox-unselect) - (imap-mailbox-select (imap-hash-mailbox iht)) - ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state) - ;; (setq imap-message-data (make-vector imap-message-prime 0) - (imap-fetch-safe range - (concat (format "(UID RFC822.SIZE BODY %s " - (if headers-only "" "BODY.PEEK[TEXT]")) - (format "BODY.PEEK[HEADER.FIELDS %s])" - imap-hash-headers)))))) - -(provide 'imap-hash) -;;; imap-hash.el ends here - -;; ignore, for testing only - -;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test")) -;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test")) -;;; (imap-hash-make "server1" "INBOX.mailbox2") -;;; (imap-hash-p iht) -;;; (imap-hash-get 35 iht) -;;; (imap-hash-get 38 iht) -;;; (imap-hash-get 37 iht t) -;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) -;;; (imap-hash-put (imap-hash-get 5 iht) iht) -;;; (with-current-buffer (imap-hash-get-buffer iht) (let ((uid (imap-hash-put (imap-hash-get 5 iht) iht))) (imap-hash-put uid iht uid))) -;;; (imap-hash-put (imap-hash-get 35 iht) iht) -;;; (imap-hash-make-message '((Subject . "normal")) "normal body") -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new"))) -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject))) -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject))) -;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil) -;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht)) -;;; (kill-buffer (imap-hash-buffer-name iht)) -;;; (imap-hash-map 'debug iht) -;;; (imap-hash-map 'debug iht t) -;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") -;;;(imap-hash-count iht) -;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) -;;; (kill-buffer (imap-hash-buffer-name iht)) -;;; this should always return t if the server is up, automatically reopening if needed -;;; (imap-opened (imap-hash-get-buffer iht)) -;;; (imap-hash-buffer-name iht) -;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state)) -;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") -;;; (imap-hash-fetch iht nil) -;;; (imap-hash-fetch iht t) -;;; (imap-hash-fetch iht nil 1 2 3) -;;; (imap-hash-fetch iht t 1 2 3) - ------------------------------------------------------------ revno: 103255 committer: Michael Albinus branch nick: trunk timestamp: Sun 2011-02-13 13:57:41 +0100 message: * NEWS: Tramp methods "imap" and "imaps" are discontinued. diff: === modified file 'etc/ChangeLog' --- etc/ChangeLog 2011-02-12 23:40:43 +0000 +++ etc/ChangeLog 2011-02-13 12:57:41 +0000 @@ -1,3 +1,7 @@ +2011-02-13 Michael Albinus + + * NEWS: Tramp methods "imap" and "imaps" are discontinued. + 2011-02-12 Drew Adams * themes/light-blue-theme.el: New file. === modified file 'etc/NEWS' --- etc/NEWS 2011-02-12 19:34:50 +0000 +++ etc/NEWS 2011-02-13 12:57:41 +0000 @@ -588,7 +588,7 @@ *** There exists a new inline access method "ksu" (kerberized su). *** The following access methods are discontinued: "ssh1_old", -"ssh2_old", "scp1_old", "scp2_old" and "fish". +"ssh2_old", "scp1_old", "scp2_old", "imap", "imaps" and "fish". ** VC and related modes ------------------------------------------------------------ revno: 103254 committer: Michael Albinus branch nick: trunk timestamp: Sun 2011-02-13 13:25:45 +0100 message: * Makefile.in (TRAMP_SRC): Remove tramp-imap.el. * net/tramp.el (tramp-read-passwd): Simplify `auth-source-search' call. * net/tramp-imap.el: Remove file. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 03:07:53 +0000 +++ lisp/ChangeLog 2011-02-13 12:25:45 +0000 @@ -1,3 +1,12 @@ +2011-02-13 Michael Albinus + + * Makefile.in (TRAMP_SRC): Remove tramp-imap.el. + + * net/tramp.el (tramp-read-passwd): Simplify `auth-source-search' + call. + + * net/tramp-imap.el: Remove file. + 2011-02-13 Chong Yidong * vc/vc.el (vc-print-log-setup-buttons): Instead of using the === modified file 'lisp/Makefile.in' --- lisp/Makefile.in 2011-01-25 04:08:28 +0000 +++ lisp/Makefile.in 2011-02-13 12:25:45 +0000 @@ -329,16 +329,16 @@ --eval "(setq make-backup-files nil)" \ -f batch-update-autoloads $(MH_E_DIR) -# Update TRAMP internal autoloads. Maybe we could move trmp*.el into +# Update TRAMP internal autoloads. Maybe we could move tramp*.el into # an own subdirectory. OTOH, it does not hurt to keep them in # lisp/net. TRAMP_DIR = $(lisp)/net TRAMP_SRC = $(TRAMP_DIR)/tramp.el $(TRAMP_DIR)/tramp-cache.el \ $(TRAMP_DIR)/tramp-cmds.el $(TRAMP_DIR)/tramp-compat.el \ $(TRAMP_DIR)/tramp-ftp.el $(TRAMP_DIR)/tramp-gvfs.el \ - $(TRAMP_DIR)/tramp-gw.el $(TRAMP_DIR)/tramp-imap.el \ - $(TRAMP_DIR)/tramp-sh.el $(TRAMP_DIR)/tramp-smb.el \ - $(TRAMP_DIR)/tramp-uu.el $(TRAMP_DIR)/trampver.el + $(TRAMP_DIR)/tramp-gw.el $(TRAMP_DIR)/tramp-sh.el \ + $(TRAMP_DIR)/tramp-smb.el $(TRAMP_DIR)/tramp-uu.el \ + $(TRAMP_DIR)/trampver.el $(TRAMP_DIR)/tramp-loaddefs.el: $(TRAMP_SRC) $(emacs) -l autoload \ === removed file 'lisp/net/tramp-imap.el' --- lisp/net/tramp-imap.el 2011-02-12 17:51:02 +0000 +++ lisp/net/tramp-imap.el 1970-01-01 00:00:00 +0000 @@ -1,850 +0,0 @@ -;;; tramp-imap.el --- Tramp interface to IMAP through imap.el - -;; Copyright (C) 2009-2011 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov -;; Keywords: mail, comm -;; Package: tramp - -;; 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: - -;; Package to provide Tramp over IMAP - -;;; Setup: - -;; just load and open files, e.g. -;; /imaps:user@yourhosthere.com:/INBOX.test/1 -;; or -;; /imap:user@yourhosthere.com:/INBOX.test/1 - -;; where `imap' goes over IMAP, while `imaps' goes over IMAP+SSL - -;; This module will use imap-hash.el to access the IMAP mailbox. - -;; This module will use auth-source.el to authenticate against the -;; IMAP server, PLUS it will use auth-source.el to get your passphrase -;; for the symmetrically encrypted messages. For the former, use the -;; usual IMAP ports. For the latter, use the port "tramp-imap". - -;; example .authinfo / .netrc file: - -;; machine yourhosthere.com port tramp-imap login USER password SYMMETRIC-PASSPHRASE - -;; note above is the symmetric encryption passphrase for GPG -;; below is the regular password for IMAP itself and other things on that host - -;; machine yourhosthere.com login USER password NORMAL-PASSWORD - - -;;; Code: - -(require 'assoc) -(require 'tramp) - -(autoload 'auth-source-search "auth-source") -(autoload 'epg-context-operation "epg") -(autoload 'epg-context-set-armor "epg") -(autoload 'epg-context-set-passphrase-callback "epg") -(autoload 'epg-context-set-progress-callback "epg") -(autoload 'epg-decrypt-string "epg") -(autoload 'epg-encrypt-string "epg") -(autoload 'epg-make-context "epg") -(autoload 'imap-hash-get "imap-hash") -(autoload 'imap-hash-make "imap-hash") -(autoload 'imap-hash-map "imap-hash") -(autoload 'imap-hash-put "imap-hash") -(autoload 'imap-hash-rem "imap-hash") - -;; We use the additional header "X-Size" for encoding the size of a file. -(eval-after-load "imap-hash" - '(add-to-list 'imap-hash-headers 'X-Size 'append)) - -;; Define Tramp IMAP method ... -;;;###tramp-autoload -(defconst tramp-imap-method "imap" - "*Method to connect via IMAP protocol.") - -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-methods - (list tramp-imap-method '(tramp-default-port 143)))) - -;; Define Tramp IMAPS method ... -;;;###tramp-autoload -(defconst tramp-imaps-method "imaps" - "*Method to connect via secure IMAP protocol.") - -;; ... and add it to the method list. -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-methods - (list tramp-imaps-method '(tramp-default-port 993)))) - -;; Add a default for `tramp-default-user-alist'. Default is the local user. -;;;###tramp-autoload -(add-to-list - 'tramp-default-user-alist - (list (concat "\\`" - (regexp-opt (list tramp-imap-method tramp-imaps-method)) - "\\'") - nil (user-login-name))) - -;; Add completion function for IMAP method. -;; (tramp-set-completion-function -;; tramp-imap-method tramp-completion-function-alist-ssh) ; TODO: test this -;; tramp-imaps-method tramp-completion-function-alist-ssh) ; TODO: test this - -;; New handlers should be added here. -(defconst tramp-imap-file-name-handler-alist - '( - ;; `access-file' performed by default handler - (add-name-to-file . ignore) - ;; `byte-compiler-base-file-name' performed by default handler - ;; `copy-directory' performed by default handler - (copy-file . tramp-imap-handle-copy-file) - (delete-directory . ignore) ;; tramp-imap-handle-delete-directory) - (delete-file . tramp-imap-handle-delete-file) - ;; `diff-latest-backup-file' performed by default handler - (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes - . tramp-handle-directory-files-and-attributes) - (dired-call-process . ignore) - ;; `dired-compress-file' performed by default handler - ;; `dired-uncache' performed by default handler - (expand-file-name . tramp-imap-handle-expand-file-name) - ;; `file-accessible-directory-p' performed by default handler - (file-attributes . tramp-imap-handle-file-attributes) - (file-directory-p . tramp-imap-handle-file-directory-p) - (file-executable-p . ignore) - (file-exists-p . tramp-handle-file-exists-p) - (file-local-copy . tramp-imap-handle-file-local-copy) - (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-imap-handle-file-name-all-completions) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (file-name-completion . tramp-handle-file-name-completion) - (file-name-directory . tramp-handle-file-name-directory) - (file-name-nondirectory . tramp-handle-file-name-nondirectory) - ;; `file-name-sans-versions' performed by default handler - (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) - (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-handle-file-exists-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-remote-p . tramp-handle-file-remote-p) - ;; `file-selinux-context' performed by default handler. - (file-symlink-p . tramp-handle-file-symlink-p) - ;; `file-truename' performed by default handler - (file-writable-p . tramp-imap-handle-file-writable-p) - (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler - ;; `get-file-buffer' performed by default handler - (insert-directory . tramp-imap-handle-insert-directory) - (insert-file-contents . tramp-imap-handle-insert-file-contents) - (load . tramp-handle-load) - (make-directory . ignore) ;; tramp-imap-handle-make-directory) - (make-directory-internal . ignore) ;; tramp-imap-handle-make-directory-internal) - (make-symbolic-link . ignore) - (rename-file . tramp-imap-handle-rename-file) - (set-file-modes . ignore) - ;; `set-file-selinux-context' performed by default handler. - (set-file-times . ignore) ;; tramp-imap-handle-set-file-times) - (set-visited-file-modtime . ignore) - (shell-command . ignore) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (vc-registered . ignore) - (verify-visited-file-modtime . ignore) - (write-region . tramp-imap-handle-write-region) - (executable-find . ignore) - (start-file-process . ignore) - (process-file . ignore) -) - "Alist of handler functions for Tramp IMAP method. -Operations not mentioned here will be handled by the default Emacs primitives.") - -(defgroup tramp-imap nil - "Tramp over IMAP configuration." - :version "23.2" - :group 'tramp) - -(defcustom tramp-imap-subject-marker "tramp-imap-subject-marker" - "The subject marker that Tramp-IMAP will use." - :type 'string - :version "23.2" - :group 'tramp-imap) - -;; TODO: these will be defcustoms later. -(defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never -(defvar tramp-imap-passphrase nil) - -;;;###tramp-autoload -(defsubst tramp-imap-file-name-p (filename) - "Check if it's a filename for IMAP protocol." - (let ((v (tramp-dissect-file-name filename))) - (or - (string= (tramp-file-name-method v) tramp-imap-method) - (string= (tramp-file-name-method v) tramp-imaps-method)))) - -;;;###tramp-autoload -(defun tramp-imap-file-name-handler (operation &rest args) - "Invoke the IMAP related OPERATION. -First arg specifies the OPERATION, second arg is a list of arguments to -pass to the OPERATION." - (let ((fn (assoc operation tramp-imap-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) - -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))) - -(defun tramp-imap-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (tramp-imap-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) - -(defun tramp-imap-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - (tramp-imap-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t)) - -(defun tramp-imap-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to perform. -FILENAME specifies the file to copy or rename, NEWNAME is the name of -the new file (for copy) or the new name of the file (for rename). -OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid if both files are on the same host. - -This function is invoked by `tramp-imap-handle-copy-file' and -`tramp-imap-handle-rename-file'. It is an error if OP is neither -of `copy' and `rename'." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (when (file-directory-p newname) - (setq newname (expand-file-name (file-name-nondirectory filename) newname))) - - (let ((t1 (and (tramp-tramp-file-p filename) - (tramp-imap-file-name-p filename))) - (t2 (and (tramp-tramp-file-p newname) - (tramp-imap-file-name-p newname)))) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (with-progress-reporter - v 0 (format "%s %s to %s" - (if (eq op 'copy) "Copying" "Renaming") - filename newname) - - ;; We just make a local copy of FILENAME, and write it then to - ;; NEWNAME. This must be optimized when both files are - ;; located on the same IMAP server. - (with-temp-buffer - (if (and t1 t2) - ;; We don't encrypt. - (with-parsed-tramp-file-name newname v1 - (insert (tramp-imap-get-file filename nil)) - (tramp-imap-put-file - v1 (current-buffer) - (tramp-imap-file-name-name v1) - nil nil (nth 7 (file-attributes filename)))) - ;; One of them is not located on a IMAP mailbox. - (insert-file-contents filename) - (write-region (point-min) (point-max) newname))))) - - (when (eq op 'rename) (delete-file filename)))) - -;; TODO: revise this much -(defun tramp-imap-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler. - (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) - (tramp-drop-volume-letter - (tramp-run-real-handler 'expand-file-name (list name nil))) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "/" localname))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). - ;; We bind `directory-sep-char' here for XEmacs on Windows, - ;; which would otherwise use backslash. `default-directory' is - ;; bound, because on Windows there would be problems with UNC - ;; shares or Cygwin mounts. - (let ((default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-imap-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (save-match-data - (let ((entries - (tramp-imap-get-file-entries v localname))) - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 9 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - entries)))))) - -(defun tramp-imap-get-file-entries (vec localname &optional exact) - "Read entries returned by IMAP server. EXACT limits to exact matches. -Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD INODE DEVICE)." - (tramp-message vec 5 "working on %s" localname) - (let* ((name (tramp-imap-file-name-name vec)) - (search-name (or name "")) - (search-name (if exact (concat search-name "$") search-name)) - (iht (tramp-imap-make-iht vec search-name))) -;; TODO: catch errors - ;; (tramp-error vec 'none "bad name %s or mailbox %s" name mbox)) - (imap-hash-map (lambda (uid headers body) - (let ((subject (substring - (aget headers 'Subject "") - (length tramp-imap-subject-marker))) - (from (aget headers 'From "")) - (date (date-to-time (aget headers 'Date ""))) - (size (string-to-number - (or (aget headers 'X-Size "0") "0")))) - (setq from - (if (string-match "<\\([^@]+\\)@" from) - (match-string 1 from) - "nobody")) - (list - subject - nil - -1 - from - "nogroup" - date - date - date - size - "-rw-rw-rw-" - nil - uid - (tramp-get-device vec)))) - iht t))) - -(defun tramp-imap-handle-write-region (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; XEmacs takes a coding system as the seventh argument, not `confirm'. - (when (and (not (featurep 'xemacs)) - confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) - (tramp-flush-file-property v localname) - (let* ((old-buffer (current-buffer)) - (inode (tramp-imap-get-file-inode filename)) - (min 1) - (max (point-max)) - ;; Make sure we have good start and end values. - (start (or start min)) - (end (or end max)) - temp-buffer) - (with-temp-buffer - (setq temp-buffer (if (and (eq start min) (eq end max)) - old-buffer - ;; If this is a region write, insert the substring. - (insert - (with-current-buffer old-buffer - (buffer-substring-no-properties start end))) - (current-buffer))) - (tramp-imap-put-file v - temp-buffer - (tramp-imap-file-name-name v) - inode - t))) - (when (eq visit t) - (set-visited-file-modtime)))) - -(defun tramp-imap-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (setq filename (expand-file-name filename)) - (if full-directory-p - ;; Called from `dired-add-entry'. - (setq filename (file-name-as-directory filename)) - (setq filename (directory-file-name filename))) - (with-parsed-tramp-file-name filename nil - (save-match-data - (let ((base (file-name-nondirectory localname)) - (entries (copy-sequence - (tramp-imap-get-file-entries - v (file-name-directory localname))))) - - (when wildcard - (when (string-match "\\." base) - (setq base (replace-match "\\\\." nil nil base))) - (when (string-match "\\*" base) - (setq base (replace-match ".*" nil nil base))) - (when (string-match "\\?" base) - (setq base (replace-match ".?" nil nil base)))) - - ;; Filter entries. - (setq entries - (delq - nil - (if (or wildcard (zerop (length base))) - ;; Check for matching entries. - (mapcar - (lambda (x) - (when (string-match - (format "^%s" base) (nth 0 x)) - x)) - entries) - ;; We just need the only and only entry FILENAME. - (list (assoc base entries))))) - - ;; Sort entries. - (setq entries - (sort - entries - (lambda (x y) - (if (string-match "t" switches) - ;; Sort by date. - (tramp-time-less-p (nth 6 y) (nth 6 x)) - ;; Sort by name. - (string-lessp (nth 0 x) (nth 0 y)))))) - - ;; Handle "-F" switch. - (when (string-match "F" switches) - (mapc - (lambda (x) - (when (not (zerop (length (car x)))) - (cond - ((char-equal ?d (string-to-char (nth 9 x))) - (setcar x (concat (car x) "/"))) - ((char-equal ?x (string-to-char (nth 9 x))) - (setcar x (concat (car x) "*")))))) - entries)) - - ;; Print entries. - (mapcar - (lambda (x) - (when (not (zerop (length (nth 0 x)))) - (insert - (format - "%10s %3d %-8s %-8s %8s %s " - (nth 9 x) ; mode - (nth 11 x) ; inode - (nth 3 x) ; uid - (nth 4 x) ; gid - (nth 8 x) ; size - (format-time-string - (if (tramp-time-less-p - (tramp-time-subtract (current-time) (nth 6 x)) - tramp-half-a-year) - "%b %e %R" - "%b %e %Y") - (nth 6 x)))) ; date - ;; For the file name, we set the `dired-filename' - ;; property. This allows to handle file names with - ;; leading or trailing spaces as well. The inserted name - ;; could be from somewhere else, so we use the relative - ;; file name of `default-directory'. - (let ((pos (point))) - (insert - (format - "%s\n" - (file-relative-name - (expand-file-name (nth 0 x) (file-name-directory filename))))) - (put-text-property pos (1- (point)) 'dired-filename t)) - (forward-line) - (beginning-of-line))) - entries))))) - -(defun tramp-imap-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (when visit - (setq buffer-file-name (expand-file-name filename)) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (with-parsed-tramp-file-name filename nil - (if (not (file-exists-p filename)) - (tramp-error - v 'file-error "File `%s' not found on remote host" filename) - (let ((point (point)) - size data) - (with-progress-reporter v 3 (format "Fetching file %s" filename) - (insert (tramp-imap-get-file filename t)) - (setq size (- (point) point)) -;;; TODO: handle ranges. -;;; (let ((beg (or beg (point-min))) -;;; (end (min (or end (point-max)) (point-max)))) -;;; (setq size (- end beg)) -;;; (buffer-substring beg end)) - (goto-char point) - (list (expand-file-name filename) size)))))) - -(defun tramp-imap-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp-IMAP files." - ;; We allow only mailboxes to be a directory. - (with-parsed-tramp-file-name (expand-file-name filename default-directory) nil - (and (string-match "^/[^/]*$" (directory-file-name localname)) t))) - -(defun tramp-imap-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp-IMAP FILENAME." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (let ((res (cdr-safe (nth 0 (tramp-imap-get-file-entries v localname))))) - (unless (or (null res) (eq id-format 'string)) - (setcar (nthcdr 2 res) 1) - (setcar (nthcdr 3 res) 1)) - res))) - -(defun tramp-imap-get-file-inode (filename &optional id-format) - "Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME." - (nth 10 (tramp-compat-file-attributes filename id-format))) - -(defun tramp-imap-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files. True for IMAP." - ;; `file-exists-p' does not work yet for directories. - ;; (file-exists-p (file-name-directory filename))) - (file-directory-p (file-name-directory filename))) - -(defun tramp-imap-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (cond - ((not (file-exists-p filename)) nil) - (t (with-parsed-tramp-file-name (expand-file-name filename) nil - (let ((iht (tramp-imap-make-iht v))) - (imap-hash-rem (tramp-imap-get-file-inode filename) iht)))))) - -(defun tramp-imap-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (with-temp-buffer - (insert-file-contents filename) - (write-region (point-min) (point-max) tmpfile) - tmpfile))))) - -(defun tramp-imap-put-file - (vec filename-or-buffer &optional subject inode encode size) - "Write contents of FILENAME-OR-BUFFER to Tramp-IMAP file VEC with name SUBJECT. -When INODE is given, delete that old remote file after writing the new one -\(normally this is the old file with the same name). A non-nil ENCODE -forces the encoding of the buffer or file. SIZE, when available, indicates -the file size; this is needed, if the file or buffer is already encoded." - ;; `tramp-current-host' is used in `tramp-imap-passphrase-callback-function'. - (let ((tramp-current-host (tramp-file-name-real-host vec)) - (iht (tramp-imap-make-iht vec))) - (imap-hash-put (list - (list (cons - 'Subject - (format - "%s%s" - tramp-imap-subject-marker - (or subject "no subject"))) - (cons - 'X-Size - (number-to-string - (cond - ((numberp size) size) - ((bufferp filename-or-buffer) - (buffer-size filename-or-buffer)) - ((stringp filename-or-buffer) - (nth 7 (file-attributes filename-or-buffer))) - ;; We don't know the size. - (t -1))))) - (cond ((bufferp filename-or-buffer) - (with-current-buffer filename-or-buffer - (if encode - (tramp-imap-encode-buffer) - (buffer-string)))) - ;; TODO: allow file names. - (t "No body available"))) - iht - inode))) - -(defun tramp-imap-get-file (filename &optional decode) - ;; (debug (tramp-imap-get-file-inode filename)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (condition-case () - ;; `tramp-current-host' is used in - ;; `tramp-imap-passphrase-callback-function'. - (let* ((tramp-current-host (tramp-file-name-real-host v)) - (iht (tramp-imap-make-iht v)) - (inode (tramp-imap-get-file-inode filename)) - (data (imap-hash-get inode iht t))) - (if decode - (with-temp-buffer - (insert (nth 1 data)) - ;;(debug inode (buffer-string)) - (tramp-imap-decode-buffer)) - (nth 1 data))) - (error (tramp-error - v 'file-error "File `%s' could not be read" filename))))) - -(defun tramp-imap-passphrase-callback-function (context key-id handback) - "Called by EPG to get a passphrase for Tramp-IMAP. -CONTEXT is the encryption/decryption EPG context. -HANDBACK is just carried through. -KEY-ID can be 'SYM or 'PIN among others." - (let* ((server tramp-current-host) - (port "tramp-imap") ; this is NOT the server password! - (auth-passwd (plist-get - (nth 0 (auth-source-search :max 1 - :host server - :port port)) - :secret)) - (auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd))) - (or - (copy-sequence auth-passwd) - ;; If we cache the passphrase and we have one. - (if (and (eq tramp-imap-passphrase-cache t) - tramp-imap-passphrase) - ;; Do we reuse it? - (if (y-or-n-p "Reuse the passphrase? ") - (copy-sequence tramp-imap-passphrase) - ;; Don't reuse: revert caching behavior to nil, erase passphrase, - ;; call ourselves again. - (setq tramp-imap-passphrase-cache nil) - (setq tramp-imap-passphrase nil) - (tramp-imap-passphrase-callback-function context key-id handback)) - (let ((p (if (eq key-id 'SYM) - (read-passwd - "Tramp-IMAP passphrase for symmetric encryption: " - (eq (epg-context-operation context) 'encrypt) - tramp-imap-passphrase) - (read-passwd - (if (eq key-id 'PIN) - "Tramp-IMAP passphrase for PIN: " - (let ((entry (assoc key-id - (symbol-value 'epg-user-id-alist)))) - (if entry - (format "Tramp-IMAP passphrase for %s %s: " - key-id (cdr entry)) - (format "Tramp-IMAP passphrase for %s: " key-id)))) - nil - tramp-imap-passphrase)))) - - ;; If we have an answer, the passphrase has changed, - ;; the user hasn't declined keeping the passphrase, - ;; and they answer yes to keep it now... - (when (and - p - (not (equal tramp-imap-passphrase p)) - (not (eq tramp-imap-passphrase-cache 'never)) - (y-or-n-p "Keep the passphrase? ")) - (setq tramp-imap-passphrase (copy-sequence p)) - (setq tramp-imap-passphrase-cache t)) - - ;; If we still don't have a passphrase, the user didn't want - ;; to keep it. - (when (and - p - (not tramp-imap-passphrase)) - (setq tramp-imap-passphrase-cache 'never)) - - p))))) - -(defun tramp-imap-encode-buffer () - (let ((context (epg-make-context 'OpenPGP)) - cipher) - (epg-context-set-armor context t) - (epg-context-set-passphrase-callback context - #'tramp-imap-passphrase-callback-function) - (epg-context-set-progress-callback context - (cons #'epa-progress-callback-function - "Encrypting...")) - (message "Encrypting...") - (setq cipher (epg-encrypt-string - context - (encode-coding-string (buffer-string) 'utf-8) - nil)) - (message "Encrypting...done") - cipher)) - -(defun tramp-imap-decode-buffer () - (let ((context (epg-make-context 'OpenPGP)) - plain) - (epg-context-set-passphrase-callback context - #'tramp-imap-passphrase-callback-function) - (epg-context-set-progress-callback context - (cons #'epa-progress-callback-function - "Decrypting...")) - (message "Decrypting...") - (setq plain (decode-coding-string - (epg-decrypt-string context (buffer-string)) - 'utf-8)) - (message "Decrypting...done") - plain)) - -(defun tramp-imap-file-name-mailbox (vec) - (nth 0 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-name (vec) - (nth 1 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-localname (vec) - (nth 1 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-parse (vec) - (let ((name (substring-no-properties (tramp-file-name-localname vec)))) - (if (string-match "^/\\([^/]+\\)/?\\(.*\\)$" name) - (list (match-string 1 name) - (match-string 2 name)) - nil))) - -(defun tramp-imap-make-iht (vec &optional needed-subject) - "Translate the Tramp vector VEC to the imap-hash structure. -With NEEDED-SUBJECT, alters the imap-hash test accordingly." - (let* ((mbox (tramp-imap-file-name-mailbox vec)) - (server (tramp-file-name-real-host vec)) - (method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (ssl (string-equal method tramp-imaps-method)) - (port (tramp-file-name-port vec)) - (result (imap-hash-make server port mbox user nil ssl))) - ;; Return the IHT with a test override to look for the subject - ;; marker. - (plist-put - result - :test (format "^%s%s" - tramp-imap-subject-marker - (if needed-subject needed-subject ""))))) - -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-imap 'force))) - -;;; TODO: - -;; * Implement `tramp-imap-handle-delete-directory', -;; `tramp-imap-handle-make-directory', -;; `tramp-imap-handle-make-directory-internal', -;; `tramp-imap-handle-set-file-times'. - -;; * Encode the subject. If the filename has trailing spaces (like -;; "test "), those characters get lost, for example in dired listings. - -;; * When opening a dired buffer, like "/imap::INBOX.test", there are -;; several error messages: -;; "Buffer has a running process; kill it? (yes or no) " -;; "error in process filter: Internal error, tag 6 status BAD code nil text No mailbox selected." -;; Afterwards, everything seems to be fine. - -;; * imaps works for local IMAP servers. Accessing -;; "/imaps:imap.gmail.com:/INBOX.test/" results in error -;; "error in process filter: Internal error, tag 5 status BAD code nil text UNSELECT not allowed now." - -;; * Improve `tramp-imap-handle-file-attributes' for directories. - -;; * Saving a file creates a second one, instead of overwriting. - -;; * Backup files: just *one* is kept. - -;; * Password requests shall have a descriptive prompt. - -;; * Exiting Emacs, there are running IMAP processes. Make them quiet -;; by `set-process-query-on-exit-flag'. - -(provide 'tramp-imap) -;;; tramp-imap.el ends here - -;; Ignore, for testing only. - -;;; (setq tramp-imap-subject-marker "T") -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t t) -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome") -;;; (dired-copy-file "/etc/fstab" "/imap:yourhosthere.com:/test/welcome" t) -;;; (write-region 1 100 "/imap:yourhosthere.com:/test/welcome") -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t) -;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome")) -;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome2")) -;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2") -;;(file-name-directory "/imap:yourhosthere.com:/test/welcome2") -;;(with-temp-buffer (insert "hello") (delete-file "/tmp/hellotest") (write-file "/tmp/hellotest") (write-file "/imap:yourhosthere.com:/test/welcome2")) -;;;(file-exists-p "/imap:yourhosthere.com:/INBOX.test/4") -;;;(file-attributes "/imap:yourhosthere.com:/INBOX.test/4") -;;;(setq vec (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4")) -;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/INBOX.test/4") -;;; (tramp-imap-handle-insert-file-contents "/imap:user@yourhosthere.com:/INBOX.test/4" nil nil nil nil) -;;;(insert-file-contents "/imap:yourhosthere.com:/INBOX.test/4") -;;;(file-attributes "/imap:yourhosthere.com:/test/welcommen") -;;;(insert-file-contents "/imap:yourhosthere.com:/test/welcome") -;;;(file-exists-p "/imap:yourhosthere.com:/test/welcome2") -;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/test/welcome") -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcommen") -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome") -;;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2") -;;; (delete-file "/imap:yourhosthere.com:/test/welcome") -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcommen" t) -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test")) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/old")) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/two")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/one")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra") === modified file 'lisp/net/tramp.el' --- lisp/net/tramp.el 2011-02-12 17:51:02 +0000 +++ lisp/net/tramp.el 2011-02-13 12:25:45 +0000 @@ -3526,23 +3526,24 @@ (with-parsed-tramp-file-name key nil (prog1 (or - ;; See if auth-sources contains something useful, if it's bound. + ;; See if auth-sources contains something useful, if it's + ;; bound. `auth-source-user-or-password' is an obsoleted + ;; function, it has been replaced by `auth-source-search'. (and (boundp 'auth-sources) (tramp-get-connection-property v "first-password-request" nil) ;; Try with Tramp's current method. (if (fboundp 'auth-source-search) - (progn - (setq auth-info + (setq auth-info (tramp-compat-funcall 'auth-source-search :max 1 :user (or tramp-current-user t) :host tramp-current-host - :port tramp-current-method)) - (setq auth-passwd (plist-get (nth 0 auth-info) :secret)) - (setq auth-passwd (if (functionp auth-passwd) + :port tramp-current-method) + auth-passwd (plist-get (nth 0 auth-info) :secret) + auth-passwd (if (functionp auth-passwd) (funcall auth-passwd) - auth-passwd))) + auth-passwd)) (tramp-compat-funcall 'auth-source-user-or-password "password" tramp-current-host tramp-current-method))) ------------------------------------------------------------ revno: 103253 committer: Michael Albinus branch nick: trunk timestamp: Sun 2011-02-13 13:21:04 +0100 message: * tramp.texi (History): Remove IMAP support. (External methods, Frequently Asked Questions): Remove `imap' and `imaps' methods. (Password handling): Remove IMAP entries for ~/.authinfo.gpg. * trampver.texi: Remove default value of `emacsimap'. diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2011-02-13 02:21:30 +0000 +++ doc/misc/ChangeLog 2011-02-13 12:21:04 +0000 @@ -1,3 +1,12 @@ +2011-02-13 Michael Albinus + + * tramp.texi (History): Remove IMAP support. + (External methods, Frequently Asked Questions): Remove `imap' and + `imaps' methods. + (Password handling): Remove IMAP entries for ~/.authinfo.gpg. + + * trampver.texi: Remove default value of `emacsimap'. + 2011-02-13 Glenn Morris * ada-mode.texi, dired-x.texi, ebrowse.texi, ediff.texi, eudc.texi: === modified file 'doc/misc/tramp.texi' --- doc/misc/tramp.texi 2011-02-05 22:30:14 +0000 +++ doc/misc/tramp.texi 2011-02-13 12:21:04 +0000 @@ -443,9 +443,6 @@ @ifset emacsgvfs GVFS integration started in February 2009. @end ifset -@ifset emacsimap -Storing files into IMAP mailboxes has been added in September 2009. -@end ifset In December 2001, @value{tramp} has been added to the XEmacs package repository. Being part of the GNU Emacs repository happened in June @@ -1012,29 +1009,6 @@ file names like @file{//melancholia/daniel$$/.emacs}. The only disadvantage is that there's no possibility to specify another user name. - - -@ifset emacsimap -@item @option{imap} -@cindex method imap -@cindex method imaps -@cindex imap method -@cindex imaps method - -Accessing an IMAP mailbox is intended to save files there as encrypted -messages. It could be used in case there are no other remote file -storages available. - -@value{tramp} supports both @option{imap} and @option{imaps} methods. -The latter one accesses the IMAP server over ssl. - -Both methods support the port number specification. - -Note that special handling is needed for declaring a passphrase for -encryption / decryption of the messages (@pxref{Using an -authentication file}). - -@end ifset @end table @@ -1625,18 +1599,6 @@ @pxref{External methods}), to match only this method. When you omit the port, you match all @value{tramp} methods. -@ifset emacsimap -A special case are @option{imap}-like methods. Authentication with -the IMAP server is performed via @file{imap.el}, there is no special -need from @value{tramp} point of view. An additional passphrase, used -for symmetric encryption and decryption of the stored messages, should -be given with the special port indication @option{tramp-imap}: - -@example -machine melancholia port tramp-imap login daniel password ultrageheim -@end example -@end ifset - @anchor{Caching passwords} @subsection Caching passwords @@ -2782,9 +2744,9 @@ XEmacs 21 (starting with 21.4), and SXEmacs 22. The package was intended to work on Unix, and it really expects a -Unix-like system on the remote end (except the @option{smb} and -@option{imap} methods), but some people seemed to have some success -getting it to work on MS Windows XP/Vista/7 @value{emacsname}. +Unix-like system on the remote end (except the @option{smb} method), +but some people seemed to have some success getting it to work on MS +Windows XP/Vista/7 @value{emacsname}. @item === modified file 'doc/misc/trampver.texi' --- doc/misc/trampver.texi 2011-02-05 10:11:32 +0000 +++ doc/misc/trampver.texi 2011-02-13 12:21:04 +0000 @@ -28,11 +28,6 @@ @set emacsgw @end ifclear -@c Whether or not describe IMAP support. -@ifclear noemacsimap -@set emacsimap -@end ifclear - @c Some flags which make the text independent on the (X)Emacs flavor. @c "emacs" resp "xemacs" are set in the Makefile. Default is "emacs". @ifclear emacs ------------------------------------------------------------ revno: 103252 committer: Jan D branch nick: trunk timestamp: Sun 2011-02-13 12:28:42 +0100 message: * callproc.c (Fcall_process): * process.c (create_process): Replace Gtk with GConf in SIGPIPE comment. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2011-02-13 00:16:28 +0000 +++ src/ChangeLog 2011-02-13 11:28:42 +0000 @@ -1,3 +1,9 @@ +2011-02-13 Jan Djärv + + * callproc.c (Fcall_process): + * process.c (create_process): Replace Gtk with GConf in SIGPIPE + comment. + 2011-02-12 Martin Rudalics * window.c (select_window): Check inhibit_point_swap argument when === modified file 'src/callproc.c' --- src/callproc.c 2011-02-12 18:53:24 +0000 +++ src/callproc.c 2011-02-13 11:28:42 +0000 @@ -559,9 +559,9 @@ setpgrp (pid, pid); #endif /* USG */ - /* GTK causes us to ignore SIGPIPE, make sure it is restored + /* GConf causes us to ignore SIGPIPE, make sure it is restored in the child. */ - signal (SIGPIPE, SIG_DFL); + //signal (SIGPIPE, SIG_DFL); #ifdef HAVE_WORKING_VFORK sigprocmask (SIG_SETMASK, &procmask, 0); #endif === modified file 'src/process.c' --- src/process.c 2011-02-12 18:53:24 +0000 +++ src/process.c 2011-02-13 11:28:42 +0000 @@ -2056,7 +2056,7 @@ signal (SIGINT, SIG_DFL); signal (SIGQUIT, SIG_DFL); - /* GTK causes us to ignore SIGPIPE, make sure it is restored + /* GConf causes us to ignore SIGPIPE, make sure it is restored in the child. */ signal (SIGPIPE, SIG_DFL); ------------------------------------------------------------ revno: 103251 committer: Chong Yidong branch nick: trunk timestamp: Sat 2011-02-12 22:07:53 -0500 message: Use simple buttons, instead of widget buttons, in vc-log. * lisp/vc/vc.el (vc-print-log-setup-buttons): Instead of using the widget library for buttons, just use button.el. * lisp/vc/log-view.el (log-view-mode-map): Don't inherit from widget-keymap. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-02-13 01:01:11 +0000 +++ lisp/ChangeLog 2011-02-13 03:07:53 +0000 @@ -1,3 +1,11 @@ +2011-02-13 Chong Yidong + + * vc/vc.el (vc-print-log-setup-buttons): Instead of using the + widget library for buttons, just use button.el. + + * vc/log-view.el (log-view-mode-map): Don't inherit from + widget-keymap. + 2011-02-12 Glenn Morris * emacs-lisp/cl-seq.el (union, nunion, intersection) === modified file 'lisp/vc/log-view.el' --- lisp/vc/log-view.el 2011-02-01 21:22:21 +0000 +++ lisp/vc/log-view.el 2011-02-13 03:07:53 +0000 @@ -147,7 +147,6 @@ ("\M-n" . log-view-file-next) ("\M-p" . log-view-file-prev)) "Log-View's keymap." - :inherit widget-keymap :group 'log-view) (easy-menu-define log-view-mode-menu log-view-mode-map === modified file 'lisp/vc/vc.el' --- lisp/vc/vc.el 2011-01-29 03:12:32 +0000 +++ lisp/vc/vc.el 2011-02-13 03:07:53 +0000 @@ -2014,22 +2014,20 @@ (goto-char (point-max)) (lexical-let ((working-revision working-revision) (limit limit)) - (widget-create 'push-button - :notify (lambda (&rest ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil (* 2 limit))) - :help-echo "Show the log again, and double the number of log entries shown" - "Show 2X entries") - (widget-insert " ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil nil)) - :help-echo "Show the log again, showing all entries" - "Show unlimited entries")) - (widget-setup))) + (insert "\n") + (insert-text-button "Show 2X entries" + 'action (lambda (&rest ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil (* 2 limit))) + 'help-echo "Show the log again, and double the number of log entries shown") + (insert " ") + (insert-text-button "Show unlimited entries" + 'action (lambda (&rest ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil nil)) + 'help-echo "Show the log again, including all entries")))) (defun vc-print-log-internal (backend files working-revision &optional is-start-revision limit)