aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/net
diff options
context:
space:
mode:
authorMiles Bader2009-01-09 03:01:50 +0000
committerMiles Bader2009-01-09 03:01:50 +0000
commite3e955fed38da9263f3904f15233ccfd0dbbbe43 (patch)
tree6a34615ae6e5699c8b7dfba64dfae3486ded203f /lisp/net
parent2188975fbff1202d011db2f82d728fc5fb5f9346 (diff)
downloademacs-e3e955fed38da9263f3904f15233ccfd0dbbbe43.tar.gz
emacs-e3e955fed38da9263f3904f15233ccfd0dbbbe43.zip
Merge from gnus--devo--0
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1513
Diffstat (limited to 'lisp/net')
-rw-r--r--lisp/net/dns.el41
-rw-r--r--lisp/net/imap.el178
2 files changed, 145 insertions, 74 deletions
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index e4dc9aa08ab..e0aba3c32ea 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -29,8 +29,8 @@
29 "How many seconds to wait when doing DNS queries.") 29 "How many seconds to wait when doing DNS queries.")
30 30
31(defvar dns-servers nil 31(defvar dns-servers nil
32 "Which DNS servers to query. 32 "List of DNS servers to query.
33If nil, /etc/resolv.conf will be consulted.") 33If nil, /etc/resolv.conf and nslookup will be consulted.")
34 34
35;;; Internal code: 35;;; Internal code:
36 36
@@ -298,14 +298,24 @@ If TCP-P, the first two bytes of the package with be the length field."
298 (t string))) 298 (t string)))
299 (goto-char point)))) 299 (goto-char point))))
300 300
301(defun dns-parse-resolv-conf () 301(defun dns-set-servers ()
302 (when (file-exists-p "/etc/resolv.conf") 302 "Set `dns-servers' to a list of DNS servers or nil if none are found.
303 (with-temp-buffer 303Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
304 (insert-file-contents "/etc/resolv.conf") 304 (or (when (file-exists-p "/etc/resolv.conf")
305 (goto-char (point-min)) 305 (setq dns-servers nil)
306 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t) 306 (with-temp-buffer
307 (push (match-string 1) dns-servers)) 307 (insert-file-contents "/etc/resolv.conf")
308 (setq dns-servers (nreverse dns-servers))))) 308 (goto-char (point-min))
309 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
310 (push (match-string 1) dns-servers))
311 (setq dns-servers (nreverse dns-servers))))
312 (when (executable-find "nslookup")
313 (with-temp-buffer
314 (call-process "nslookup" nil t nil "localhost")
315 (goto-char (point-min))
316 (re-search-forward
317 "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
318 (setq dns-servers (list (match-string 1)))))))
309 319
310(defun dns-read-txt (string) 320(defun dns-read-txt (string)
311 (if (> (length string) 1) 321 (if (> (length string) 1)
@@ -351,23 +361,26 @@ If TCP-P, the first two bytes of the package with be the length field."
351 361
352(defvar dns-cache (make-vector 4096 0)) 362(defvar dns-cache (make-vector 4096 0))
353 363
354(defun query-dns-cached (name &optional type fullp reversep) 364(defun dns-query-cached (name &optional type fullp reversep)
355 (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) 365 (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
356 (sym (intern-soft key dns-cache))) 366 (sym (intern-soft key dns-cache)))
357 (if (and sym 367 (if (and sym
358 (boundp sym)) 368 (boundp sym))
359 (symbol-value sym) 369 (symbol-value sym)
360 (let ((result (query-dns name type fullp reversep))) 370 (let ((result (dns-query name type fullp reversep)))
361 (set (intern key dns-cache) result) 371 (set (intern key dns-cache) result)
362 result)))) 372 result))))
363 373
364(defun query-dns (name &optional type fullp reversep) 374;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
375;; yet, so no alias are provided. --rsteib
376
377(defun dns-query (name &optional type fullp reversep)
365 "Query a DNS server for NAME of TYPE. 378 "Query a DNS server for NAME of TYPE.
366If FULLP, return the entire record returned. 379If FULLP, return the entire record returned.
367If REVERSEP, look up an IP address." 380If REVERSEP, look up an IP address."
368 (setq type (or type 'A)) 381 (setq type (or type 'A))
369 (unless dns-servers 382 (unless dns-servers
370 (dns-parse-resolv-conf)) 383 (dns-set-servers))
371 384
372 (when reversep 385 (when reversep
373 (setq name (concat 386 (setq name (concat
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index dc295d5b367..6f2b2d11f97 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -3,7 +3,7 @@
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.
@@ -23,7 +23,7 @@
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
@@ -72,25 +72,25 @@
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;;
@@ -121,6 +121,7 @@
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.
@@ -131,7 +132,7 @@
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:
@@ -204,19 +205,19 @@ until a successful connection is made."
204Within a string, %s is replaced with the server address, %p with port 205Within a string, %s is replaced with the server address, %p with port
205number on server, %g with `imap-shell-host', and %l with 206number 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
207and write IMAP response to stdout. Each entry in the list is tried 208and write IMAP response to stdout. Each entry in the list is tried
208until a successful connection is made." 209until 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.
214The `process-connection-type' variable control type of device 215The `process-connection-type' variable controls the type of device
215used to communicate with subprocesses. Values are nil to use a 216used to communicate with subprocesses. Values are nil to use a
216pipe, or t or `pty' to use a pty. The value has no effect if the 217pipe, or t or `pty' to use a pty. The value has no effect if the
217system has no ptys or if all ptys are busy: then a pipe is used 218system has no ptys or if all ptys are busy: then a pipe is used
218in any case. The value takes effect when a IMAP server is 219in any case. The value takes effect when an IMAP server is
219opened, changing it after that has no effect." 220opened; 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)
@@ -230,20 +231,28 @@ encoded mailboxes which doesn't translate into ISO-8859-1."
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'.
234Note that username, passwords and other privacy sensitive 235Note that username, passwords and other privacy sensitive
235information (such as e-mail) may be stored in the *imap-log* 236information (such as e-mail) may be stored in the buffer.
236buffer. It is not written to disk, however. Do not enable this 237It is not written to disk, however. Do not enable this
237variable unless you are comfortable with that." 238variable unless you are comfortable with that.
239
240See 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'.
246Uses `trace-function-background', so you can turn it off with,
247say, `untrace-all'.
248
243Note that username, passwords and other privacy sensitive 249Note that username, passwords and other privacy sensitive
244information (such as e-mail) may be stored in the *imap-debug* 250information (such as e-mail) may be stored in the buffer.
245buffer. It is not written to disk, however. Do not enable this 251It is not written to disk, however. Do not enable this
246variable unless you are comfortable with that." 252variable unless you are comfortable with that.
253
254This variable only takes effect when loading the `imap' library.
255See also `imap-log'."
247 :group 'imap 256 :group 'imap
248 :type 'boolean) 257 :type 'boolean)
249 258
@@ -268,7 +277,7 @@ Shorter values mean quicker response, but is more CPU intensive."
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
@@ -393,7 +402,7 @@ and `examine'.")
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.")
@@ -402,7 +411,7 @@ and `examine'.")
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.")
@@ -440,17 +449,23 @@ 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 *.
443Enabling this appears to be required for some servers (e.g., 452
444Microsoft Exchange) which otherwise would trigger a response 'BAD 453When non-nil, use an alternative UIDS form. Enabling appears to
445The specified message set is invalid.'.") 454be required for some servers (e.g., Microsoft Exchange 2007)
455which otherwise would trigger a response 'BAD The specified
456message set is invalid.'. We don't unconditionally use this
457form, since this is said to be significantly inefficient.
458
459This variable is set to t automatically per server if the
460canonical 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.
452The modified LIST is returned. If the first member 467The modified ALIST is returned. If the first member
453of LIST has a car that is `equal' to KEY, there is no way to remove it 468of ALIST has a car that is `equal' to KEY, there is no way to remove it
454by side effect; therefore, write `(setq foo (remassoc key foo))' to be 469by side effect; therefore, write `(setq foo (remassoc key foo))' to be
455sure of changing the value of `foo'." 470sure of changing the value of `foo'."
456 (when alist 471 (when alist
@@ -650,7 +665,7 @@ sure of changing the value of `foo'."
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)
@@ -711,6 +726,13 @@ sure of changing the value of `foo'."
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)
@@ -1081,7 +1103,7 @@ Returns t if login was successful, nil otherwise."
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.
1085If PORT is unspecified, a default value is used (143 except 1107If PORT is unspecified, a default value is used (143 except
1086for SSL which use 993). 1108for SSL which use 993).
1087STREAM indicates the stream to use, see `imap-streams' for available 1109STREAM indicates the stream to use, see `imap-streams' for available
@@ -1402,7 +1424,7 @@ If EXAMINE is non-nil, do a read-only select."
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.
1405If ASYNCH, do not wait for succesful completion of the command. 1427If ASYNCH, do not wait for successful completion of the command.
1406If BUFFER is nil the current buffer is assumed." 1428If 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)))
@@ -1412,7 +1434,7 @@ If BUFFER is nil the current buffer is assumed."
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.
1415If ASYNCH, do not wait for succesful completion of the command. 1437If ASYNCH, do not wait for successful completion of the command.
1416If BUFFER is nil the current buffer is assumed." 1438If 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
@@ -1510,7 +1532,7 @@ passed to list command."
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.
1514Returns non-nil if successful." 1536Returns 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 \""
@@ -1518,7 +1540,7 @@ Returns non-nil if successful."
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.
1522Returns non-nil if successful." 1544Returns 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 "
@@ -1528,8 +1550,8 @@ Returns non-nil if successful."
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.
1530ITEMS can be a symbol or a list of symbols, valid symbols are one of 1552ITEMS can be a symbol or a list of symbols, valid symbols are one of
1531the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity 1553the STATUS data items -- i.e. `messages', `recent', `uidnext', `uidvalidity',
1532or 'unseen. If ITEMS is a list of symbols, a list of values is 1554or `unseen'. If ITEMS is a list of symbols, a list of values is
1533returned, if ITEMS is a symbol only its value is returned." 1555returned, 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
@@ -1550,7 +1572,7 @@ returned, if ITEMS is a symbol only its value is returned."
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.
1552ITEMS can be a symbol or a list of symbols, valid symbols are one of 1574ITEMS can be a symbol or a list of symbols, valid symbols are one of
1553the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity 1575the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity
1554or 'unseen. The IMAP command tag is returned." 1576or '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 \""
@@ -1563,7 +1585,7 @@ or 'unseen. The IMAP command tag is returned."
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
@@ -1585,7 +1607,7 @@ or 'unseen. The IMAP command tag is returned."
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
@@ -1720,6 +1742,7 @@ is non-nil return these properties."
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)
@@ -1766,9 +1789,38 @@ is non-nil return these properties."
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)))
1771 1794
1795(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
1796 "Like `imap-fetch', but DTRT with Exchange 2007 bug.
1797However, UIDS here is a cons, where the car is the canonical form
1798of the UIDS specification, and the cdr is the one which works with
1799Exchange 2007 or, potentially, other buggy servers.
1800See `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))))))
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))
@@ -1778,8 +1830,7 @@ is non-nil return these properties."
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))))
@@ -1793,11 +1844,11 @@ is non-nil return these properties."
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.
1797BUFFER, creating mailbox if it doesn't exist. If dont-create is 1848ARTICLES is a string message set. Create mailbox if it doesn't exist,
1798non-nil, it will not create a mailbox. On success, return a list with 1849unless DONT-CREATE is non-nil. On success, return a list with
1799the UIDVALIDITY of the mailbox the article(s) was copied to as the 1850the UIDVALIDITY of the mailbox the article(s) was copied to as the
1800first element, rest of list contain the saved articles' UIDs." 1851first 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)))
@@ -1815,6 +1866,8 @@ first element, rest of list contain the saved articles' UIDs."
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)
@@ -1823,8 +1876,7 @@ first element, rest of list contain the saved articles' UIDs."
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))))
@@ -2201,7 +2253,7 @@ Return nil if no complete line has arrived."
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 ")
@@ -2623,7 +2675,7 @@ Return nil if no complete line has arrived."
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)
@@ -2632,7 +2684,7 @@ Return nil if no complete line has arrived."
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
@@ -2828,7 +2880,7 @@ Return nil if no complete line has arrived."
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))) ?\())
@@ -2861,22 +2913,28 @@ Return nil if no complete line has arrived."
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...
2923 (if (eq (char-after) ?-)
2924 (progn
2925 (skip-chars-forward "-0-9")
2926 (push nil body))
2927 (push (imap-parse-number) body)) ;; body-fld-octets
2870 2928
2871 ;; ok, we're done parsing the required parts, what comes now is one 2929 ;; Ok, we're done parsing the required parts, what comes now is one of
2872 ;; of three things: 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)