Mercurial > emacs
comparison lisp/net/imap.el @ 100993:a16e9f7c2536
Merge from gnus--devo--0
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1513
author | Miles Bader <miles@gnu.org> |
---|---|
date | Fri, 09 Jan 2009 03:01:50 +0000 |
parents | a9dc0e7c3f2b |
children | d775b84fdd71 |
comparison
equal
deleted
inserted
replaced
100992:5cb6d276b93a | 100993:a16e9f7c2536 |
---|---|
1 ;;; imap.el --- imap library | 1 ;;; imap.el --- imap library |
2 | 2 |
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, | 3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
4 ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | 4 ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
5 | 5 |
6 ;; Author: Simon Josefsson <jas@pdc.kth.se> | 6 ;; Author: Simon Josefsson <simon@josefsson.org> |
7 ;; Keywords: mail | 7 ;; Keywords: mail |
8 | 8 |
9 ;; This file is part of GNU Emacs. | 9 ;; This file is part of GNU Emacs. |
10 | 10 |
11 ;; GNU Emacs is free software: you can redistribute it and/or modify | 11 ;; GNU Emacs is free software: you can redistribute it and/or modify |
21 ;; You should have received a copy of the GNU General Public License | 21 ;; You should have received a copy of the GNU General Public License |
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | 22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23 | 23 |
24 ;;; Commentary: | 24 ;;; Commentary: |
25 | 25 |
26 ;; imap.el is a elisp library providing an interface for talking to | 26 ;; imap.el is an elisp library providing an interface for talking to |
27 ;; IMAP servers. | 27 ;; IMAP servers. |
28 ;; | 28 ;; |
29 ;; imap.el is roughly divided in two parts, one that parses IMAP | 29 ;; imap.el is roughly divided in two parts, one that parses IMAP |
30 ;; responses from the server and storing data into buffer-local | 30 ;; responses from the server and storing data into buffer-local |
31 ;; variables, and one for utility functions which send commands to | 31 ;; variables, and one for utility functions which send commands to |
70 ;; | 70 ;; |
71 ;; It is my hope that these commands should be pretty self | 71 ;; It is my hope that these commands should be pretty self |
72 ;; explanatory for someone that know IMAP. All functions have | 72 ;; explanatory for someone that know IMAP. All functions have |
73 ;; additional documentation on how to invoke them. | 73 ;; additional documentation on how to invoke them. |
74 ;; | 74 ;; |
75 ;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented | 75 ;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1). The implemented |
76 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 | 76 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 |
77 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS, | 77 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS, |
78 ;; LOGINDISABLED) (with use of external library starttls.el and | 78 ;; LOGINDISABLED) (with use of external library starttls.el and |
79 ;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731 | 79 ;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731 |
80 ;; (with use of external program `imtest'), RFC2971 (ID). It also | 80 ;; (with use of external program `imtest'), and RFC2971 (ID). It also |
81 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD. | 81 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD. |
82 ;; | 82 ;; |
83 ;; Without the work of John McClary Prevost and Jim Radford this library | 83 ;; Without the work of John McClary Prevost and Jim Radford this library |
84 ;; would not have seen the light of day. Many thanks. | 84 ;; would not have seen the light of day. Many thanks. |
85 ;; | 85 ;; |
86 ;; This is a transcript of short interactive session for demonstration | 86 ;; This is a transcript of a short interactive session for demonstration |
87 ;; purposes. | 87 ;; purposes. |
88 ;; | 88 ;; |
89 ;; (imap-open "my.mail.server") | 89 ;; (imap-open "my.mail.server") |
90 ;; => " *imap* my.mail.server:0" | 90 ;; => " *imap* my.mail.server:0" |
91 ;; | 91 ;; |
92 ;; The rest are invoked with current buffer as the buffer returned by | 92 ;; The rest are invoked with current buffer as the buffer returned by |
93 ;; `imap-open'. It is possible to do all without this, but it would | 93 ;; `imap-open'. It is possible to do it all without this, but it would |
94 ;; look ugly here since `buffer' is always the last argument for all | 94 ;; look ugly here since `buffer' is always the last argument for all |
95 ;; imap.el API functions. | 95 ;; imap.el API functions. |
96 ;; | 96 ;; |
97 ;; (imap-authenticate "myusername" "mypassword") | 97 ;; (imap-authenticate "myusername" "mypassword") |
98 ;; => auth | 98 ;; => auth |
119 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...." | 119 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...." |
120 ;; | 120 ;; |
121 ;; Todo: | 121 ;; Todo: |
122 ;; | 122 ;; |
123 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. | 123 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. |
124 ;; Use IEEE floats (which are effectively exact)? -- fx | |
124 ;; o Don't use `read' at all (important places already fixed) | 125 ;; o Don't use `read' at all (important places already fixed) |
125 ;; o Accept list of articles instead of message set string in most | 126 ;; o Accept list of articles instead of message set string in most |
126 ;; imap-message-* functions. | 127 ;; imap-message-* functions. |
127 ;; o Send strings as literal if they contain, e.g., ". | 128 ;; o Send strings as literal if they contain, e.g., ". |
128 ;; | 129 ;; |
129 ;; Revision history: | 130 ;; Revision history: |
130 ;; | 131 ;; |
131 ;; - 19991218 added starttls/digest-md5 patch, | 132 ;; - 19991218 added starttls/digest-md5 patch, |
132 ;; by Daiki Ueno <ueno@ueda.info.waseda.ac.jp> | 133 ;; by Daiki Ueno <ueno@ueda.info.waseda.ac.jp> |
133 ;; NB! you need SLIM for starttls.el and digest-md5.el | 134 ;; NB! you need SLIM for starttls.el and digest-md5.el |
134 ;; - 19991023 commited to pgnus | 135 ;; - 19991023 committed to pgnus |
135 ;; | 136 ;; |
136 | 137 |
137 ;;; Code: | 138 ;;; Code: |
138 | 139 |
139 (eval-when-compile (require 'cl)) | 140 (eval-when-compile (require 'cl)) |
202 "rsh %g rsh %s imapd") | 203 "rsh %g rsh %s imapd") |
203 "A list of strings, containing commands for IMAP connection. | 204 "A list of strings, containing commands for IMAP connection. |
204 Within a string, %s is replaced with the server address, %p with port | 205 Within a string, %s is replaced with the server address, %p with port |
205 number on server, %g with `imap-shell-host', and %l with | 206 number on server, %g with `imap-shell-host', and %l with |
206 `imap-default-user'. The program should read IMAP commands from stdin | 207 `imap-default-user'. The program should read IMAP commands from stdin |
207 and write IMAP response to stdout. Each entry in the list is tried | 208 and write IMAP response to stdout. Each entry in the list is tried |
208 until a successful connection is made." | 209 until a successful connection is made." |
209 :group 'imap | 210 :group 'imap |
210 :type '(repeat string)) | 211 :type '(repeat string)) |
211 | 212 |
212 (defcustom imap-process-connection-type nil | 213 (defcustom imap-process-connection-type nil |
213 "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. | 214 "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. |
214 The `process-connection-type' variable control type of device | 215 The `process-connection-type' variable controls the type of device |
215 used to communicate with subprocesses. Values are nil to use a | 216 used to communicate with subprocesses. Values are nil to use a |
216 pipe, or t or `pty' to use a pty. The value has no effect if the | 217 pipe, or t or `pty' to use a pty. The value has no effect if the |
217 system has no ptys or if all ptys are busy: then a pipe is used | 218 system has no ptys or if all ptys are busy: then a pipe is used |
218 in any case. The value takes effect when a IMAP server is | 219 in any case. The value takes effect when an IMAP server is |
219 opened, changing it after that has no effect." | 220 opened; changing it after that has no effect." |
220 :version "22.1" | 221 :version "22.1" |
221 :group 'imap | 222 :group 'imap |
222 :type 'boolean) | 223 :type 'boolean) |
223 | 224 |
224 (defcustom imap-use-utf7 t | 225 (defcustom imap-use-utf7 t |
228 encoded mailboxes which doesn't translate into ISO-8859-1." | 229 encoded mailboxes which doesn't translate into ISO-8859-1." |
229 :group 'imap | 230 :group 'imap |
230 :type 'boolean) | 231 :type 'boolean) |
231 | 232 |
232 (defcustom imap-log nil | 233 (defcustom imap-log nil |
233 "If non-nil, a imap session trace is placed in *imap-log* buffer. | 234 "If non-nil, an imap session trace is placed in `imap-log-buffer'. |
234 Note that username, passwords and other privacy sensitive | 235 Note that username, passwords and other privacy sensitive |
235 information (such as e-mail) may be stored in the *imap-log* | 236 information (such as e-mail) may be stored in the buffer. |
236 buffer. It is not written to disk, however. Do not enable this | 237 It is not written to disk, however. Do not enable this |
237 variable unless you are comfortable with that." | 238 variable unless you are comfortable with that. |
239 | |
240 See also `imap-debug'." | |
238 :group 'imap | 241 :group 'imap |
239 :type 'boolean) | 242 :type 'boolean) |
240 | 243 |
241 (defcustom imap-debug nil | 244 (defcustom imap-debug nil |
242 "If non-nil, random debug spews are placed in *imap-debug* buffer. | 245 "If non-nil, trace imap- functions into `imap-debug-buffer'. |
246 Uses `trace-function-background', so you can turn it off with, | |
247 say, `untrace-all'. | |
248 | |
243 Note that username, passwords and other privacy sensitive | 249 Note that username, passwords and other privacy sensitive |
244 information (such as e-mail) may be stored in the *imap-debug* | 250 information (such as e-mail) may be stored in the buffer. |
245 buffer. It is not written to disk, however. Do not enable this | 251 It is not written to disk, however. Do not enable this |
246 variable unless you are comfortable with that." | 252 variable unless you are comfortable with that. |
253 | |
254 This variable only takes effect when loading the `imap' library. | |
255 See also `imap-log'." | |
247 :group 'imap | 256 :group 'imap |
248 :type 'boolean) | 257 :type 'boolean) |
249 | 258 |
250 (defcustom imap-shell-host "gateway" | 259 (defcustom imap-shell-host "gateway" |
251 "Hostname of rlogin proxy." | 260 "Hostname of rlogin proxy." |
266 Shorter values mean quicker response, but is more CPU intensive." | 275 Shorter values mean quicker response, but is more CPU intensive." |
267 :type 'number | 276 :type 'number |
268 :group 'imap) | 277 :group 'imap) |
269 | 278 |
270 (defcustom imap-store-password nil | 279 (defcustom imap-store-password nil |
271 "If non-nil, store session password without promting." | 280 "If non-nil, store session password without prompting." |
272 :group 'imap | 281 :group 'imap |
273 :type 'boolean) | 282 :type 'boolean) |
274 | 283 |
275 ;; Various variables. | 284 ;; Various variables. |
276 | 285 |
391 | 400 |
392 (defvar imap-mailbox-data nil | 401 (defvar imap-mailbox-data nil |
393 "Obarray with mailbox data.") | 402 "Obarray with mailbox data.") |
394 | 403 |
395 (defvar imap-mailbox-prime 997 | 404 (defvar imap-mailbox-prime 997 |
396 "Length of imap-mailbox-data.") | 405 "Length of `imap-mailbox-data'.") |
397 | 406 |
398 (defvar imap-current-message nil | 407 (defvar imap-current-message nil |
399 "Current message number.") | 408 "Current message number.") |
400 | 409 |
401 (defvar imap-message-data nil | 410 (defvar imap-message-data nil |
402 "Obarray with message data.") | 411 "Obarray with message data.") |
403 | 412 |
404 (defvar imap-message-prime 997 | 413 (defvar imap-message-prime 997 |
405 "Length of imap-message-data.") | 414 "Length of `imap-message-data'.") |
406 | 415 |
407 (defvar imap-capability nil | 416 (defvar imap-capability nil |
408 "Capability for server.") | 417 "Capability for server.") |
409 | 418 |
410 (defvar imap-id nil | 419 (defvar imap-id nil |
438 The function should take two arguments, the first the IMAP tag and the | 447 The function should take two arguments, the first the IMAP tag and the |
439 second the status (OK, NO, BAD etc) of the command.") | 448 second the status (OK, NO, BAD etc) of the command.") |
440 | 449 |
441 (defvar imap-enable-exchange-bug-workaround nil | 450 (defvar imap-enable-exchange-bug-workaround nil |
442 "Send FETCH UID commands as *:* instead of *. | 451 "Send FETCH UID commands as *:* instead of *. |
443 Enabling this appears to be required for some servers (e.g., | 452 |
444 Microsoft Exchange) which otherwise would trigger a response 'BAD | 453 When non-nil, use an alternative UIDS form. Enabling appears to |
445 The specified message set is invalid.'.") | 454 be required for some servers (e.g., Microsoft Exchange 2007) |
455 which otherwise would trigger a response 'BAD The specified | |
456 message set is invalid.'. We don't unconditionally use this | |
457 form, since this is said to be significantly inefficient. | |
458 | |
459 This variable is set to t automatically per server if the | |
460 canonical form fails.") | |
446 | 461 |
447 | 462 |
448 ;; Utility functions: | 463 ;; Utility functions: |
449 | 464 |
450 (defun imap-remassoc (key alist) | 465 (defun imap-remassoc (key alist) |
451 "Delete by side effect any elements of LIST whose car is `equal' to KEY. | 466 "Delete by side effect any elements of ALIST whose car is `equal' to KEY. |
452 The modified LIST is returned. If the first member | 467 The modified ALIST is returned. If the first member |
453 of LIST has a car that is `equal' to KEY, there is no way to remove it | 468 of ALIST has a car that is `equal' to KEY, there is no way to remove it |
454 by side effect; therefore, write `(setq foo (remassoc key foo))' to be | 469 by side effect; therefore, write `(setq foo (remassoc key foo))' to be |
455 sure of changing the value of `foo'." | 470 sure of changing the value of `foo'." |
456 (when alist | 471 (when alist |
457 (if (equal key (caar alist)) | 472 (if (equal key (caar alist)) |
458 (cdr alist) | 473 (cdr alist) |
648 | 663 |
649 (defun imap-ssl-p (buffer) | 664 (defun imap-ssl-p (buffer) |
650 nil) | 665 nil) |
651 | 666 |
652 (defun imap-ssl-open (name buffer server port) | 667 (defun imap-ssl-open (name buffer server port) |
653 "Open a SSL connection to server." | 668 "Open an SSL connection to SERVER." |
654 (let ((cmds (if (listp imap-ssl-program) imap-ssl-program | 669 (let ((cmds (if (listp imap-ssl-program) imap-ssl-program |
655 (list imap-ssl-program))) | 670 (list imap-ssl-program))) |
656 cmd done) | 671 cmd done) |
657 (while (and (not done) (setq cmd (pop cmds))) | 672 (while (and (not done) (setq cmd (pop cmds))) |
658 (message "imap: Opening SSL connection with `%s'..." cmd) | 673 (message "imap: Opening SSL connection with `%s'..." cmd) |
709 (coding-system-for-read imap-coding-system-for-read) | 724 (coding-system-for-read imap-coding-system-for-read) |
710 (coding-system-for-write imap-coding-system-for-write) | 725 (coding-system-for-write imap-coding-system-for-write) |
711 (process (open-tls-stream name buffer server port))) | 726 (process (open-tls-stream name buffer server port))) |
712 (when process | 727 (when process |
713 (while (and (memq (process-status process) '(open run)) | 728 (while (and (memq (process-status process) '(open run)) |
729 ;; FIXME: Per the "blue moon" comment, the process/buffer | |
730 ;; handling here, and elsewhere in functions which open | |
731 ;; streams, looks confused. Obviously we can change buffers | |
732 ;; if a different process handler kicks in from | |
733 ;; `accept-process-output' or `sit-for' below, and TRT seems | |
734 ;; to be to `save-buffer' around those calls. (I wonder why | |
735 ;; `sit-for' is used with a non-zero wait.) -- fx | |
714 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug | 736 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
715 (goto-char (point-max)) | 737 (goto-char (point-max)) |
716 (forward-line -1) | 738 (forward-line -1) |
717 (not (imap-parse-greeting))) | 739 (not (imap-parse-greeting))) |
718 (accept-process-output process 1) | 740 (accept-process-output process 1) |
1079 (message "Waiting for response from %s...done" imap-server) | 1101 (message "Waiting for response from %s...done" imap-server) |
1080 (and (memq (process-status imap-process) '(open run)) | 1102 (and (memq (process-status imap-process) '(open run)) |
1081 imap-process)))) | 1103 imap-process)))) |
1082 | 1104 |
1083 (defun imap-open (server &optional port stream auth buffer) | 1105 (defun imap-open (server &optional port stream auth buffer) |
1084 "Open a IMAP connection to host SERVER at PORT returning a buffer. | 1106 "Open an IMAP connection to host SERVER at PORT returning a buffer. |
1085 If PORT is unspecified, a default value is used (143 except | 1107 If PORT is unspecified, a default value is used (143 except |
1086 for SSL which use 993). | 1108 for SSL which use 993). |
1087 STREAM indicates the stream to use, see `imap-streams' for available | 1109 STREAM indicates the stream to use, see `imap-streams' for available |
1088 streams. If nil, it choices the best stream the server is capable of. | 1110 streams. If nil, it choices the best stream the server is capable of. |
1089 AUTH indicates authenticator to use, see `imap-authenticators' for | 1111 AUTH indicates authenticator to use, see `imap-authenticators' for |
1400 imap-state 'auth) | 1422 imap-state 'auth) |
1401 t))) | 1423 t))) |
1402 | 1424 |
1403 (defun imap-mailbox-expunge (&optional asynch buffer) | 1425 (defun imap-mailbox-expunge (&optional asynch buffer) |
1404 "Expunge articles in current folder in BUFFER. | 1426 "Expunge articles in current folder in BUFFER. |
1405 If ASYNCH, do not wait for succesful completion of the command. | 1427 If ASYNCH, do not wait for successful completion of the command. |
1406 If BUFFER is nil the current buffer is assumed." | 1428 If BUFFER is nil the current buffer is assumed." |
1407 (with-current-buffer (or buffer (current-buffer)) | 1429 (with-current-buffer (or buffer (current-buffer)) |
1408 (when (and imap-current-mailbox (not (eq imap-state 'examine))) | 1430 (when (and imap-current-mailbox (not (eq imap-state 'examine))) |
1409 (if asynch | 1431 (if asynch |
1410 (imap-send-command "EXPUNGE") | 1432 (imap-send-command "EXPUNGE") |
1411 (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) | 1433 (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) |
1412 | 1434 |
1413 (defun imap-mailbox-close (&optional asynch buffer) | 1435 (defun imap-mailbox-close (&optional asynch buffer) |
1414 "Expunge articles and close current folder in BUFFER. | 1436 "Expunge articles and close current folder in BUFFER. |
1415 If ASYNCH, do not wait for succesful completion of the command. | 1437 If ASYNCH, do not wait for successful completion of the command. |
1416 If BUFFER is nil the current buffer is assumed." | 1438 If BUFFER is nil the current buffer is assumed." |
1417 (with-current-buffer (or buffer (current-buffer)) | 1439 (with-current-buffer (or buffer (current-buffer)) |
1418 (when imap-current-mailbox | 1440 (when imap-current-mailbox |
1419 (if asynch | 1441 (if asynch |
1420 (imap-add-callback (imap-send-command "CLOSE") | 1442 (imap-add-callback (imap-send-command "CLOSE") |
1508 (when (imap-mailbox-get-1 'list mailbox) | 1530 (when (imap-mailbox-get-1 'list mailbox) |
1509 (push (imap-utf7-decode mailbox) out)))) | 1531 (push (imap-utf7-decode mailbox) out)))) |
1510 (nreverse out))))) | 1532 (nreverse out))))) |
1511 | 1533 |
1512 (defun imap-mailbox-subscribe (mailbox &optional buffer) | 1534 (defun imap-mailbox-subscribe (mailbox &optional buffer) |
1513 "Send the SUBSCRIBE command on the mailbox to server in BUFFER. | 1535 "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER. |
1514 Returns non-nil if successful." | 1536 Returns non-nil if successful." |
1515 (with-current-buffer (or buffer (current-buffer)) | 1537 (with-current-buffer (or buffer (current-buffer)) |
1516 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" | 1538 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" |
1517 (imap-utf7-encode mailbox) | 1539 (imap-utf7-encode mailbox) |
1518 "\""))))) | 1540 "\""))))) |
1519 | 1541 |
1520 (defun imap-mailbox-unsubscribe (mailbox &optional buffer) | 1542 (defun imap-mailbox-unsubscribe (mailbox &optional buffer) |
1521 "Send the SUBSCRIBE command on the mailbox to server in BUFFER. | 1543 "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER. |
1522 Returns non-nil if successful." | 1544 Returns non-nil if successful." |
1523 (with-current-buffer (or buffer (current-buffer)) | 1545 (with-current-buffer (or buffer (current-buffer)) |
1524 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " | 1546 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " |
1525 (imap-utf7-encode mailbox) | 1547 (imap-utf7-encode mailbox) |
1526 "\""))))) | 1548 "\""))))) |
1527 | 1549 |
1528 (defun imap-mailbox-status (mailbox items &optional buffer) | 1550 (defun imap-mailbox-status (mailbox items &optional buffer) |
1529 "Get status items ITEM in MAILBOX from server in BUFFER. | 1551 "Get status items ITEM in MAILBOX from server in BUFFER. |
1530 ITEMS can be a symbol or a list of symbols, valid symbols are one of | 1552 ITEMS can be a symbol or a list of symbols, valid symbols are one of |
1531 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity | 1553 the STATUS data items -- i.e. `messages', `recent', `uidnext', `uidvalidity', |
1532 or 'unseen. If ITEMS is a list of symbols, a list of values is | 1554 or `unseen'. If ITEMS is a list of symbols, a list of values is |
1533 returned, if ITEMS is a symbol only its value is returned." | 1555 returned, if ITEMS is a symbol only its value is returned." |
1534 (with-current-buffer (or buffer (current-buffer)) | 1556 (with-current-buffer (or buffer (current-buffer)) |
1535 (when (imap-ok-p | 1557 (when (imap-ok-p |
1536 (imap-send-command-wait (list "STATUS \"" | 1558 (imap-send-command-wait (list "STATUS \"" |
1537 (imap-utf7-encode mailbox) | 1559 (imap-utf7-encode mailbox) |
1548 (imap-mailbox-get items mailbox))))) | 1570 (imap-mailbox-get items mailbox))))) |
1549 | 1571 |
1550 (defun imap-mailbox-status-asynch (mailbox items &optional buffer) | 1572 (defun imap-mailbox-status-asynch (mailbox items &optional buffer) |
1551 "Send status item request ITEM on MAILBOX to server in BUFFER. | 1573 "Send status item request ITEM on MAILBOX to server in BUFFER. |
1552 ITEMS can be a symbol or a list of symbols, valid symbols are one of | 1574 ITEMS can be a symbol or a list of symbols, valid symbols are one of |
1553 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity | 1575 the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity |
1554 or 'unseen. The IMAP command tag is returned." | 1576 or 'unseen. The IMAP command tag is returned." |
1555 (with-current-buffer (or buffer (current-buffer)) | 1577 (with-current-buffer (or buffer (current-buffer)) |
1556 (imap-send-command (list "STATUS \"" | 1578 (imap-send-command (list "STATUS \"" |
1557 (imap-utf7-encode mailbox) | 1579 (imap-utf7-encode mailbox) |
1558 "\" " | 1580 "\" " |
1561 (if (listp items) | 1583 (if (listp items) |
1562 items | 1584 items |
1563 (list items)))))))) | 1585 (list items)))))))) |
1564 | 1586 |
1565 (defun imap-mailbox-acl-get (&optional mailbox buffer) | 1587 (defun imap-mailbox-acl-get (&optional mailbox buffer) |
1566 "Get ACL on mailbox from server in BUFFER." | 1588 "Get ACL on MAILBOX from server in BUFFER." |
1567 (let ((mailbox (imap-utf7-encode mailbox))) | 1589 (let ((mailbox (imap-utf7-encode mailbox))) |
1568 (with-current-buffer (or buffer (current-buffer)) | 1590 (with-current-buffer (or buffer (current-buffer)) |
1569 (when (imap-ok-p | 1591 (when (imap-ok-p |
1570 (imap-send-command-wait (list "GETACL \"" | 1592 (imap-send-command-wait (list "GETACL \"" |
1571 (or mailbox imap-current-mailbox) | 1593 (or mailbox imap-current-mailbox) |
1583 identifier | 1605 identifier |
1584 " " | 1606 " " |
1585 rights)))))) | 1607 rights)))))) |
1586 | 1608 |
1587 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) | 1609 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) |
1588 "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER." | 1610 "Remove any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER." |
1589 (let ((mailbox (imap-utf7-encode mailbox))) | 1611 (let ((mailbox (imap-utf7-encode mailbox))) |
1590 (with-current-buffer (or buffer (current-buffer)) | 1612 (with-current-buffer (or buffer (current-buffer)) |
1591 (imap-ok-p | 1613 (imap-ok-p |
1592 (imap-send-command-wait (list "DELETEACL \"" | 1614 (imap-send-command-wait (list "DELETEACL \"" |
1593 (or mailbox imap-current-mailbox) | 1615 (or mailbox imap-current-mailbox) |
1718 | 1740 |
1719 (defmacro imap-message-body (uid &optional buffer) | 1741 (defmacro imap-message-body (uid &optional buffer) |
1720 `(with-current-buffer (or ,buffer (current-buffer)) | 1742 `(with-current-buffer (or ,buffer (current-buffer)) |
1721 (imap-message-get ,uid 'BODY))) | 1743 (imap-message-get ,uid 'BODY))) |
1722 | 1744 |
1745 ;; FIXME: Should this try to use CHARSET? -- fx | |
1723 (defun imap-search (predicate &optional buffer) | 1746 (defun imap-search (predicate &optional buffer) |
1724 (with-current-buffer (or buffer (current-buffer)) | 1747 (with-current-buffer (or buffer (current-buffer)) |
1725 (imap-mailbox-put 'search 'dummy) | 1748 (imap-mailbox-put 'search 'dummy) |
1726 (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) | 1749 (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) |
1727 (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) | 1750 (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) |
1764 ;; `imap-string-to-integer'. | 1787 ;; `imap-string-to-integer'. |
1765 (defun imap-string-to-integer (string &optional base) | 1788 (defun imap-string-to-integer (string &optional base) |
1766 (let ((number (string-to-number string base))) | 1789 (let ((number (string-to-number string base))) |
1767 (if (> number most-positive-fixnum) | 1790 (if (> number most-positive-fixnum) |
1768 (error | 1791 (error |
1769 (format "String %s cannot be converted to a lisp integer" number)) | 1792 (format "String %s cannot be converted to a Lisp integer" number)) |
1770 number))) | 1793 number))) |
1794 | |
1795 (defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) | |
1796 "Like `imap-fetch', but DTRT with Exchange 2007 bug. | |
1797 However, UIDS here is a cons, where the car is the canonical form | |
1798 of the UIDS specification, and the cdr is the one which works with | |
1799 Exchange 2007 or, potentially, other buggy servers. | |
1800 See `imap-enable-exchange-bug-workaround'." | |
1801 ;; We don't unconditionally use the alternative (valid) form, since | |
1802 ;; this is said to be significantly inefficient. The first time we | |
1803 ;; get here for a given, we'll try the canonical form. If we get | |
1804 ;; the known error from the buggy server, set the flag | |
1805 ;; buffer-locally (to account for connections to multiple servers), | |
1806 ;; then re-try with the alternative UIDS spec. | |
1807 (condition-case data | |
1808 (imap-fetch (if imap-enable-exchange-bug-workaround | |
1809 (cdr uids) | |
1810 (car uids)) | |
1811 props receive nouidfetch buffer) | |
1812 (error | |
1813 (if (and (not imap-enable-exchange-bug-workaround) | |
1814 (string-match | |
1815 "The specified message set is invalid" | |
1816 (cadr data))) | |
1817 (with-current-buffer (or buffer (current-buffer)) | |
1818 (set (make-local-variable | |
1819 'imap-enable-exchange-bug-workaround) | |
1820 t) | |
1821 (imap-fetch (cdr uids) props receive nouidfetch)) | |
1822 (signal (car data) (cdr data)))))) | |
1771 | 1823 |
1772 (defun imap-message-copyuid-1 (mailbox) | 1824 (defun imap-message-copyuid-1 (mailbox) |
1773 (if (imap-capability 'UIDPLUS) | 1825 (if (imap-capability 'UIDPLUS) |
1774 (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) | 1826 (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) |
1775 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) | 1827 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) |
1776 (let ((old-mailbox imap-current-mailbox) | 1828 (let ((old-mailbox imap-current-mailbox) |
1777 (state imap-state) | 1829 (state imap-state) |
1778 (imap-message-data (make-vector 2 0))) | 1830 (imap-message-data (make-vector 2 0))) |
1779 (when (imap-mailbox-examine-1 mailbox) | 1831 (when (imap-mailbox-examine-1 mailbox) |
1780 (prog1 | 1832 (prog1 |
1781 (and (imap-fetch | 1833 (and (imap-fetch-safe '("*" . "*:*") "UID") |
1782 (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") | |
1783 (list (imap-mailbox-get-1 'uidvalidity mailbox) | 1834 (list (imap-mailbox-get-1 'uidvalidity mailbox) |
1784 (apply 'max (imap-message-map | 1835 (apply 'max (imap-message-map |
1785 (lambda (uid prop) uid) 'UID)))) | 1836 (lambda (uid prop) uid) 'UID)))) |
1786 (if old-mailbox | 1837 (if old-mailbox |
1787 (imap-mailbox-select old-mailbox (eq state 'examine)) | 1838 (imap-mailbox-select old-mailbox (eq state 'examine)) |
1791 (with-current-buffer (or buffer (current-buffer)) | 1842 (with-current-buffer (or buffer (current-buffer)) |
1792 (imap-message-copyuid-1 (imap-utf7-decode mailbox)))) | 1843 (imap-message-copyuid-1 (imap-utf7-decode mailbox)))) |
1793 | 1844 |
1794 (defun imap-message-copy (articles mailbox | 1845 (defun imap-message-copy (articles mailbox |
1795 &optional dont-create no-copyuid buffer) | 1846 &optional dont-create no-copyuid buffer) |
1796 "Copy ARTICLES (a string message set) to MAILBOX on server in | 1847 "Copy ARTICLES to MAILBOX on server in BUFFER. |
1797 BUFFER, creating mailbox if it doesn't exist. If dont-create is | 1848 ARTICLES is a string message set. Create mailbox if it doesn't exist, |
1798 non-nil, it will not create a mailbox. On success, return a list with | 1849 unless DONT-CREATE is non-nil. On success, return a list with |
1799 the UIDVALIDITY of the mailbox the article(s) was copied to as the | 1850 the UIDVALIDITY of the mailbox the article(s) was copied to as the |
1800 first element, rest of list contain the saved articles' UIDs." | 1851 first element. The rest of list contains the saved articles' UIDs." |
1801 (when articles | 1852 (when articles |
1802 (with-current-buffer (or buffer (current-buffer)) | 1853 (with-current-buffer (or buffer (current-buffer)) |
1803 (let ((mailbox (imap-utf7-encode mailbox))) | 1854 (let ((mailbox (imap-utf7-encode mailbox))) |
1804 (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\"")) | 1855 (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\"")) |
1805 (imap-current-target-mailbox mailbox)) | 1856 (imap-current-target-mailbox mailbox)) |
1813 (imap-mailbox-create-1 mailbox)) | 1864 (imap-mailbox-create-1 mailbox)) |
1814 (imap-ok-p (imap-send-command-wait cmd))))) | 1865 (imap-ok-p (imap-send-command-wait cmd))))) |
1815 (or no-copyuid | 1866 (or no-copyuid |
1816 (imap-message-copyuid-1 mailbox))))))) | 1867 (imap-message-copyuid-1 mailbox))))))) |
1817 | 1868 |
1869 ;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it | |
1870 ;; shares most of the code? -- fx | |
1818 (defun imap-message-appenduid-1 (mailbox) | 1871 (defun imap-message-appenduid-1 (mailbox) |
1819 (if (imap-capability 'UIDPLUS) | 1872 (if (imap-capability 'UIDPLUS) |
1820 (imap-mailbox-get-1 'appenduid mailbox) | 1873 (imap-mailbox-get-1 'appenduid mailbox) |
1821 (let ((old-mailbox imap-current-mailbox) | 1874 (let ((old-mailbox imap-current-mailbox) |
1822 (state imap-state) | 1875 (state imap-state) |
1823 (imap-message-data (make-vector 2 0))) | 1876 (imap-message-data (make-vector 2 0))) |
1824 (when (imap-mailbox-examine-1 mailbox) | 1877 (when (imap-mailbox-examine-1 mailbox) |
1825 (prog1 | 1878 (prog1 |
1826 (and (imap-fetch | 1879 (and (imap-fetch-safe '("*" . "*:*") "UID") |
1827 (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") | |
1828 (list (imap-mailbox-get-1 'uidvalidity mailbox) | 1880 (list (imap-mailbox-get-1 'uidvalidity mailbox) |
1829 (apply 'max (imap-message-map | 1881 (apply 'max (imap-message-map |
1830 (lambda (uid prop) uid) 'UID)))) | 1882 (lambda (uid prop) uid) 'UID)))) |
1831 (if old-mailbox | 1883 (if old-mailbox |
1832 (imap-mailbox-select old-mailbox (eq state 'examine)) | 1884 (imap-mailbox-select old-mailbox (eq state 'examine)) |
2199 ;; ; Authentication condition | 2251 ;; ; Authentication condition |
2200 ;; | 2252 ;; |
2201 ;; resp-cond-bye = "BYE" SP resp-text | 2253 ;; resp-cond-bye = "BYE" SP resp-text |
2202 | 2254 |
2203 (defun imap-parse-greeting () | 2255 (defun imap-parse-greeting () |
2204 "Parse a IMAP greeting." | 2256 "Parse an IMAP greeting." |
2205 (cond ((looking-at "\\* OK ") | 2257 (cond ((looking-at "\\* OK ") |
2206 (setq imap-state 'nonauth)) | 2258 (setq imap-state 'nonauth)) |
2207 ((looking-at "\\* PREAUTH ") | 2259 ((looking-at "\\* PREAUTH ") |
2208 (setq imap-state 'auth)) | 2260 (setq imap-state 'auth)) |
2209 ((looking-at "\\* BYE ") | 2261 ((looking-at "\\* BYE ") |
2621 ;; ; future standard or standards-track | 2673 ;; ; future standard or standards-track |
2622 ;; ; revisions of this specification. | 2674 ;; ; revisions of this specification. |
2623 | 2675 |
2624 (defun imap-parse-flag-list () | 2676 (defun imap-parse-flag-list () |
2625 (let (flag-list start) | 2677 (let (flag-list start) |
2626 (assert (eq (char-after) ?\() nil "In imap-parse-flag-list") | 2678 (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") |
2627 (while (and (not (eq (char-after) ?\))) | 2679 (while (and (not (eq (char-after) ?\))) |
2628 (setq start (progn | 2680 (setq start (progn |
2629 (imap-forward) | 2681 (imap-forward) |
2630 ;; next line for Courier IMAP bug. | 2682 ;; next line for Courier IMAP bug. |
2631 (skip-chars-forward " ") | 2683 (skip-chars-forward " ") |
2632 (point))) | 2684 (point))) |
2633 (> (skip-chars-forward "^ )" (point-at-eol)) 0)) | 2685 (> (skip-chars-forward "^ )" (point-at-eol)) 0)) |
2634 (push (buffer-substring start (point)) flag-list)) | 2686 (push (buffer-substring start (point)) flag-list)) |
2635 (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list") | 2687 (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") |
2636 (imap-forward) | 2688 (imap-forward) |
2637 (nreverse flag-list))) | 2689 (nreverse flag-list))) |
2638 | 2690 |
2639 ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP | 2691 ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP |
2640 ;; env-reply-to SP env-to SP env-cc SP env-bcc SP | 2692 ;; env-reply-to SP env-to SP env-cc SP env-bcc SP |
2826 (imap-forward) | 2878 (imap-forward) |
2827 (if (eq (char-after) ?\() | 2879 (if (eq (char-after) ?\() |
2828 (let (subbody) | 2880 (let (subbody) |
2829 (while (and (eq (char-after) ?\() | 2881 (while (and (eq (char-after) ?\() |
2830 (setq subbody (imap-parse-body))) | 2882 (setq subbody (imap-parse-body))) |
2831 ;; buggy stalker communigate pro 3.0 insert a SPC between | 2883 ;; buggy stalker communigate pro 3.0 inserts a SPC between |
2832 ;; parts in multiparts | 2884 ;; parts in multiparts |
2833 (when (and (eq (char-after) ?\ ) | 2885 (when (and (eq (char-after) ?\ ) |
2834 (eq (char-after (1+ (point))) ?\()) | 2886 (eq (char-after (1+ (point))) ?\()) |
2835 (imap-forward)) | 2887 (imap-forward)) |
2836 (push subbody body)) | 2888 (push subbody body)) |
2859 (imap-forward) | 2911 (imap-forward) |
2860 (push (imap-parse-nstring) body) ;; body-fld-id | 2912 (push (imap-parse-nstring) body) ;; body-fld-id |
2861 (imap-forward) | 2913 (imap-forward) |
2862 (push (imap-parse-nstring) body) ;; body-fld-desc | 2914 (push (imap-parse-nstring) body) ;; body-fld-desc |
2863 (imap-forward) | 2915 (imap-forward) |
2864 ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a | 2916 ;; Next `or' for Sun SIMS bug. It regards body-fld-enc as a |
2865 ;; nstring and return nil instead of defaulting back to 7BIT | 2917 ;; nstring and returns nil instead of defaulting back to 7BIT |
2866 ;; as the standard says. | 2918 ;; as the standard says. |
2919 ;; Exchange (2007, at least) does this as well. | |
2867 (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc | 2920 (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc |
2868 (imap-forward) | 2921 (imap-forward) |
2869 (push (imap-parse-number) body) ;; body-fld-octets | 2922 ;; Exchange 2007 can return -1, contrary to the spec... |
2870 | 2923 (if (eq (char-after) ?-) |
2871 ;; ok, we're done parsing the required parts, what comes now is one | 2924 (progn |
2872 ;; of three things: | 2925 (skip-chars-forward "-0-9") |
2926 (push nil body)) | |
2927 (push (imap-parse-number) body)) ;; body-fld-octets | |
2928 | |
2929 ;; Ok, we're done parsing the required parts, what comes now is one of | |
2930 ;; three things: | |
2873 ;; | 2931 ;; |
2874 ;; envelope (then we're parsing body-type-msg) | 2932 ;; envelope (then we're parsing body-type-msg) |
2875 ;; body-fld-lines (then we're parsing body-type-text) | 2933 ;; body-fld-lines (then we're parsing body-type-text) |
2876 ;; body-ext-1part (then we're parsing body-type-basic) | 2934 ;; body-ext-1part (then we're parsing body-type-basic) |
2877 ;; | 2935 ;; |
2878 ;; the problem is that the two first are in turn optionally followed | 2936 ;; The problem is that the two first are in turn optionally followed |
2879 ;; by the third. So we parse the first two here (if there are any)... | 2937 ;; by the third. So we parse the first two here (if there are any)... |
2880 | 2938 |
2881 (when (eq (char-after) ?\ ) | 2939 (when (eq (char-after) ?\ ) |
2882 (imap-forward) | 2940 (imap-forward) |
2883 (let (lines) | 2941 (let (lines) |
2884 (cond ((eq (char-after) ?\() ;; body-type-msg: | 2942 (cond ((eq (char-after) ?\() ;; body-type-msg: |