aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorTeodor Zlatanov2011-02-14 00:57:10 +0000
committerKatsumi Yamaoka2011-02-14 00:57:10 +0000
commitb2108a3663a3d470ef3a53e5d63fff608a0517ae (patch)
treefdb11612cf8f7dc45d1a5eb0ce709cb77a6bf89d
parent35f52ed60dd7234639308c733f28684b2b1492ae (diff)
downloademacs-b2108a3663a3d470ef3a53e5d63fff608a0517ae.tar.gz
emacs-b2108a3663a3d470ef3a53e5d63fff608a0517ae.zip
net/imap.el: Bring it back.
Diffstat
-rw-r--r--lisp/ChangeLog5
-rw-r--r--lisp/net/imap.el3055
2 files changed, 3060 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 1aef40fb770..4d62d676c2a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -2,6 +2,11 @@
2 2
3 * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el. 3 * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el.
4 4
52011-02-13 Teodor Zlatanov <tzz@lifelogs.com>
6
7 * net/imap.el: Bring it back (revert
8 84d800cd31de3064f0ed39617d725709a2f8f42f).
9
52011-02-13 Alan Mackenzie <acm@muc.de> 102011-02-13 Alan Mackenzie <acm@muc.de>
6 11
7 * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a 12 * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
new file mode 100644
index 00000000000..6d80b97fd23
--- /dev/null
+++ b/lisp/net/imap.el
@@ -0,0 +1,3055 @@
1;;; imap.el --- imap library
2
3;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
4
5;; Author: Simon Josefsson <simon@josefsson.org>
6;; Keywords: mail
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;; imap.el is an elisp library providing an interface for talking to
26;; IMAP servers.
27;;
28;; imap.el is roughly divided in two parts, one that parses IMAP
29;; responses from the server and storing data into buffer-local
30;; variables, and one for utility functions which send commands to
31;; server, waits for an answer, and return information. The latter
32;; part is layered on top of the previous.
33;;
34;; The imap.el API consist of the following functions, other functions
35;; in this file should not be called directly and the result of doing
36;; so are at best undefined.
37;;
38;; Global commands:
39;;
40;; imap-open, imap-opened, imap-authenticate, imap-close,
41;; imap-capability, imap-namespace, imap-error-text
42;;
43;; Mailbox commands:
44;;
45;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
46;; imap-current-mailbox-p, imap-search, imap-mailbox-select,
47;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge
48;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete
49;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list
50;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
51;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete
52;;
53;; Message commands:
54;;
55;; imap-fetch-asynch, imap-fetch,
56;; imap-current-message, imap-list-to-message-set,
57;; imap-message-get, imap-message-map
58;; imap-message-envelope-date, imap-message-envelope-subject,
59;; imap-message-envelope-from, imap-message-envelope-sender,
60;; imap-message-envelope-reply-to, imap-message-envelope-to,
61;; imap-message-envelope-cc, imap-message-envelope-bcc
62;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
63;; imap-message-body, imap-message-flag-permanent-p
64;; imap-message-flags-set, imap-message-flags-del
65;; imap-message-flags-add, imap-message-copyuid
66;; imap-message-copy, imap-message-appenduid
67;; imap-message-append, imap-envelope-from
68;; imap-body-lines
69;;
70;; It is my hope that these commands should be pretty self
71;; explanatory for someone that know IMAP. All functions have
72;; additional documentation on how to invoke them.
73;;
74;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1). The implemented
75;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
76;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
77;; LOGINDISABLED) (with use of external library starttls.el and
78;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731
79;; (with use of external program `imtest'), and RFC2971 (ID). It also
80;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
81;;
82;; Without the work of John McClary Prevost and Jim Radford this library
83;; would not have seen the light of day. Many thanks.
84;;
85;; This is a transcript of a short interactive session for demonstration
86;; purposes.
87;;
88;; (imap-open "my.mail.server")
89;; => " *imap* my.mail.server:0"
90;;
91;; The rest are invoked with current buffer as the buffer returned by
92;; `imap-open'. It is possible to do it all without this, but it would
93;; look ugly here since `buffer' is always the last argument for all
94;; imap.el API functions.
95;;
96;; (imap-authenticate "myusername" "mypassword")
97;; => auth
98;;
99;; (imap-mailbox-lsub "*")
100;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
101;;
102;; (imap-mailbox-list "INBOX.n%")
103;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
104;;
105;; (imap-mailbox-select "INBOX.nnimap")
106;; => "INBOX.nnimap"
107;;
108;; (imap-mailbox-get 'exists)
109;; => 166
110;;
111;; (imap-mailbox-get 'uidvalidity)
112;; => "908992622"
113;;
114;; (imap-search "FLAGGED SINCE 18-DEC-98")
115;; => (235 236)
116;;
117;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
118;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
119;;
120;; Todo:
121;;
122;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
123;; Use IEEE floats (which are effectively exact)? -- fx
124;; 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;; imap-message-* functions.
127;; o Send strings as literal if they contain, e.g., ".
128;;
129;; Revision history:
130;;
131;; - 19991218 added starttls/digest-md5 patch,
132;; by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
133;; NB! you need SLIM for starttls.el and digest-md5.el
134;; - 19991023 committed to pgnus
135;;
136
137;;; Code:
138
139(eval-when-compile (require 'cl))
140(eval-and-compile
141 ;; For Emacs <22.2 and XEmacs.
142 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
143 (autoload 'starttls-open-stream "starttls")
144 (autoload 'starttls-negotiate "starttls")
145 (autoload 'sasl-find-mechanism "sasl")
146 (autoload 'digest-md5-parse-digest-challenge "digest-md5")
147 (autoload 'digest-md5-digest-response "digest-md5")
148 (autoload 'digest-md5-digest-uri "digest-md5")
149 (autoload 'digest-md5-challenge "digest-md5")
150 (autoload 'rfc2104-hash "rfc2104")
151 (autoload 'utf7-encode "utf7")
152 (autoload 'utf7-decode "utf7")
153 (autoload 'format-spec "format-spec")
154 (autoload 'format-spec-make "format-spec")
155 (autoload 'open-tls-stream "tls"))
156
157;; User variables.
158
159(defgroup imap nil
160 "Low-level IMAP issues."
161 :version "21.1"
162 :group 'mail)
163
164(defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
165 "imtest -kp %s %p")
166 "List of strings containing commands for Kerberos 4 authentication.
167%s is replaced with server hostname, %p with port to connect to, and
168%l with the value of `imap-default-user'. The program should accept
169IMAP commands on stdin and return responses to stdout. Each entry in
170the list is tried until a successful connection is made."
171 :group 'imap
172 :type '(repeat string))
173
174(defcustom imap-gssapi-program (list
175 (concat "gsasl %s %p "
176 "--mechanism GSSAPI "
177 "--authentication-id %l")
178 "imtest -m gssapi -u %l -p %p %s")
179 "List of strings containing commands for GSSAPI (krb5) authentication.
180%s is replaced with server hostname, %p with port to connect to, and
181%l with the value of `imap-default-user'. The program should accept
182IMAP commands on stdin and return responses to stdout. Each entry in
183the list is tried until a successful connection is made."
184 :group 'imap
185 :type '(repeat string))
186
187(defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
188 "openssl s_client -quiet -ssl2 -connect %s:%p"
189 "s_client -quiet -ssl3 -connect %s:%p"
190 "s_client -quiet -ssl2 -connect %s:%p")
191 "A string, or list of strings, containing commands for SSL connections.
192Within a string, %s is replaced with the server address and %p with
193port number on server. The program should accept IMAP commands on
194stdin and return responses to stdout. Each entry in the list is tried
195until a successful connection is made."
196 :group 'imap
197 :type '(choice string
198 (repeat string)))
199
200(defcustom imap-shell-program '("ssh %s imapd"
201 "rsh %s imapd"
202 "ssh %g ssh %s imapd"
203 "rsh %g rsh %s imapd")
204 "A list of strings, containing commands for IMAP connection.
205Within a string, %s is replaced with the server address, %p with port
206number on server, %g with `imap-shell-host', and %l with
207`imap-default-user'. The program should read IMAP commands from stdin
208and write IMAP response to stdout. Each entry in the list is tried
209until a successful connection is made."
210 :group 'imap
211 :type '(repeat string))
212
213(defcustom imap-process-connection-type nil
214 "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
215The `process-connection-type' variable controls the type of device
216used to communicate with subprocesses. Values are nil to use a
217pipe, or t or `pty' to use a pty. The value has no effect if the
218system has no ptys or if all ptys are busy: then a pipe is used
219in any case. The value takes effect when an IMAP server is
220opened; changing it after that has no effect."
221 :version "22.1"
222 :group 'imap
223 :type 'boolean)
224
225(defcustom imap-use-utf7 t
226 "If non-nil, do utf7 encoding/decoding of mailbox names.
227Since the UTF7 decoding currently only decodes into ISO-8859-1
228characters, you may disable this decoding if you need to access UTF7
229encoded mailboxes which doesn't translate into ISO-8859-1."
230 :group 'imap
231 :type 'boolean)
232
233(defcustom imap-log nil
234 "If non-nil, an imap session trace is placed in `imap-log-buffer'.
235Note that username, passwords and other privacy sensitive
236information (such as e-mail) may be stored in the buffer.
237It is not written to disk, however. Do not enable this
238variable unless you are comfortable with that.
239
240See also `imap-debug'."
241 :group 'imap
242 :type 'boolean)
243
244(defcustom imap-debug nil
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
249Note that username, passwords and other privacy sensitive
250information (such as e-mail) may be stored in the buffer.
251It is not written to disk, however. Do not enable this
252variable unless you are comfortable with that.
253
254This variable only takes effect when loading the `imap' library.
255See also `imap-log'."
256 :group 'imap
257 :type 'boolean)
258
259(defcustom imap-shell-host "gateway"
260 "Hostname of rlogin proxy."
261 :group 'imap
262 :type 'string)
263
264(defcustom imap-default-user (user-login-name)
265 "Default username to use."
266 :group 'imap
267 :type 'string)
268
269(defcustom imap-read-timeout (if (string-match
270 "windows-nt\\|os/2\\|cygwin"
271 (symbol-name system-type))
272 1.0
273 0.1)
274 "*How long to wait between checking for the end of output.
275Shorter values mean quicker response, but is more CPU intensive."
276 :type 'number
277 :group 'imap)
278
279(defcustom imap-store-password nil
280 "If non-nil, store session password without prompting."
281 :group 'imap
282 :type 'boolean)
283
284;; Various variables.
285
286(defvar imap-fetch-data-hook nil
287 "Hooks called after receiving each FETCH response.")
288
289(defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
290 "Priority of streams to consider when opening connection to server.")
291
292(defvar imap-stream-alist
293 '((gssapi imap-gssapi-stream-p imap-gssapi-open)
294 (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
295 (tls imap-tls-p imap-tls-open)
296 (ssl imap-ssl-p imap-ssl-open)
297 (network imap-network-p imap-network-open)
298 (shell imap-shell-p imap-shell-open)
299 (starttls imap-starttls-p imap-starttls-open))
300 "Definition of network streams.
301
302\(NAME CHECK OPEN)
303
304NAME names the stream, CHECK is a function returning non-nil if the
305server support the stream and OPEN is a function for opening the
306stream.")
307
308(defvar imap-authenticators '(gssapi
309 kerberos4
310 digest-md5
311 cram-md5
312 ;;sasl
313 login
314 anonymous)
315 "Priority of authenticators to consider when authenticating to server.")
316
317(defvar imap-authenticator-alist
318 '((gssapi imap-gssapi-auth-p imap-gssapi-auth)
319 (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth)
320 (sasl imap-sasl-auth-p imap-sasl-auth)
321 (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
322 (login imap-login-p imap-login-auth)
323 (anonymous imap-anonymous-p imap-anonymous-auth)
324 (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
325 "Definition of authenticators.
326
327\(NAME CHECK AUTHENTICATE)
328
329NAME names the authenticator. CHECK is a function returning non-nil if
330the server support the authenticator and AUTHENTICATE is a function
331for doing the actual authentication.")
332
333(defvar imap-error nil
334 "Error codes from the last command.")
335
336(defvar imap-logout-timeout nil
337 "Close server immediately if it can't logout in this number of seconds.
338If it is nil, never close server until logout completes. Normally,
339the value of this variable will be bound to a certain value to which
340an application program that uses this module specifies on a per-server
341basis.")
342
343;; Internal constants. Change these and die.
344
345(defconst imap-default-port 143)
346(defconst imap-default-ssl-port 993)
347(defconst imap-default-tls-port 993)
348(defconst imap-default-stream 'network)
349(defconst imap-coding-system-for-read 'binary)
350(defconst imap-coding-system-for-write 'binary)
351(defconst imap-local-variables '(imap-server
352 imap-port
353 imap-client-eol
354 imap-server-eol
355 imap-auth
356 imap-stream
357 imap-username
358 imap-password
359 imap-current-mailbox
360 imap-current-target-mailbox
361 imap-message-data
362 imap-capability
363 imap-id
364 imap-namespace
365 imap-state
366 imap-reached-tag
367 imap-failed-tags
368 imap-tag
369 imap-process
370 imap-calculate-literal-size-first
371 imap-mailbox-data))
372(defconst imap-log-buffer "*imap-log*")
373(defconst imap-debug-buffer "*imap-debug*")
374
375;; Internal variables.
376
377(defvar imap-stream nil)
378(defvar imap-auth nil)
379(defvar imap-server nil)
380(defvar imap-port nil)
381(defvar imap-username nil)
382(defvar imap-password nil)
383(defvar imap-last-authenticator nil)
384(defvar imap-calculate-literal-size-first nil)
385(defvar imap-state 'closed
386 "IMAP state.
387Valid states are `closed', `initial', `nonauth', `auth', `selected'
388and `examine'.")
389
390(defvar imap-server-eol "\r\n"
391 "The EOL string sent from the server.")
392
393(defvar imap-client-eol "\r\n"
394 "The EOL string we send to the server.")
395
396(defvar imap-current-mailbox nil
397 "Current mailbox name.")
398
399(defvar imap-current-target-mailbox nil
400 "Current target mailbox for COPY and APPEND commands.")
401
402(defvar imap-mailbox-data nil
403 "Obarray with mailbox data.")
404
405(defvar imap-mailbox-prime 997
406 "Length of `imap-mailbox-data'.")
407
408(defvar imap-current-message nil
409 "Current message number.")
410
411(defvar imap-message-data nil
412 "Obarray with message data.")
413
414(defvar imap-message-prime 997
415 "Length of `imap-message-data'.")
416
417(defvar imap-capability nil
418 "Capability for server.")
419
420(defvar imap-id nil
421 "Identity of server.
422See RFC 2971.")
423
424(defvar imap-namespace nil
425 "Namespace for current server.")
426
427(defvar imap-reached-tag 0
428 "Lower limit on command tags that have been parsed.")
429
430(defvar imap-failed-tags nil
431 "Alist of tags that failed.
432Each element is a list with four elements; tag (a integer), response
433state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
434human readable response text (a string).")
435
436(defvar imap-tag 0
437 "Command tag number.")
438
439(defvar imap-process nil
440 "Process.")
441
442(defvar imap-continuation nil
443 "Non-nil indicates that the server emitted a continuation request.
444The actual value is really the text on the continuation line.")
445
446(defvar imap-callbacks nil
447 "List of response tags and callbacks, on the form `(number . function)'.
448The function should take two arguments, the first the IMAP tag and the
449second the status (OK, NO, BAD etc) of the command.")
450
451(defvar imap-enable-exchange-bug-workaround nil
452 "Send FETCH UID commands as *:* instead of *.
453
454When non-nil, use an alternative UIDS form. Enabling appears to
455be required for some servers (e.g., Microsoft Exchange 2007)
456which otherwise would trigger a response 'BAD The specified
457message set is invalid.'. We don't unconditionally use this
458form, since this is said to be significantly inefficient.
459
460This variable is set to t automatically per server if the
461canonical form fails.")
462
463
464;; Utility functions:
465
466(defun imap-remassoc (key alist)
467 "Delete by side effect any elements of ALIST whose car is `equal' to KEY.
468The modified ALIST is returned. If the first member
469of ALIST has a car that is `equal' to KEY, there is no way to remove it
470by side effect; therefore, write `(setq foo (remassoc key foo))' to be
471sure of changing the value of `foo'."
472 (when alist
473 (if (equal key (caar alist))
474 (cdr alist)
475 (setcdr alist (imap-remassoc key (cdr alist)))
476 alist)))
477
478(defmacro imap-disable-multibyte ()
479 "Enable multibyte in the current buffer."
480 (unless (featurep 'xemacs)
481 '(set-buffer-multibyte nil)))
482
483(defsubst imap-utf7-encode (string)
484 (if imap-use-utf7
485 (and string
486 (condition-case ()
487 (utf7-encode string t)
488 (error (message
489 "imap: Could not UTF7 encode `%s', using it unencoded..."
490 string)
491 string)))
492 string))
493
494(defsubst imap-utf7-decode (string)
495 (if imap-use-utf7
496 (and string
497 (condition-case ()
498 (utf7-decode string t)
499 (error (message
500 "imap: Could not UTF7 decode `%s', using it undecoded..."
501 string)
502 string)))
503 string))
504
505(defsubst imap-ok-p (status)
506 (if (eq status 'OK)
507 t
508 (setq imap-error status)
509 nil))
510
511(defun imap-error-text (&optional buffer)
512 (with-current-buffer (or buffer (current-buffer))
513 (nth 3 (car imap-failed-tags))))
514
515
516;; Server functions; stream stuff:
517
518(defun imap-log (string-or-buffer)
519 (when imap-log
520 (with-current-buffer (get-buffer-create imap-log-buffer)
521 (imap-disable-multibyte)
522 (buffer-disable-undo)
523 (goto-char (point-max))
524 (if (bufferp string-or-buffer)
525 (insert-buffer-substring string-or-buffer)
526 (insert string-or-buffer)))))
527
528(defun imap-kerberos4-stream-p (buffer)
529 (imap-capability 'AUTH=KERBEROS_V4 buffer))
530
531(defun imap-kerberos4-open (name buffer server port)
532 (let ((cmds imap-kerberos4-program)
533 cmd done)
534 (while (and (not done) (setq cmd (pop cmds)))
535 (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
536 (erase-buffer)
537 (let* ((port (or port imap-default-port))
538 (coding-system-for-read imap-coding-system-for-read)
539 (coding-system-for-write imap-coding-system-for-write)
540 (process-connection-type imap-process-connection-type)
541 (process (start-process
542 name buffer shell-file-name shell-command-switch
543 (format-spec
544 cmd
545 (format-spec-make
546 ?s server
547 ?p (number-to-string port)
548 ?l imap-default-user))))
549 response)
550 (when process
551 (with-current-buffer buffer
552 (setq imap-client-eol "\n"
553 imap-calculate-literal-size-first t)
554 (while (and (memq (process-status process) '(open run))
555 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
556 (goto-char (point-min))
557 ;; Athena IMTEST can output SSL verify errors
558 (or (while (looking-at "^verify error:num=")
559 (forward-line))
560 t)
561 (or (while (looking-at "^TLS connection established")
562 (forward-line))
563 t)
564 ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
565 (or (while (looking-at "^C:")
566 (forward-line))
567 t)
568 ;; cyrus 1.6 imtest print "S: " before server greeting
569 (or (not (looking-at "S: "))
570 (forward-char 3)
571 t)
572 (not (and (imap-parse-greeting)
573 ;; success in imtest < 1.6:
574 (or (re-search-forward
575 "^__\\(.*\\)__\n" nil t)
576 ;; success in imtest 1.6:
577 (re-search-forward
578 "^\\(Authenticat.*\\)" nil t))
579 (setq response (match-string 1)))))
580 (accept-process-output process 1)
581 (sit-for 1))
582 (erase-buffer)
583 (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
584 (if response (concat "done, " response) "failed"))
585 (if (and response (let ((case-fold-search nil))
586 (not (string-match "failed" response))))
587 (setq done process)
588 (if (memq (process-status process) '(open run))
589 (imap-logout))
590 (delete-process process)
591 nil)))))
592 done))
593
594(defun imap-gssapi-stream-p (buffer)
595 (imap-capability 'AUTH=GSSAPI buffer))
596
597(defun imap-gssapi-open (name buffer server port)
598 (let ((cmds imap-gssapi-program)
599 cmd done)
600 (while (and (not done) (setq cmd (pop cmds)))
601 (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
602 (erase-buffer)
603 (let* ((port (or port imap-default-port))
604 (coding-system-for-read imap-coding-system-for-read)
605 (coding-system-for-write imap-coding-system-for-write)
606 (process-connection-type imap-process-connection-type)
607 (process (start-process
608 name buffer shell-file-name shell-command-switch
609 (format-spec
610 cmd
611 (format-spec-make
612 ?s server
613 ?p (number-to-string port)
614 ?l imap-default-user))))
615 response)
616 (when process
617 (with-current-buffer buffer
618 (setq imap-client-eol "\n"
619 imap-calculate-literal-size-first t)
620 (while (and (memq (process-status process) '(open run))
621 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
622 (goto-char (point-min))
623 ;; Athena IMTEST can output SSL verify errors
624 (or (while (looking-at "^verify error:num=")
625 (forward-line))
626 t)
627 (or (while (looking-at "^TLS connection established")
628 (forward-line))
629 t)
630 ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
631 (or (while (looking-at "^C:")
632 (forward-line))
633 t)
634 ;; cyrus 1.6 imtest print "S: " before server greeting
635 (or (not (looking-at "S: "))
636 (forward-char 3)
637 t)
638 ;; GNU SASL may print 'Trying ...' first.
639 (or (not (looking-at "Trying "))
640 (forward-line)
641 t)
642 (not (and (imap-parse-greeting)
643 ;; success in imtest 1.6:
644 (re-search-forward
645 (concat "^\\(\\(Authenticat.*\\)\\|\\("
646 "Client authentication "
647 "finished.*\\)\\)")
648 nil t)
649 (setq response (match-string 1)))))
650 (accept-process-output process 1)
651 (sit-for 1))
652 (imap-log buffer)
653 (erase-buffer)
654 (message "GSSAPI IMAP connection: %s" (or response "failed"))
655 (if (and response (let ((case-fold-search nil))
656 (not (string-match "failed" response))))
657 (setq done process)
658 (if (memq (process-status process) '(open run))
659 (imap-logout))
660 (delete-process process)
661 nil)))))
662 done))
663
664(defun imap-ssl-p (buffer)
665 nil)
666
667(defun imap-ssl-open (name buffer server port)
668 "Open an SSL connection to SERVER."
669 (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
670 (list imap-ssl-program)))
671 cmd done)
672 (while (and (not done) (setq cmd (pop cmds)))
673 (message "imap: Opening SSL connection with `%s'..." cmd)
674 (erase-buffer)
675 (let* ((port (or port imap-default-ssl-port))
676 (coding-system-for-read imap-coding-system-for-read)
677 (coding-system-for-write imap-coding-system-for-write)
678 (process-connection-type imap-process-connection-type)
679 (set-process-query-on-exit-flag
680 (if (fboundp 'set-process-query-on-exit-flag)
681 'set-process-query-on-exit-flag
682 'process-kill-without-query))
683 process)
684 (when (progn
685 (setq process (start-process
686 name buffer shell-file-name
687 shell-command-switch
688 (format-spec cmd
689 (format-spec-make
690 ?s server
691 ?p (number-to-string port)))))
692 (funcall set-process-query-on-exit-flag process nil)
693 process)
694 (with-current-buffer buffer
695 (goto-char (point-min))
696 (while (and (memq (process-status process) '(open run))
697 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
698 (goto-char (point-max))
699 (forward-line -1)
700 (not (imap-parse-greeting)))
701 (accept-process-output process 1)
702 (sit-for 1))
703 (imap-log buffer)
704 (erase-buffer)
705 (when (memq (process-status process) '(open run))
706 (setq done process))))))
707 (if done
708 (progn
709 (message "imap: Opening SSL connection with `%s'...done" cmd)
710 done)
711 (message "imap: Opening SSL connection with `%s'...failed" cmd)
712 nil)))
713
714(defun imap-tls-p (buffer)
715 nil)
716
717(defun imap-tls-open (name buffer server port)
718 (let* ((port (or port imap-default-tls-port))
719 (coding-system-for-read imap-coding-system-for-read)
720 (coding-system-for-write imap-coding-system-for-write)
721 (process (open-tls-stream name buffer server port)))
722 (when process
723 (while (and (memq (process-status process) '(open run))
724 ;; FIXME: Per the "blue moon" comment, the process/buffer
725 ;; handling here, and elsewhere in functions which open
726 ;; streams, looks confused. Obviously we can change buffers
727 ;; if a different process handler kicks in from
728 ;; `accept-process-output' or `sit-for' below, and TRT seems
729 ;; to be to `save-buffer' around those calls. (I wonder why
730 ;; `sit-for' is used with a non-zero wait.) -- fx
731 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
732 (goto-char (point-max))
733 (forward-line -1)
734 (not (imap-parse-greeting)))
735 (accept-process-output process 1)
736 (sit-for 1))
737 (imap-log buffer)
738 (when (memq (process-status process) '(open run))
739 process))))
740
741(defun imap-network-p (buffer)
742 t)
743
744(defun imap-network-open (name buffer server port)
745 (let* ((port (or port imap-default-port))
746 (coding-system-for-read imap-coding-system-for-read)
747 (coding-system-for-write imap-coding-system-for-write)
748 (process (open-network-stream name buffer server port)))
749 (when process
750 (while (and (memq (process-status process) '(open run))
751 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
752 (goto-char (point-min))
753 (not (imap-parse-greeting)))
754 (accept-process-output process 1)
755 (sit-for 1))
756 (imap-log buffer)
757 (when (memq (process-status process) '(open run))
758 process))))
759
760(defun imap-shell-p (buffer)
761 nil)
762
763(defun imap-shell-open (name buffer server port)
764 (let ((cmds (if (listp imap-shell-program) imap-shell-program
765 (list imap-shell-program)))
766 cmd done)
767 (while (and (not done) (setq cmd (pop cmds)))
768 (message "imap: Opening IMAP connection with `%s'..." cmd)
769 (setq imap-client-eol "\n")
770 (let* ((port (or port imap-default-port))
771 (coding-system-for-read imap-coding-system-for-read)
772 (coding-system-for-write imap-coding-system-for-write)
773 (process (start-process
774 name buffer shell-file-name shell-command-switch
775 (format-spec
776 cmd
777 (format-spec-make
778 ?s server
779 ?g imap-shell-host
780 ?p (number-to-string port)
781 ?l imap-default-user)))))
782 (when process
783 (while (and (memq (process-status process) '(open run))
784 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
785 (goto-char (point-max))
786 (forward-line -1)
787 (not (imap-parse-greeting)))
788 (accept-process-output process 1)
789 (sit-for 1))
790 (imap-log buffer)
791 (erase-buffer)
792 (when (memq (process-status process) '(open run))
793 (setq done process)))))
794 (if done
795 (progn
796 (message "imap: Opening IMAP connection with `%s'...done" cmd)
797 done)
798 (message "imap: Opening IMAP connection with `%s'...failed" cmd)
799 nil)))
800
801(defun imap-starttls-p (buffer)
802 (imap-capability 'STARTTLS buffer))
803
804(defun imap-starttls-open (name buffer server port)
805 (let* ((port (or port imap-default-port))
806 (coding-system-for-read imap-coding-system-for-read)
807 (coding-system-for-write imap-coding-system-for-write)
808 (process (starttls-open-stream name buffer server port))
809 done tls-info)
810 (message "imap: Connecting with STARTTLS...")
811 (when process
812 (while (and (memq (process-status process) '(open run))
813 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
814 (goto-char (point-max))
815 (forward-line -1)
816 (not (imap-parse-greeting)))
817 (accept-process-output process 1)
818 (sit-for 1))
819 (imap-send-command "STARTTLS")
820 (while (and (memq (process-status process) '(open run))
821 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
822 (goto-char (point-max))
823 (forward-line -1)
824 (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
825 (accept-process-output process 1)
826 (sit-for 1))
827 (imap-log buffer)
828 (when (and (setq tls-info (starttls-negotiate process))
829 (memq (process-status process) '(open run)))
830 (setq done process)))
831 (if (stringp tls-info)
832 (message "imap: STARTTLS info: %s" tls-info))
833 (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
834 done))
835
836;; Server functions; authenticator stuff:
837
838(defun imap-interactive-login (buffer loginfunc)
839 "Login to server in BUFFER.
840LOGINFUNC is passed a username and a password, it should return t if
841it where successful authenticating itself to the server, nil otherwise.
842Returns t if login was successful, nil otherwise."
843 (with-current-buffer buffer
844 (make-local-variable 'imap-username)
845 (make-local-variable 'imap-password)
846 (let (user passwd ret)
847 ;; (condition-case ()
848 (while (or (not user) (not passwd))
849 (setq user (or imap-username
850 (read-from-minibuffer
851 (concat "imap: username for " imap-server
852 " (using stream `" (symbol-name imap-stream)
853 "'): ")
854 (or user imap-default-user))))
855 (setq passwd (or imap-password
856 (read-passwd
857 (concat "imap: password for " user "@"
858 imap-server " (using authenticator `"
859 (symbol-name imap-auth) "'): "))))
860 (when (and user passwd)
861 (if (funcall loginfunc user passwd)
862 (progn
863 (message "imap: Login successful...")
864 (setq ret t
865 imap-username user)
866 (when (and (not imap-password)
867 (or imap-store-password
868 (y-or-n-p "imap: Store password for this IMAP session? ")))
869 (setq imap-password passwd)))
870 (message "imap: Login failed...")
871 (setq passwd nil)
872 (setq imap-password nil)
873 (sit-for 1))))
874 ;; (quit (with-current-buffer buffer
875 ;; (setq user nil
876 ;; passwd nil)))
877 ;; (error (with-current-buffer buffer
878 ;; (setq user nil
879 ;; passwd nil))))
880 ret)))
881
882(defun imap-gssapi-auth-p (buffer)
883 (eq imap-stream 'gssapi))
884
885(defun imap-gssapi-auth (buffer)
886 (message "imap: Authenticating using GSSAPI...%s"
887 (if (eq imap-stream 'gssapi) "done" "failed"))
888 (eq imap-stream 'gssapi))
889
890(defun imap-kerberos4-auth-p (buffer)
891 (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
892 (eq imap-stream 'kerberos4)))
893
894(defun imap-kerberos4-auth (buffer)
895 (message "imap: Authenticating using Kerberos 4...%s"
896 (if (eq imap-stream 'kerberos4) "done" "failed"))
897 (eq imap-stream 'kerberos4))
898
899(defun imap-cram-md5-p (buffer)
900 (imap-capability 'AUTH=CRAM-MD5 buffer))
901
902(defun imap-cram-md5-auth (buffer)
903 "Login to server using the AUTH CRAM-MD5 method."
904 (message "imap: Authenticating using CRAM-MD5...")
905 (let ((done (imap-interactive-login
906 buffer
907 (lambda (user passwd)
908 (imap-ok-p
909 (imap-send-command-wait
910 (list
911 "AUTHENTICATE CRAM-MD5"
912 (lambda (challenge)
913 (let* ((decoded (base64-decode-string challenge))
914 (hash (rfc2104-hash 'md5 64 16 passwd decoded))
915 (response (concat user " " hash))
916 (encoded (base64-encode-string response)))
917 encoded)))))))))
918 (if done
919 (message "imap: Authenticating using CRAM-MD5...done")
920 (message "imap: Authenticating using CRAM-MD5...failed"))))
921
922(defun imap-login-p (buffer)
923 (and (not (imap-capability 'LOGINDISABLED buffer))
924 (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
925
926(defun imap-quote-specials (string)
927 (with-temp-buffer
928 (insert string)
929 (goto-char (point-min))
930 (while (re-search-forward "[\\\"]" nil t)
931 (forward-char -1)
932 (insert "\\")
933 (forward-char 1))
934 (buffer-string)))
935
936(defun imap-login-auth (buffer)
937 "Login to server using the LOGIN command."
938 (message "imap: Plaintext authentication...")
939 (imap-interactive-login buffer
940 (lambda (user passwd)
941 (imap-ok-p (imap-send-command-wait
942 (concat "LOGIN \""
943 (imap-quote-specials user)
944 "\" \""
945 (imap-quote-specials passwd)
946 "\""))))))
947
948(defun imap-anonymous-p (buffer)
949 t)
950
951(defun imap-anonymous-auth (buffer)
952 (message "imap: Logging in anonymously...")
953 (with-current-buffer buffer
954 (imap-ok-p (imap-send-command-wait
955 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
956 (system-name)) "\"")))))
957
958;;; Compiler directives.
959
960(defvar imap-sasl-client)
961(defvar imap-sasl-step)
962
963(defun imap-sasl-make-mechanisms (buffer)
964 (let ((mecs '()))
965 (mapc (lambda (sym)
966 (let ((name (symbol-name sym)))
967 (if (and (> (length name) 5)
968 (string-equal "AUTH=" (substring name 0 5 )))
969 (setq mecs (cons (substring name 5) mecs)))))
970 (imap-capability nil buffer))
971 mecs))
972
973(declare-function sasl-find-mechanism "sasl" (mechanism))
974(declare-function sasl-mechanism-name "sasl" (mechanism))
975(declare-function sasl-make-client "sasl" (mechanism name service server))
976(declare-function sasl-next-step "sasl" (client step))
977(declare-function sasl-step-data "sasl" (step))
978(declare-function sasl-step-set-data "sasl" (step data))
979
980(defun imap-sasl-auth-p (buffer)
981 (and (condition-case ()
982 (require 'sasl)
983 (error nil))
984 (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
985
986(defun imap-sasl-auth (buffer)
987 "Login to server using the SASL method."
988 (message "imap: Authenticating using SASL...")
989 (with-current-buffer buffer
990 (make-local-variable 'imap-username)
991 (make-local-variable 'imap-sasl-client)
992 (make-local-variable 'imap-sasl-step)
993 (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
994 logged user)
995 (while (not logged)
996 (setq user (or imap-username
997 (read-from-minibuffer
998 (concat "IMAP username for " imap-server " using SASL "
999 (sasl-mechanism-name mechanism) ": ")
1000 (or user imap-default-user))))
1001 (when user
1002 (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
1003 imap-sasl-step (sasl-next-step imap-sasl-client nil))
1004 (let ((tag (imap-send-command
1005 (if (sasl-step-data imap-sasl-step)
1006 (format "AUTHENTICATE %s %s"
1007 (sasl-mechanism-name mechanism)
1008 (sasl-step-data imap-sasl-step))
1009 (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
1010 buffer)))
1011 (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
1012 (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
1013 (setq imap-continuation nil
1014 imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
1015 (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
1016 (base64-encode-string (sasl-step-data imap-sasl-step) t)
1017 "")))
1018 (if (imap-ok-p (imap-wait-for-tag tag))
1019 (setq imap-username user
1020 logged t)
1021 (message "Login failed...")
1022 (sit-for 1)))))
1023 logged)))
1024
1025(defun imap-digest-md5-p (buffer)
1026 (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
1027 (condition-case ()
1028 (require 'digest-md5)
1029 (error nil))))
1030
1031(defun imap-digest-md5-auth (buffer)
1032 "Login to server using the AUTH DIGEST-MD5 method."
1033 (message "imap: Authenticating using DIGEST-MD5...")
1034 (imap-interactive-login
1035 buffer
1036 (lambda (user passwd)
1037 (let ((tag
1038 (imap-send-command
1039 (list
1040 "AUTHENTICATE DIGEST-MD5"
1041 (lambda (challenge)
1042 (digest-md5-parse-digest-challenge
1043 (base64-decode-string challenge))
1044 (let* ((digest-uri
1045 (digest-md5-digest-uri
1046 "imap" (digest-md5-challenge 'realm)))
1047 (response
1048 (digest-md5-digest-response
1049 user passwd digest-uri)))
1050 (base64-encode-string response 'no-line-break))))
1051 )))
1052 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1053 nil
1054 (setq imap-continuation nil)
1055 (imap-send-command-1 "")
1056 (imap-ok-p (imap-wait-for-tag tag)))))))
1057
1058;; Server functions:
1059
1060(defun imap-open-1 (buffer)
1061 (with-current-buffer buffer
1062 (erase-buffer)
1063 (setq imap-current-mailbox nil
1064 imap-current-message nil
1065 imap-state 'initial
1066 imap-process (condition-case ()
1067 (funcall (nth 2 (assq imap-stream
1068 imap-stream-alist))
1069 "imap" buffer imap-server imap-port)
1070 ((error quit) nil)))
1071 (when imap-process
1072 (set-process-filter imap-process 'imap-arrival-filter)
1073 (set-process-sentinel imap-process 'imap-sentinel)
1074 (while (and (eq imap-state 'initial)
1075 (memq (process-status imap-process) '(open run)))
1076 (message "Waiting for response from %s..." imap-server)
1077 (accept-process-output imap-process 1))
1078 (message "Waiting for response from %s...done" imap-server)
1079 (and (memq (process-status imap-process) '(open run))
1080 imap-process))))
1081
1082(defun imap-open (server &optional port stream auth buffer)
1083 "Open an IMAP connection to host SERVER at PORT returning a buffer.
1084If PORT is unspecified, a default value is used (143 except
1085for SSL which use 993).
1086STREAM indicates the stream to use, see `imap-streams' for available
1087streams. If nil, it choices the best stream the server is capable of.
1088AUTH indicates authenticator to use, see `imap-authenticators' for
1089available authenticators. If nil, it choices the best stream the
1090server is capable of.
1091BUFFER can be a buffer or a name of a buffer, which is created if
1092necessary. If nil, the buffer name is generated."
1093 (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
1094 (with-current-buffer (get-buffer-create buffer)
1095 (if (imap-opened buffer)
1096 (imap-close buffer))
1097 (mapc 'make-local-variable imap-local-variables)
1098 (imap-disable-multibyte)
1099 (buffer-disable-undo)
1100 (setq imap-server (or server imap-server))
1101 (setq imap-port (or port imap-port))
1102 (setq imap-auth (or auth imap-auth))
1103 (setq imap-stream (or stream imap-stream))
1104 (message "imap: Connecting to %s..." imap-server)
1105 (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
1106 (imap-open-1 buffer)))
1107 (progn
1108 (message "imap: Connecting to %s...failed" imap-server)
1109 nil)
1110 (when (null imap-stream)
1111 ;; Need to choose stream.
1112 (let ((streams imap-streams))
1113 (while (setq stream (pop streams))
1114 ;; OK to use this stream?
1115 (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
1116 ;; Stream changed?
1117 (if (not (eq imap-default-stream stream))
1118 (with-current-buffer (get-buffer-create
1119 (generate-new-buffer-name " *temp*"))
1120 (mapc 'make-local-variable imap-local-variables)
1121 (imap-disable-multibyte)
1122 (buffer-disable-undo)
1123 (setq imap-server (or server imap-server))
1124 (setq imap-port (or port imap-port))
1125 (setq imap-auth (or auth imap-auth))
1126 (message "imap: Reconnecting with stream `%s'..." stream)
1127 (if (null (let ((imap-stream stream))
1128 (imap-open-1 (current-buffer))))
1129 (progn
1130 (kill-buffer (current-buffer))
1131 (message
1132 "imap: Reconnecting with stream `%s'...failed"
1133 stream))
1134 ;; We're done, kill the first connection
1135 (imap-close buffer)
1136 (let ((name (if (stringp buffer)
1137 buffer
1138 (buffer-name buffer))))
1139 (kill-buffer buffer)
1140 (rename-buffer name)
1141 ;; set the passed buffer to the current one,
1142 ;; so that (imap-opened buffer) later will work
1143 (setq buffer (current-buffer)))
1144 (message "imap: Reconnecting with stream `%s'...done"
1145 stream)
1146 (setq imap-stream stream)
1147 (setq imap-capability nil)
1148 (setq streams nil)))
1149 ;; We're done
1150 (message "imap: Connecting to %s...done" imap-server)
1151 (setq imap-stream stream)
1152 (setq imap-capability nil)
1153 (setq streams nil))))))
1154 (when (imap-opened buffer)
1155 (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1156 ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
1157 (when imap-stream
1158 buffer))))
1159
1160(defcustom imap-ping-server t
1161 "If non-nil, check if IMAP is open.
1162See the function `imap-ping-server'."
1163 :version "23.1" ;; No Gnus
1164 :group 'imap
1165 :type 'boolean)
1166
1167(defun imap-opened (&optional buffer)
1168 "Return non-nil if connection to imap server in BUFFER is open.
1169If BUFFER is nil then the current buffer is used."
1170 (and (setq buffer (get-buffer (or buffer (current-buffer))))
1171 (buffer-live-p buffer)
1172 (with-current-buffer buffer
1173 (and imap-process
1174 (memq (process-status imap-process) '(open run))
1175 (if imap-ping-server
1176 (imap-ping-server)
1177 t)))))
1178
1179(defun imap-ping-server (&optional buffer)
1180 "Ping the IMAP server in BUFFER with a \"NOOP\" command.
1181Return non-nil if the server responds, and nil if it does not
1182respond. If BUFFER is nil, the current buffer is used."
1183 (condition-case ()
1184 (imap-ok-p (imap-send-command-wait "NOOP" buffer))
1185 (error nil)))
1186
1187(defun imap-authenticate (&optional user passwd buffer)
1188 "Authenticate to server in BUFFER, using current buffer if nil.
1189It uses the authenticator specified when opening the server. If the
1190authenticator requires username/passwords, they are queried from the
1191user and optionally stored in the buffer. If USER and/or PASSWD is
1192specified, the user will not be questioned and the username and/or
1193password is remembered in the buffer."
1194 (with-current-buffer (or buffer (current-buffer))
1195 (if (not (eq imap-state 'nonauth))
1196 (or (eq imap-state 'auth)
1197 (eq imap-state 'selected)
1198 (eq imap-state 'examine))
1199 (make-local-variable 'imap-username)
1200 (make-local-variable 'imap-password)
1201 (make-local-variable 'imap-last-authenticator)
1202 (when user (setq imap-username user))
1203 (when passwd (setq imap-password passwd))
1204 (if imap-auth
1205 (and (setq imap-last-authenticator
1206 (assq imap-auth imap-authenticator-alist))
1207 (funcall (nth 2 imap-last-authenticator) (current-buffer))
1208 (setq imap-state 'auth))
1209 ;; Choose authenticator.
1210 (let ((auths imap-authenticators)
1211 auth)
1212 (while (setq auth (pop auths))
1213 ;; OK to use authenticator?
1214 (setq imap-last-authenticator
1215 (assq auth imap-authenticator-alist))
1216 (when (funcall (nth 1 imap-last-authenticator) (current-buffer))
1217 (message "imap: Authenticating to `%s' using `%s'..."
1218 imap-server auth)
1219 (setq imap-auth auth)
1220 (if (funcall (nth 2 imap-last-authenticator) (current-buffer))
1221 (progn
1222 (message "imap: Authenticating to `%s' using `%s'...done"
1223 imap-server auth)
1224 ;; set imap-state correctly on successful auth attempt
1225 (setq imap-state 'auth)
1226 ;; stop iterating through the authenticator list
1227 (setq auths nil))
1228 (message "imap: Authenticating to `%s' using `%s'...failed"
1229 imap-server auth)))))
1230 imap-state))))
1231
1232(defun imap-close (&optional buffer)
1233 "Close connection to server in BUFFER.
1234If BUFFER is nil, the current buffer is used."
1235 (with-current-buffer (or buffer (current-buffer))
1236 (when (imap-opened)
1237 (condition-case nil
1238 (imap-logout-wait)
1239 (quit nil)))
1240 (when (and imap-process
1241 (memq (process-status imap-process) '(open run)))
1242 (delete-process imap-process))
1243 (setq imap-current-mailbox nil
1244 imap-current-message nil
1245 imap-process nil)
1246 (erase-buffer)
1247 t))
1248
1249(defun imap-capability (&optional identifier buffer)
1250 "Return a list of identifiers which server in BUFFER support.
1251If IDENTIFIER, return non-nil if it's among the servers capabilities.
1252If BUFFER is nil, the current buffer is assumed."
1253 (with-current-buffer (or buffer (current-buffer))
1254 (unless imap-capability
1255 (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1256 (setq imap-capability '(IMAP2))))
1257 (if identifier
1258 (memq (intern (upcase (symbol-name identifier))) imap-capability)
1259 imap-capability)))
1260
1261(defun imap-id (&optional list-of-values buffer)
1262 "Identify client to server in BUFFER, and return server identity.
1263LIST-OF-VALUES is nil, or a plist with identifier and value
1264strings to send to the server to identify the client.
1265
1266Return a list of identifiers which server in BUFFER support, or
1267nil if it doesn't support ID or returns no information.
1268
1269If BUFFER is nil, the current buffer is assumed."
1270 (with-current-buffer (or buffer (current-buffer))
1271 (when (and (imap-capability 'ID)
1272 (imap-ok-p (imap-send-command-wait
1273 (if (null list-of-values)
1274 "ID NIL"
1275 (concat "ID (" (mapconcat (lambda (el)
1276 (concat "\"" el "\""))
1277 list-of-values
1278 " ") ")")))))
1279 imap-id)))
1280
1281(defun imap-namespace (&optional buffer)
1282 "Return a namespace hierarchy at server in BUFFER.
1283If BUFFER is nil, the current buffer is assumed."
1284 (with-current-buffer (or buffer (current-buffer))
1285 (unless imap-namespace
1286 (when (imap-capability 'NAMESPACE)
1287 (imap-send-command-wait "NAMESPACE")))
1288 imap-namespace))
1289
1290(defun imap-send-command-wait (command &optional buffer)
1291 (imap-wait-for-tag (imap-send-command command buffer) buffer))
1292
1293(defun imap-logout (&optional buffer)
1294 (or buffer (setq buffer (current-buffer)))
1295 (if imap-logout-timeout
1296 (with-timeout (imap-logout-timeout
1297 (condition-case nil
1298 (with-current-buffer buffer
1299 (delete-process imap-process))
1300 (error)))
1301 (imap-send-command "LOGOUT" buffer))
1302 (imap-send-command "LOGOUT" buffer)))
1303
1304(defun imap-logout-wait (&optional buffer)
1305 (or buffer (setq buffer (current-buffer)))
1306 (if imap-logout-timeout
1307 (with-timeout (imap-logout-timeout
1308 (condition-case nil
1309 (with-current-buffer buffer
1310 (delete-process imap-process))
1311 (error)))
1312 (imap-send-command-wait "LOGOUT" buffer))
1313 (imap-send-command-wait "LOGOUT" buffer)))
1314
1315
1316;; Mailbox functions:
1317
1318(defun imap-mailbox-put (propname value &optional mailbox buffer)
1319 (with-current-buffer (or buffer (current-buffer))
1320 (if imap-mailbox-data
1321 (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1322 propname value)
1323 (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1324 propname value mailbox (current-buffer)))
1325 t))
1326
1327(defsubst imap-mailbox-get-1 (propname &optional mailbox)
1328 (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1329 propname))
1330
1331(defun imap-mailbox-get (propname &optional mailbox buffer)
1332 (let ((mailbox (imap-utf7-encode mailbox)))
1333 (with-current-buffer (or buffer (current-buffer))
1334 (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1335
1336(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1337 (with-current-buffer (or buffer (current-buffer))
1338 (let (result)
1339 (mapatoms
1340 (lambda (s)
1341 (push (funcall func (if mailbox-decoder
1342 (funcall mailbox-decoder (symbol-name s))
1343 (symbol-name s))) result))
1344 imap-mailbox-data)
1345 result)))
1346
1347(defun imap-mailbox-map (func &optional buffer)
1348 "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1349Function should take a mailbox name (a string) as
1350the only argument."
1351 (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1352
1353(defun imap-current-mailbox (&optional buffer)
1354 (with-current-buffer (or buffer (current-buffer))
1355 (imap-utf7-decode imap-current-mailbox)))
1356
1357(defun imap-current-mailbox-p-1 (mailbox &optional examine)
1358 (and (string= mailbox imap-current-mailbox)
1359 (or (and examine
1360 (eq imap-state 'examine))
1361 (and (not examine)
1362 (eq imap-state 'selected)))))
1363
1364(defun imap-current-mailbox-p (mailbox &optional examine buffer)
1365 (with-current-buffer (or buffer (current-buffer))
1366 (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1367
1368(defun imap-mailbox-select-1 (mailbox &optional examine)
1369 "Select MAILBOX on server in BUFFER.
1370If EXAMINE is non-nil, do a read-only select."
1371 (if (imap-current-mailbox-p-1 mailbox examine)
1372 imap-current-mailbox
1373 (setq imap-current-mailbox mailbox)
1374 (if (imap-ok-p (imap-send-command-wait
1375 (concat (if examine "EXAMINE" "SELECT") " \""
1376 mailbox "\"")))
1377 (progn
1378 (setq imap-message-data (make-vector imap-message-prime 0)
1379 imap-state (if examine 'examine 'selected))
1380 imap-current-mailbox)
1381 ;; Failed SELECT/EXAMINE unselects current mailbox
1382 (setq imap-current-mailbox nil))))
1383
1384(defun imap-mailbox-select (mailbox &optional examine buffer)
1385 (with-current-buffer (or buffer (current-buffer))
1386 (imap-utf7-decode
1387 (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1388
1389(defun imap-mailbox-examine-1 (mailbox &optional buffer)
1390 (with-current-buffer (or buffer (current-buffer))
1391 (imap-mailbox-select-1 mailbox 'examine)))
1392
1393(defun imap-mailbox-examine (mailbox &optional buffer)
1394 "Examine MAILBOX on server in BUFFER."
1395 (imap-mailbox-select mailbox 'examine buffer))
1396
1397(defun imap-mailbox-unselect (&optional buffer)
1398 "Close current folder in BUFFER, without expunging articles."
1399 (with-current-buffer (or buffer (current-buffer))
1400 (when (or (eq imap-state 'auth)
1401 (and (imap-capability 'UNSELECT)
1402 (imap-ok-p (imap-send-command-wait "UNSELECT")))
1403 (and (imap-ok-p
1404 (imap-send-command-wait (concat "EXAMINE \""
1405 imap-current-mailbox
1406 "\"")))
1407 (imap-ok-p (imap-send-command-wait "CLOSE"))))
1408 (setq imap-current-mailbox nil
1409 imap-message-data nil
1410 imap-state 'auth)
1411 t)))
1412
1413(defun imap-mailbox-expunge (&optional asynch buffer)
1414 "Expunge articles in current folder in BUFFER.
1415If ASYNCH, do not wait for successful completion of the command.
1416If BUFFER is nil the current buffer is assumed."
1417 (with-current-buffer (or buffer (current-buffer))
1418 (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1419 (if asynch
1420 (imap-send-command "EXPUNGE")
1421 (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1422
1423(defun imap-mailbox-close (&optional asynch buffer)
1424 "Expunge articles and close current folder in BUFFER.
1425If ASYNCH, do not wait for successful completion of the command.
1426If BUFFER is nil the current buffer is assumed."
1427 (with-current-buffer (or buffer (current-buffer))
1428 (when imap-current-mailbox
1429 (if asynch
1430 (imap-add-callback (imap-send-command "CLOSE")
1431 `(lambda (tag status)
1432 (message "IMAP mailbox `%s' closed... %s"
1433 imap-current-mailbox status)
1434 (when (eq ,imap-current-mailbox
1435 imap-current-mailbox)
1436 ;; Don't wipe out data if another mailbox
1437 ;; was selected...
1438 (setq imap-current-mailbox nil
1439 imap-message-data nil
1440 imap-state 'auth))))
1441 (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1442 (setq imap-current-mailbox nil
1443 imap-message-data nil
1444 imap-state 'auth)))
1445 t)))
1446
1447(defun imap-mailbox-create-1 (mailbox)
1448 (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1449
1450(defun imap-mailbox-create (mailbox &optional buffer)
1451 "Create MAILBOX on server in BUFFER.
1452If BUFFER is nil the current buffer is assumed."
1453 (with-current-buffer (or buffer (current-buffer))
1454 (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1455
1456(defun imap-mailbox-delete (mailbox &optional buffer)
1457 "Delete MAILBOX on server in BUFFER.
1458If BUFFER is nil the current buffer is assumed."
1459 (let ((mailbox (imap-utf7-encode mailbox)))
1460 (with-current-buffer (or buffer (current-buffer))
1461 (imap-ok-p
1462 (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1463
1464(defun imap-mailbox-rename (oldname newname &optional buffer)
1465 "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1466If BUFFER is nil the current buffer is assumed."
1467 (let ((oldname (imap-utf7-encode oldname))
1468 (newname (imap-utf7-encode newname)))
1469 (with-current-buffer (or buffer (current-buffer))
1470 (imap-ok-p
1471 (imap-send-command-wait (list "RENAME \"" oldname "\" "
1472 "\"" newname "\""))))))
1473
1474(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1475 "Return a list of subscribed mailboxes on server in BUFFER.
1476If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
1477non-nil, a hierarchy delimiter is added to root. REFERENCE is a
1478implementation-specific string that has to be passed to lsub command."
1479 (with-current-buffer (or buffer (current-buffer))
1480 ;; Make sure we know the hierarchy separator for root's hierarchy
1481 (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1482 (imap-send-command-wait (concat "LIST \"" reference "\" \""
1483 (imap-utf7-encode root) "\"")))
1484 ;; clear list data (NB not delimiter and other stuff)
1485 (imap-mailbox-map-1 (lambda (mailbox)
1486 (imap-mailbox-put 'lsub nil mailbox)))
1487 (when (imap-ok-p
1488 (imap-send-command-wait
1489 (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1490 (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1491 "%\"")))
1492 (let (out)
1493 (imap-mailbox-map-1 (lambda (mailbox)
1494 (when (imap-mailbox-get-1 'lsub mailbox)
1495 (push (imap-utf7-decode mailbox) out))))
1496 (nreverse out)))))
1497
1498(defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1499 "Return a list of mailboxes matching ROOT on server in BUFFER.
1500If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1501root. REFERENCE is a implementation-specific string that has to be
1502passed to list command."
1503 (with-current-buffer (or buffer (current-buffer))
1504 ;; Make sure we know the hierarchy separator for root's hierarchy
1505 (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1506 (imap-send-command-wait (concat "LIST \"" reference "\" \""
1507 (imap-utf7-encode root) "\"")))
1508 ;; clear list data (NB not delimiter and other stuff)
1509 (imap-mailbox-map-1 (lambda (mailbox)
1510 (imap-mailbox-put 'list nil mailbox)))
1511 (when (imap-ok-p
1512 (imap-send-command-wait
1513 (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1514 (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1515 "%\"")))
1516 (let (out)
1517 (imap-mailbox-map-1 (lambda (mailbox)
1518 (when (imap-mailbox-get-1 'list mailbox)
1519 (push (imap-utf7-decode mailbox) out))))
1520 (nreverse out)))))
1521
1522(defun imap-mailbox-subscribe (mailbox &optional buffer)
1523 "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER.
1524Returns non-nil if successful."
1525 (with-current-buffer (or buffer (current-buffer))
1526 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1527 (imap-utf7-encode mailbox)
1528 "\"")))))
1529
1530(defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1531 "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER.
1532Returns non-nil if successful."
1533 (with-current-buffer (or buffer (current-buffer))
1534 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1535 (imap-utf7-encode mailbox)
1536 "\"")))))
1537
1538(defun imap-mailbox-status (mailbox items &optional buffer)
1539 "Get status items ITEM in MAILBOX from server in BUFFER.
1540ITEMS can be a symbol or a list of symbols, valid symbols are one of
1541the STATUS data items -- i.e. `messages', `recent', `uidnext', `uidvalidity',
1542or `unseen'. If ITEMS is a list of symbols, a list of values is
1543returned, if ITEMS is a symbol only its value is returned."
1544 (with-current-buffer (or buffer (current-buffer))
1545 (when (imap-ok-p
1546 (imap-send-command-wait (list "STATUS \""
1547 (imap-utf7-encode mailbox)
1548 "\" "
1549 (upcase
1550 (format "%s"
1551 (if (listp items)
1552 items
1553 (list items)))))))
1554 (if (listp items)
1555 (mapcar (lambda (item)
1556 (imap-mailbox-get item mailbox))
1557 items)
1558 (imap-mailbox-get items mailbox)))))
1559
1560(defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1561 "Send status item request ITEM on MAILBOX to server in BUFFER.
1562ITEMS can be a symbol or a list of symbols, valid symbols are one of
1563the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity
1564or 'unseen. The IMAP command tag is returned."
1565 (with-current-buffer (or buffer (current-buffer))
1566 (imap-send-command (list "STATUS \""
1567 (imap-utf7-encode mailbox)
1568 "\" "
1569 (upcase
1570 (format "%s"
1571 (if (listp items)
1572 items
1573 (list items))))))))
1574
1575(defun imap-mailbox-acl-get (&optional mailbox buffer)
1576 "Get ACL on MAILBOX from server in BUFFER."
1577 (let ((mailbox (imap-utf7-encode mailbox)))
1578 (with-current-buffer (or buffer (current-buffer))
1579 (when (imap-ok-p
1580 (imap-send-command-wait (list "GETACL \""
1581 (or mailbox imap-current-mailbox)
1582 "\"")))
1583 (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1584
1585(defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1586 "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1587 (let ((mailbox (imap-utf7-encode mailbox)))
1588 (with-current-buffer (or buffer (current-buffer))
1589 (imap-ok-p
1590 (imap-send-command-wait (list "SETACL \""
1591 (or mailbox imap-current-mailbox)
1592 "\" "
1593 identifier
1594 " "
1595 rights))))))
1596
1597(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1598 "Remove any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1599 (let ((mailbox (imap-utf7-encode mailbox)))
1600 (with-current-buffer (or buffer (current-buffer))
1601 (imap-ok-p
1602 (imap-send-command-wait (list "DELETEACL \""
1603 (or mailbox imap-current-mailbox)
1604 "\" "
1605 identifier))))))
1606
1607
1608;; Message functions:
1609
1610(defun imap-current-message (&optional buffer)
1611 (with-current-buffer (or buffer (current-buffer))
1612 imap-current-message))
1613
1614(defun imap-list-to-message-set (list)
1615 (mapconcat (lambda (item)
1616 (number-to-string item))
1617 (if (listp list)
1618 list
1619 (list list))
1620 ","))
1621
1622(defun imap-range-to-message-set (range)
1623 (mapconcat
1624 (lambda (item)
1625 (if (consp item)
1626 (format "%d:%d"
1627 (car item) (cdr item))
1628 (format "%d" item)))
1629 (if (and (listp range) (not (listp (cdr range))))
1630 (list range) ;; make (1 . 2) into ((1 . 2))
1631 range)
1632 ","))
1633
1634(defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1635 (with-current-buffer (or buffer (current-buffer))
1636 (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1637 (if (listp uids)
1638 (imap-list-to-message-set uids)
1639 uids)
1640 props))))
1641
1642(defun imap-fetch (uids props &optional receive nouidfetch buffer)
1643 "Fetch properties PROPS from message set UIDS from server in BUFFER.
1644UIDS can be a string, number or a list of numbers. If RECEIVE
1645is non-nil return these properties."
1646 (with-current-buffer (or buffer (current-buffer))
1647 (when (imap-ok-p (imap-send-command-wait
1648 (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1649 (if (listp uids)
1650 (imap-list-to-message-set uids)
1651 uids)
1652 props)))
1653 (if (or (null receive) (stringp uids))
1654 t
1655 (if (listp uids)
1656 (mapcar (lambda (uid)
1657 (if (listp receive)
1658 (mapcar (lambda (prop)
1659 (imap-message-get uid prop))
1660 receive)
1661 (imap-message-get uid receive)))
1662 uids)
1663 (imap-message-get uids receive))))))
1664
1665(defun imap-message-put (uid propname value &optional buffer)
1666 (with-current-buffer (or buffer (current-buffer))
1667 (if imap-message-data
1668 (put (intern (number-to-string uid) imap-message-data)
1669 propname value)
1670 (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1671 uid propname value (current-buffer)))
1672 t))
1673
1674(defun imap-message-get (uid propname &optional buffer)
1675 (with-current-buffer (or buffer (current-buffer))
1676 (get (intern-soft (number-to-string uid) imap-message-data)
1677 propname)))
1678
1679(defun imap-message-map (func propname &optional buffer)
1680 "Map a function across each message in `imap-message-data', returning a list."
1681 (with-current-buffer (or buffer (current-buffer))
1682 (let (result)
1683 (mapatoms
1684 (lambda (s)
1685 (push (funcall func (get s 'UID) (get s propname)) result))
1686 imap-message-data)
1687 result)))
1688
1689(defmacro imap-message-envelope-date (uid &optional buffer)
1690 `(with-current-buffer (or ,buffer (current-buffer))
1691 (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1692
1693(defmacro imap-message-envelope-subject (uid &optional buffer)
1694 `(with-current-buffer (or ,buffer (current-buffer))
1695 (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1696
1697(defmacro imap-message-envelope-from (uid &optional buffer)
1698 `(with-current-buffer (or ,buffer (current-buffer))
1699 (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1700
1701(defmacro imap-message-envelope-sender (uid &optional buffer)
1702 `(with-current-buffer (or ,buffer (current-buffer))
1703 (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1704
1705(defmacro imap-message-envelope-reply-to (uid &optional buffer)
1706 `(with-current-buffer (or ,buffer (current-buffer))
1707 (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1708
1709(defmacro imap-message-envelope-to (uid &optional buffer)
1710 `(with-current-buffer (or ,buffer (current-buffer))
1711 (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1712
1713(defmacro imap-message-envelope-cc (uid &optional buffer)
1714 `(with-current-buffer (or ,buffer (current-buffer))
1715 (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1716
1717(defmacro imap-message-envelope-bcc (uid &optional buffer)
1718 `(with-current-buffer (or ,buffer (current-buffer))
1719 (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1720
1721(defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1722 `(with-current-buffer (or ,buffer (current-buffer))
1723 (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1724
1725(defmacro imap-message-envelope-message-id (uid &optional buffer)
1726 `(with-current-buffer (or ,buffer (current-buffer))
1727 (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1728
1729(defmacro imap-message-body (uid &optional buffer)
1730 `(with-current-buffer (or ,buffer (current-buffer))
1731 (imap-message-get ,uid 'BODY)))
1732
1733;; FIXME: Should this try to use CHARSET? -- fx
1734(defun imap-search (predicate &optional buffer)
1735 (with-current-buffer (or buffer (current-buffer))
1736 (imap-mailbox-put 'search 'dummy)
1737 (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1738 (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1739 (progn
1740 (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1741 nil)
1742 (imap-mailbox-get-1 'search imap-current-mailbox)))))
1743
1744(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1745 "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1746 (with-current-buffer (or buffer (current-buffer))
1747 (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1748 (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1749
1750(defun imap-message-flags-set (articles flags &optional silent buffer)
1751 (when (and articles flags)
1752 (with-current-buffer (or buffer (current-buffer))
1753 (imap-ok-p (imap-send-command-wait
1754 (concat "UID STORE " articles
1755 " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1756
1757(defun imap-message-flags-del (articles flags &optional silent buffer)
1758 (when (and articles flags)
1759 (with-current-buffer (or buffer (current-buffer))
1760 (imap-ok-p (imap-send-command-wait
1761 (concat "UID STORE " articles
1762 " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1763
1764(defun imap-message-flags-add (articles flags &optional silent buffer)
1765 (when (and articles flags)
1766 (with-current-buffer (or buffer (current-buffer))
1767 (imap-ok-p (imap-send-command-wait
1768 (concat "UID STORE " articles
1769 " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1770
1771;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343
1772;; Signal an error if we'd get an integer overflow.
1773;;
1774;; FIXME: Identify relevant calls to `string-to-number' and replace them with
1775;; `imap-string-to-integer'.
1776(defun imap-string-to-integer (string &optional base)
1777 (let ((number (string-to-number string base)))
1778 (if (> number most-positive-fixnum)
1779 (error
1780 (format "String %s cannot be converted to a Lisp integer" number))
1781 number)))
1782
1783(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
1784 "Like `imap-fetch', but DTRT with Exchange 2007 bug.
1785However, UIDS here is a cons, where the car is the canonical form
1786of the UIDS specification, and the cdr is the one which works with
1787Exchange 2007 or, potentially, other buggy servers.
1788See `imap-enable-exchange-bug-workaround'."
1789 ;; The first time we get here for a given, we'll try the canonical
1790 ;; form. If we get the known error from the buggy server, set the
1791 ;; flag buffer-locally (to account for connections to multiple
1792 ;; servers), then re-try with the alternative UIDS spec. We don't
1793 ;; unconditionally use the alternative form, since the
1794 ;; currently-used alternatives are seriously inefficient with some
1795 ;; servers (although they are valid).
1796 ;;
1797 ;; FIXME: Maybe it would be cleaner to have a flag to not signal
1798 ;; the error (which otherwise gives a message), and test
1799 ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of
1800 ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:*
1801 ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not
1802 ;; to do the same?
1803 (condition-case data
1804 ;; Binding `debug-on-error' allows us to get the error from
1805 ;; `imap-parse-response' -- it's normally caught by Emacs around
1806 ;; execution of a process filter.
1807 (let ((debug-on-error t))
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 ;; This is the Exchange 2007 response. It may be more
1815 ;; robust just to check for a BAD response to the
1816 ;; attempted fetch.
1817 (string-match "The specified message set is invalid"
1818 (cadr data)))
1819 (with-current-buffer (or buffer (current-buffer))
1820 (set (make-local-variable 'imap-enable-exchange-bug-workaround)
1821 t)
1822 (imap-fetch (cdr uids) props receive nouidfetch))
1823 (signal (car data) (cdr data))))))
1824
1825(defun imap-message-copyuid-1 (mailbox)
1826 (if (imap-capability 'UIDPLUS)
1827 (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1828 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1829 (let ((old-mailbox imap-current-mailbox)
1830 (state imap-state)
1831 (imap-message-data (make-vector 2 0)))
1832 (when (imap-mailbox-examine-1 mailbox)
1833 (prog1
1834 (and (imap-fetch-safe '("*" . "*:*") "UID")
1835 (list (imap-mailbox-get-1 'uidvalidity mailbox)
1836 (apply 'max (imap-message-map
1837 (lambda (uid prop) uid) 'UID))))
1838 (if old-mailbox
1839 (imap-mailbox-select old-mailbox (eq state 'examine))
1840 (imap-mailbox-unselect)))))))
1841
1842(defun imap-message-copyuid (mailbox &optional buffer)
1843 (with-current-buffer (or buffer (current-buffer))
1844 (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1845
1846(defun imap-message-copy (articles mailbox
1847 &optional dont-create no-copyuid buffer)
1848 "Copy ARTICLES to MAILBOX on server in BUFFER.
1849ARTICLES is a string message set. Create mailbox if it doesn't exist,
1850unless DONT-CREATE is non-nil. On success, return a list with
1851the UIDVALIDITY of the mailbox the article(s) was copied to as the
1852first element. The rest of list contains the saved articles' UIDs."
1853 (when articles
1854 (with-current-buffer (or buffer (current-buffer))
1855 (let ((mailbox (imap-utf7-encode mailbox)))
1856 (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1857 (imap-current-target-mailbox mailbox))
1858 (if (imap-ok-p (imap-send-command-wait cmd))
1859 t
1860 (when (and (not dont-create)
1861 ;; removed because of buggy Oracle server
1862 ;; that doesn't send TRYCREATE tags (which
1863 ;; is a MUST according to specifications):
1864 ;;(imap-mailbox-get-1 'trycreate mailbox)
1865 (imap-mailbox-create-1 mailbox))
1866 (imap-ok-p (imap-send-command-wait cmd)))))
1867 (or no-copyuid
1868 (imap-message-copyuid-1 mailbox)))))))
1869
1870;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it
1871;; shares most of the code? -- fx
1872(defun imap-message-appenduid-1 (mailbox)
1873 (if (imap-capability 'UIDPLUS)
1874 (imap-mailbox-get-1 'appenduid mailbox)
1875 (let ((old-mailbox imap-current-mailbox)
1876 (state imap-state)
1877 (imap-message-data (make-vector 2 0)))
1878 (when (imap-mailbox-examine-1 mailbox)
1879 (prog1
1880 (and (imap-fetch-safe '("*" . "*:*") "UID")
1881 (list (imap-mailbox-get-1 'uidvalidity mailbox)
1882 (apply 'max (imap-message-map
1883 (lambda (uid prop) uid) 'UID))))
1884 (if old-mailbox
1885 (imap-mailbox-select old-mailbox (eq state 'examine))
1886 (imap-mailbox-unselect)))))))
1887
1888(defun imap-message-appenduid (mailbox &optional buffer)
1889 (with-current-buffer (or buffer (current-buffer))
1890 (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1891
1892(defun imap-message-append (mailbox article &optional flags date-time buffer)
1893 "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1894FLAGS and DATE-TIME is currently not used. Return a cons holding
1895uidvalidity of MAILBOX and UID the newly created article got, or nil
1896on failure."
1897 (let ((mailbox (imap-utf7-encode mailbox)))
1898 (with-current-buffer (or buffer (current-buffer))
1899 (and (let ((imap-current-target-mailbox mailbox))
1900 (imap-ok-p
1901 (imap-send-command-wait
1902 (list "APPEND \"" mailbox "\" " article))))
1903 (imap-message-appenduid-1 mailbox)))))
1904
1905(defun imap-body-lines (body)
1906 "Return number of lines in article by looking at the mime bodystructure BODY."
1907 (if (listp body)
1908 (if (stringp (car body))
1909 (cond ((and (string= (upcase (car body)) "TEXT")
1910 (numberp (nth 7 body)))
1911 (nth 7 body))
1912 ((and (string= (upcase (car body)) "MESSAGE")
1913 (numberp (nth 9 body)))
1914 (nth 9 body))
1915 (t 0))
1916 (apply '+ (mapcar 'imap-body-lines body)))
1917 0))
1918
1919(defun imap-envelope-from (from)
1920 "Return a from string line."
1921 (and from
1922 (concat (aref from 0)
1923 (if (aref from 0) " <")
1924 (aref from 2)
1925 "@"
1926 (aref from 3)
1927 (if (aref from 0) ">"))))
1928
1929
1930;; Internal functions.
1931
1932(defun imap-add-callback (tag func)
1933 (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1934
1935(defun imap-send-command-1 (cmdstr)
1936 (setq cmdstr (concat cmdstr imap-client-eol))
1937 (imap-log cmdstr)
1938 (process-send-string imap-process cmdstr))
1939
1940(defun imap-send-command (command &optional buffer)
1941 (with-current-buffer (or buffer (current-buffer))
1942 (if (not (listp command)) (setq command (list command)))
1943 (let ((tag (setq imap-tag (1+ imap-tag)))
1944 cmd cmdstr)
1945 (setq cmdstr (concat (number-to-string imap-tag) " "))
1946 (while (setq cmd (pop command))
1947 (cond ((stringp cmd)
1948 (setq cmdstr (concat cmdstr cmd)))
1949 ((bufferp cmd)
1950 (let ((eol imap-client-eol)
1951 (calcfirst imap-calculate-literal-size-first)
1952 size)
1953 (with-current-buffer cmd
1954 (if calcfirst
1955 (setq size (buffer-size)))
1956 (when (not (equal eol "\r\n"))
1957 ;; XXX modifies buffer!
1958 (goto-char (point-min))
1959 (while (search-forward "\r\n" nil t)
1960 (replace-match eol)))
1961 (if (not calcfirst)
1962 (setq size (buffer-size))))
1963 (setq cmdstr
1964 (concat cmdstr (format "{%d}" size))))
1965 (unwind-protect
1966 (progn
1967 (imap-send-command-1 cmdstr)
1968 (setq cmdstr nil)
1969 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1970 (setq command nil) ;; abort command if no cont-req
1971 (let ((process imap-process)
1972 (stream imap-stream)
1973 (eol imap-client-eol))
1974 (with-current-buffer cmd
1975 (imap-log cmd)
1976 (process-send-region process (point-min)
1977 (point-max)))
1978 (process-send-string process imap-client-eol))))
1979 (setq imap-continuation nil)))
1980 ((functionp cmd)
1981 (imap-send-command-1 cmdstr)
1982 (setq cmdstr nil)
1983 (unwind-protect
1984 (setq command
1985 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1986 nil ;; abort command if no cont-req
1987 (cons (funcall cmd imap-continuation)
1988 command)))
1989 (setq imap-continuation nil)))
1990 (t
1991 (error "Unknown command type"))))
1992 (if cmdstr
1993 (imap-send-command-1 cmdstr))
1994 tag)))
1995
1996(defun imap-wait-for-tag (tag &optional buffer)
1997 (with-current-buffer (or buffer (current-buffer))
1998 (let (imap-have-messaged)
1999 (while (and (null imap-continuation)
2000 (memq (process-status imap-process) '(open run))
2001 (< imap-reached-tag tag))
2002 (let ((len (/ (buffer-size) 1024))
2003 message-log-max)
2004 (unless (< len 10)
2005 (setq imap-have-messaged t)
2006 (message "imap read: %dk" len))
2007 (accept-process-output imap-process
2008 (truncate imap-read-timeout)
2009 (truncate (* (- imap-read-timeout
2010 (truncate imap-read-timeout))
2011 1000)))))
2012 ;; A process can die _before_ we have processed everything it
2013 ;; has to say. Moreover, this can happen in between the call to
2014 ;; accept-process-output and the call to process-status in an
2015 ;; iteration of the loop above.
2016 (when (and (null imap-continuation)
2017 (< imap-reached-tag tag))
2018 (accept-process-output imap-process 0 0))
2019 (when imap-have-messaged
2020 (message ""))
2021 (and (memq (process-status imap-process) '(open run))
2022 (or (assq tag imap-failed-tags)
2023 (if imap-continuation
2024 'INCOMPLETE
2025 'OK))))))
2026
2027(defun imap-sentinel (process string)
2028 (delete-process process))
2029
2030(defun imap-find-next-line ()
2031 "Return point at end of current line, taking into account literals.
2032Return nil if no complete line has arrived."
2033 (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
2034 imap-server-eol)
2035 nil t)
2036 (if (match-string 1)
2037 (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
2038 nil
2039 (goto-char (+ (point) (string-to-number (match-string 1))))
2040 (imap-find-next-line))
2041 (point))))
2042
2043(defun imap-arrival-filter (proc string)
2044 "IMAP process filter."
2045 ;; Sometimes, we are called even though the process has died.
2046 ;; Better abstain from doing stuff in that case.
2047 (when (buffer-name (process-buffer proc))
2048 (with-current-buffer (process-buffer proc)
2049 (goto-char (point-max))
2050 (insert string)
2051 (imap-log string)
2052 (let (end)
2053 (goto-char (point-min))
2054 (while (setq end (imap-find-next-line))
2055 (save-restriction
2056 (narrow-to-region (point-min) end)
2057 (delete-char (- (length imap-server-eol)))
2058 (goto-char (point-min))
2059 (unwind-protect
2060 (cond ((eq imap-state 'initial)
2061 (imap-parse-greeting))
2062 ((or (eq imap-state 'auth)
2063 (eq imap-state 'nonauth)
2064 (eq imap-state 'selected)
2065 (eq imap-state 'examine))
2066 (imap-parse-response))
2067 (t
2068 (message "Unknown state %s in arrival filter"
2069 imap-state)))
2070 (delete-region (point-min) (point-max)))))))))
2071
2072
2073;; Imap parser.
2074
2075(defsubst imap-forward ()
2076 (or (eobp) (forward-char)))
2077
2078;; number = 1*DIGIT
2079;; ; Unsigned 32-bit integer
2080;; ; (0 <= n < 4,294,967,296)
2081
2082(defsubst imap-parse-number ()
2083 (when (looking-at "[0-9]+")
2084 (prog1
2085 (string-to-number (match-string 0))
2086 (goto-char (match-end 0)))))
2087
2088;; literal = "{" number "}" CRLF *CHAR8
2089;; ; Number represents the number of CHAR8s
2090
2091(defsubst imap-parse-literal ()
2092 (when (looking-at "{\\([0-9]+\\)}\r\n")
2093 (let ((pos (match-end 0))
2094 (len (string-to-number (match-string 1))))
2095 (if (< (point-max) (+ pos len))
2096 nil
2097 (goto-char (+ pos len))
2098 (buffer-substring pos (+ pos len))))))
2099
2100;; string = quoted / literal
2101;;
2102;; quoted = DQUOTE *QUOTED-CHAR DQUOTE
2103;;
2104;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
2105;; "\" quoted-specials
2106;;
2107;; quoted-specials = DQUOTE / "\"
2108;;
2109;; TEXT-CHAR = <any CHAR except CR and LF>
2110
2111(defsubst imap-parse-string ()
2112 (cond ((eq (char-after) ?\")
2113 (forward-char 1)
2114 (let ((p (point)) (name ""))
2115 (skip-chars-forward "^\"\\\\")
2116 (setq name (buffer-substring p (point)))
2117 (while (eq (char-after) ?\\)
2118 (setq p (1+ (point)))
2119 (forward-char 2)
2120 (skip-chars-forward "^\"\\\\")
2121 (setq name (concat name (buffer-substring p (point)))))
2122 (forward-char 1)
2123 name))
2124 ((eq (char-after) ?{)
2125 (imap-parse-literal))))
2126
2127;; nil = "NIL"
2128
2129(defsubst imap-parse-nil ()
2130 (if (looking-at "NIL")
2131 (goto-char (match-end 0))))
2132
2133;; nstring = string / nil
2134
2135(defsubst imap-parse-nstring ()
2136 (or (imap-parse-string)
2137 (and (imap-parse-nil)
2138 nil)))
2139
2140;; astring = atom / string
2141;;
2142;; atom = 1*ATOM-CHAR
2143;;
2144;; ATOM-CHAR = <any CHAR except atom-specials>
2145;;
2146;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards /
2147;; quoted-specials
2148;;
2149;; list-wildcards = "%" / "*"
2150;;
2151;; quoted-specials = DQUOTE / "\"
2152
2153(defsubst imap-parse-astring ()
2154 (or (imap-parse-string)
2155 (buffer-substring (point)
2156 (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
2157 (goto-char (1- (match-end 0)))
2158 (end-of-line)
2159 (point)))))
2160
2161;; address = "(" addr-name SP addr-adl SP addr-mailbox SP
2162;; addr-host ")"
2163;;
2164;; addr-adl = nstring
2165;; ; Holds route from [RFC-822] route-addr if
2166;; ; non-nil
2167;;
2168;; addr-host = nstring
2169;; ; nil indicates [RFC-822] group syntax.
2170;; ; Otherwise, holds [RFC-822] domain name
2171;;
2172;; addr-mailbox = nstring
2173;; ; nil indicates end of [RFC-822] group; if
2174;; ; non-nil and addr-host is nil, holds
2175;; ; [RFC-822] group name.
2176;; ; Otherwise, holds [RFC-822] local-part
2177;; ; after removing [RFC-822] quoting
2178;;
2179;; addr-name = nstring
2180;; ; If non-nil, holds phrase from [RFC-822]
2181;; ; mailbox after removing [RFC-822] quoting
2182;;
2183
2184(defsubst imap-parse-address ()
2185 (let (address)
2186 (when (eq (char-after) ?\()
2187 (imap-forward)
2188 (setq address (vector (prog1 (imap-parse-nstring)
2189 (imap-forward))
2190 (prog1 (imap-parse-nstring)
2191 (imap-forward))
2192 (prog1 (imap-parse-nstring)
2193 (imap-forward))
2194 (imap-parse-nstring)))
2195 (when (eq (char-after) ?\))
2196 (imap-forward)
2197 address))))
2198
2199;; address-list = "(" 1*address ")" / nil
2200;;
2201;; nil = "NIL"
2202
2203(defsubst imap-parse-address-list ()
2204 (if (eq (char-after) ?\()
2205 (let (address addresses)
2206 (imap-forward)
2207 (while (and (not (eq (char-after) ?\)))
2208 ;; next line for MS Exchange bug
2209 (progn (and (eq (char-after) ? ) (imap-forward)) t)
2210 (setq address (imap-parse-address)))
2211 (setq addresses (cons address addresses)))
2212 (when (eq (char-after) ?\))
2213 (imap-forward)
2214 (nreverse addresses)))
2215 ;; With assert, the code might not be eval'd.
2216 ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
2217 (imap-parse-nil)))
2218
2219;; mailbox = "INBOX" / astring
2220;; ; INBOX is case-insensitive. All case variants of
2221;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
2222;; ; not as an astring. An astring which consists of
2223;; ; the case-insensitive sequence "I" "N" "B" "O" "X"
2224;; ; is considered to be INBOX and not an astring.
2225;; ; Refer to section 5.1 for further
2226;; ; semantic details of mailbox names.
2227
2228(defsubst imap-parse-mailbox ()
2229 (let ((mailbox (imap-parse-astring)))
2230 (if (string-equal "INBOX" (upcase mailbox))
2231 "INBOX"
2232 mailbox)))
2233
2234;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
2235;;
2236;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text
2237;; ; Authentication condition
2238;;
2239;; resp-cond-bye = "BYE" SP resp-text
2240
2241(defun imap-parse-greeting ()
2242 "Parse an IMAP greeting."
2243 (cond ((looking-at "\\* OK ")
2244 (setq imap-state 'nonauth))
2245 ((looking-at "\\* PREAUTH ")
2246 (setq imap-state 'auth))
2247 ((looking-at "\\* BYE ")
2248 (setq imap-state 'closed))))
2249
2250;; response = *(continue-req / response-data) response-done
2251;;
2252;; continue-req = "+" SP (resp-text / base64) CRLF
2253;;
2254;; response-data = "*" SP (resp-cond-state / resp-cond-bye /
2255;; mailbox-data / message-data / capability-data) CRLF
2256;;
2257;; response-done = response-tagged / response-fatal
2258;;
2259;; response-fatal = "*" SP resp-cond-bye CRLF
2260;; ; Server closes connection immediately
2261;;
2262;; response-tagged = tag SP resp-cond-state CRLF
2263;;
2264;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
2265;; ; Status condition
2266;;
2267;; resp-cond-bye = "BYE" SP resp-text
2268;;
2269;; mailbox-data = "FLAGS" SP flag-list /
2270;; "LIST" SP mailbox-list /
2271;; "LSUB" SP mailbox-list /
2272;; "SEARCH" *(SP nz-number) /
2273;; "STATUS" SP mailbox SP "("
2274;; [status-att SP number *(SP status-att SP number)] ")" /
2275;; number SP "EXISTS" /
2276;; number SP "RECENT"
2277;;
2278;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
2279;;
2280;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
2281;; *(SP capability)
2282;; ; IMAP4rev1 servers which offer RFC 1730
2283;; ; compatibility MUST list "IMAP4" as the first
2284;; ; capability.
2285
2286(defun imap-parse-response ()
2287 "Parse a IMAP command response."
2288 (let (token)
2289 (case (setq token (read (current-buffer)))
2290 (+ (setq imap-continuation
2291 (or (buffer-substring (min (point-max) (1+ (point)))
2292 (point-max))
2293 t)))
2294 (* (case (prog1 (setq token (read (current-buffer)))
2295 (imap-forward))
2296 (OK (imap-parse-resp-text))
2297 (NO (imap-parse-resp-text))
2298 (BAD (imap-parse-resp-text))
2299 (BYE (imap-parse-resp-text))
2300 (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
2301 (LIST (imap-parse-data-list 'list))
2302 (LSUB (imap-parse-data-list 'lsub))
2303 (SEARCH (imap-mailbox-put
2304 'search
2305 (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2306 (STATUS (imap-parse-status))
2307 (CAPABILITY (setq imap-capability
2308 (read (concat "(" (upcase (buffer-substring
2309 (point) (point-max)))
2310 ")"))))
2311 (ID (setq imap-id (read (buffer-substring (point)
2312 (point-max)))))
2313 (ACL (imap-parse-acl))
2314 (t (case (prog1 (read (current-buffer))
2315 (imap-forward))
2316 (EXISTS (imap-mailbox-put 'exists token))
2317 (RECENT (imap-mailbox-put 'recent token))
2318 (EXPUNGE t)
2319 (FETCH (imap-parse-fetch token))
2320 (t (message "Garbage: %s" (buffer-string)))))))
2321 (t (let (status)
2322 (if (not (integerp token))
2323 (message "Garbage: %s" (buffer-string))
2324 (case (prog1 (setq status (read (current-buffer)))
2325 (imap-forward))
2326 (OK (progn
2327 (setq imap-reached-tag (max imap-reached-tag token))
2328 (imap-parse-resp-text)))
2329 (NO (progn
2330 (setq imap-reached-tag (max imap-reached-tag token))
2331 (save-excursion
2332 (imap-parse-resp-text))
2333 (let (code text)
2334 (when (eq (char-after) ?\[)
2335 (setq code (buffer-substring (point)
2336 (search-forward "]")))
2337 (imap-forward))
2338 (setq text (buffer-substring (point) (point-max)))
2339 (push (list token status code text)
2340 imap-failed-tags))))
2341 (BAD (progn
2342 (setq imap-reached-tag (max imap-reached-tag token))
2343 (save-excursion
2344 (imap-parse-resp-text))
2345 (let (code text)
2346 (when (eq (char-after) ?\[)
2347 (setq code (buffer-substring (point)
2348 (search-forward "]")))
2349 (imap-forward))
2350 (setq text (buffer-substring (point) (point-max)))
2351 (push (list token status code text) imap-failed-tags)
2352 (error "Internal error, tag %s status %s code %s text %s"
2353 token status code text))))
2354 (t (message "Garbage: %s" (buffer-string))))
2355 (when (assq token imap-callbacks)
2356 (funcall (cdr (assq token imap-callbacks)) token status)
2357 (setq imap-callbacks
2358 (imap-remassoc token imap-callbacks)))))))))
2359
2360;; resp-text = ["[" resp-text-code "]" SP] text
2361;;
2362;; text = 1*TEXT-CHAR
2363;;
2364;; TEXT-CHAR = <any CHAR except CR and LF>
2365
2366(defun imap-parse-resp-text ()
2367 (imap-parse-resp-text-code))
2368
2369;; resp-text-code = "ALERT" /
2370;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
2371;; "NEWNAME" SP string SP string /
2372;; "PARSE" /
2373;; "PERMANENTFLAGS" SP "("
2374;; [flag-perm *(SP flag-perm)] ")" /
2375;; "READ-ONLY" /
2376;; "READ-WRITE" /
2377;; "TRYCREATE" /
2378;; "UIDNEXT" SP nz-number /
2379;; "UIDVALIDITY" SP nz-number /
2380;; "UNSEEN" SP nz-number /
2381;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2382;;
2383;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid
2384;;
2385;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set
2386;;
2387;; set = sequence-num / (sequence-num ":" sequence-num) /
2388;; (set "," set)
2389;; ; Identifies a set of messages. For message
2390;; ; sequence numbers, these are consecutive
2391;; ; numbers from 1 to the number of messages in
2392;; ; the mailbox
2393;; ; Comma delimits individual numbers, colon
2394;; ; delimits between two numbers inclusive.
2395;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2396;; ; 14,15 for a mailbox with 15 messages.
2397;;
2398;; sequence-num = nz-number / "*"
2399;; ; * is the largest number in use. For message
2400;; ; sequence numbers, it is the number of messages
2401;; ; in the mailbox. For unique identifiers, it is
2402;; ; the unique identifier of the last message in
2403;; ; the mailbox.
2404;;
2405;; flag-perm = flag / "\*"
2406;;
2407;; flag = "\Answered" / "\Flagged" / "\Deleted" /
2408;; "\Seen" / "\Draft" / flag-keyword / flag-extension
2409;; ; Does not include "\Recent"
2410;;
2411;; flag-extension = "\" atom
2412;; ; Future expansion. Client implementations
2413;; ; MUST accept flag-extension flags. Server
2414;; ; implementations MUST NOT generate
2415;; ; flag-extension flags except as defined by
2416;; ; future standard or standards-track
2417;; ; revisions of this specification.
2418;;
2419;; flag-keyword = atom
2420;;
2421;; resp-text-atom = 1*<any ATOM-CHAR except "]">
2422
2423(defun imap-parse-resp-text-code ()
2424 ;; xxx next line for stalker communigate pro 3.3.1 bug
2425 (when (looking-at " \\[")
2426 (imap-forward))
2427 (when (eq (char-after) ?\[)
2428 (imap-forward)
2429 (cond ((search-forward "PERMANENTFLAGS " nil t)
2430 (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2431 ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2432 (imap-mailbox-put 'uidnext (match-string 1)))
2433 ((search-forward "UNSEEN " nil t)
2434 (imap-mailbox-put 'first-unseen (read (current-buffer))))
2435 ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2436 (imap-mailbox-put 'uidvalidity (match-string 1)))
2437 ((search-forward "READ-ONLY" nil t)
2438 (imap-mailbox-put 'read-only t))
2439 ((search-forward "NEWNAME " nil t)
2440 (let (oldname newname)
2441 (setq oldname (imap-parse-string))
2442 (imap-forward)
2443 (setq newname (imap-parse-string))
2444 (imap-mailbox-put 'newname newname oldname)))
2445 ((search-forward "TRYCREATE" nil t)
2446 (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2447 ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2448 (imap-mailbox-put 'appenduid
2449 (list (match-string 1)
2450 (string-to-number (match-string 2)))
2451 imap-current-target-mailbox))
2452 ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2453 (imap-mailbox-put 'copyuid (list (match-string 1)
2454 (match-string 2)
2455 (match-string 3))
2456 imap-current-target-mailbox))
2457 ((search-forward "ALERT] " nil t)
2458 (message "Imap server %s information: %s" imap-server
2459 (buffer-substring (point) (point-max)))))))
2460
2461;; mailbox-list = "(" [mbx-list-flags] ")" SP
2462;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2463;;
2464;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag
2465;; *(SP mbx-list-oflag) /
2466;; mbx-list-oflag *(SP mbx-list-oflag)
2467;;
2468;; mbx-list-oflag = "\Noinferiors" / flag-extension
2469;; ; Other flags; multiple possible per LIST response
2470;;
2471;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked"
2472;; ; Selectability flags; only one per LIST response
2473;;
2474;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
2475;; "\" quoted-specials
2476;;
2477;; quoted-specials = DQUOTE / "\"
2478
2479(defun imap-parse-data-list (type)
2480 (let (flags delimiter mailbox)
2481 (setq flags (imap-parse-flag-list))
2482 (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2483 (setq delimiter (match-string 1))
2484 (goto-char (1+ (match-end 0)))
2485 (when (setq mailbox (imap-parse-mailbox))
2486 (imap-mailbox-put type t mailbox)
2487 (imap-mailbox-put 'list-flags flags mailbox)
2488 (imap-mailbox-put 'delimiter delimiter mailbox)))))
2489
2490;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope /
2491;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2492;; "INTERNALDATE" SPACE date_time /
2493;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2494;; "RFC822.SIZE" SPACE number /
2495;; "BODY" ["STRUCTURE"] SPACE body /
2496;; "BODY" section ["<" number ">"] SPACE nstring /
2497;; "UID" SPACE uniqueid) ")"
2498;;
2499;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
2500;; SPACE time SPACE zone <">
2501;;
2502;; section ::= "[" [section_text / (nz_number *["." nz_number]
2503;; ["." (section_text / "MIME")])] "]"
2504;;
2505;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2506;; SPACE header_list / "TEXT"
2507;;
2508;; header_fld_name ::= astring
2509;;
2510;; header_list ::= "(" 1#header_fld_name ")"
2511
2512(defsubst imap-parse-header-list ()
2513 (when (eq (char-after) ?\()
2514 (let (strlist)
2515 (while (not (eq (char-after) ?\)))
2516 (imap-forward)
2517 (push (imap-parse-astring) strlist))
2518 (imap-forward)
2519 (nreverse strlist))))
2520
2521(defsubst imap-parse-fetch-body-section ()
2522 (let ((section
2523 (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2524 (if (eq (char-before) ? )
2525 (prog1
2526 (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2527 (search-forward "]" nil t))
2528 section)))
2529
2530(defun imap-parse-fetch (response)
2531 (when (eq (char-after) ?\()
2532 (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2533 rfc822size body bodydetail bodystructure flags-empty)
2534 ;; Courier can insert spurious blank characters which will
2535 ;; confuse `read', so skip past them.
2536 (while (let ((moved (skip-chars-forward " \t")))
2537 (prog1 (not (eq (char-after) ?\)))
2538 (unless (= moved 0) (backward-char))))
2539 (imap-forward)
2540 (let ((token (read (current-buffer))))
2541 (imap-forward)
2542 (cond ((eq token 'UID)
2543 (setq uid (condition-case ()
2544 (read (current-buffer))
2545 (error))))
2546 ((eq token 'FLAGS)
2547 (setq flags (imap-parse-flag-list))
2548 (if (not flags)
2549 (setq flags-empty 't)))
2550 ((eq token 'ENVELOPE)
2551 (setq envelope (imap-parse-envelope)))
2552 ((eq token 'INTERNALDATE)
2553 (setq internaldate (imap-parse-string)))
2554 ((eq token 'RFC822)
2555 (setq rfc822 (imap-parse-nstring)))
2556 ((eq token 'RFC822.HEADER)
2557 (setq rfc822header (imap-parse-nstring)))
2558 ((eq token 'RFC822.TEXT)
2559 (setq rfc822text (imap-parse-nstring)))
2560 ((eq token 'RFC822.SIZE)
2561 (setq rfc822size (read (current-buffer))))
2562 ((eq token 'BODY)
2563 (if (eq (char-before) ?\[)
2564 (push (list
2565 (upcase (imap-parse-fetch-body-section))
2566 (and (eq (char-after) ?<)
2567 (buffer-substring (1+ (point))
2568 (search-forward ">" nil t)))
2569 (progn (imap-forward)
2570 (imap-parse-nstring)))
2571 bodydetail)
2572 (setq body (imap-parse-body))))
2573 ((eq token 'BODYSTRUCTURE)
2574 (setq bodystructure (imap-parse-body))))))
2575 (when uid
2576 (setq imap-current-message uid)
2577 (imap-message-put uid 'UID uid)
2578 (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2579 (and envelope (imap-message-put uid 'ENVELOPE envelope))
2580 (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2581 (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2582 (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2583 (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2584 (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2585 (and body (imap-message-put uid 'BODY body))
2586 (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2587 (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2588 (run-hooks 'imap-fetch-data-hook)))))
2589
2590;; mailbox-data = ...
2591;; "STATUS" SP mailbox SP "("
2592;; [status-att SP number
2593;; *(SP status-att SP number)] ")"
2594;; ...
2595;;
2596;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2597;; "UNSEEN"
2598
2599(defun imap-parse-status ()
2600 (let ((mailbox (imap-parse-mailbox)))
2601 (if (eq (char-after) ? )
2602 (forward-char))
2603 (when (and mailbox (eq (char-after) ?\())
2604 (while (and (not (eq (char-after) ?\)))
2605 (or (forward-char) t)
2606 (looking-at "\\([A-Za-z]+\\) "))
2607 (let ((token (upcase (match-string 1))))
2608 (goto-char (match-end 0))
2609 (cond ((string= token "MESSAGES")
2610 (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2611 ((string= token "RECENT")
2612 (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2613 ((string= token "UIDNEXT")
2614 (and (looking-at "[0-9]+")
2615 (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2616 (goto-char (match-end 0))))
2617 ((string= token "UIDVALIDITY")
2618 (and (looking-at "[0-9]+")
2619 (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2620 (goto-char (match-end 0))))
2621 ((string= token "UNSEEN")
2622 (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2623 (t
2624 (message "Unknown status data %s in mailbox %s ignored"
2625 token mailbox)
2626 (read (current-buffer)))))))))
2627
2628;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2629;; rights)
2630;;
2631;; identifier ::= astring
2632;;
2633;; rights ::= astring
2634
2635(defun imap-parse-acl ()
2636 (let ((mailbox (imap-parse-mailbox))
2637 identifier rights acl)
2638 (while (eq (char-after) ?\ )
2639 (imap-forward)
2640 (setq identifier (imap-parse-astring))
2641 (imap-forward)
2642 (setq rights (imap-parse-astring))
2643 (setq acl (append acl (list (cons identifier rights)))))
2644 (imap-mailbox-put 'acl acl mailbox)))
2645
2646;; flag-list = "(" [flag *(SP flag)] ")"
2647;;
2648;; flag = "\Answered" / "\Flagged" / "\Deleted" /
2649;; "\Seen" / "\Draft" / flag-keyword / flag-extension
2650;; ; Does not include "\Recent"
2651;;
2652;; flag-keyword = atom
2653;;
2654;; flag-extension = "\" atom
2655;; ; Future expansion. Client implementations
2656;; ; MUST accept flag-extension flags. Server
2657;; ; implementations MUST NOT generate
2658;; ; flag-extension flags except as defined by
2659;; ; future standard or standards-track
2660;; ; revisions of this specification.
2661
2662(defun imap-parse-flag-list ()
2663 (let (flag-list start)
2664 (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1")
2665 (while (and (not (eq (char-after) ?\)))
2666 (setq start (progn
2667 (imap-forward)
2668 ;; next line for Courier IMAP bug.
2669 (skip-chars-forward " ")
2670 (point)))
2671 (> (skip-chars-forward "^ )" (point-at-eol)) 0))
2672 (push (buffer-substring start (point)) flag-list))
2673 (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2")
2674 (imap-forward)
2675 (nreverse flag-list)))
2676
2677;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP
2678;; env-reply-to SP env-to SP env-cc SP env-bcc SP
2679;; env-in-reply-to SP env-message-id ")"
2680;;
2681;; env-bcc = "(" 1*address ")" / nil
2682;;
2683;; env-cc = "(" 1*address ")" / nil
2684;;
2685;; env-date = nstring
2686;;
2687;; env-from = "(" 1*address ")" / nil
2688;;
2689;; env-in-reply-to = nstring
2690;;
2691;; env-message-id = nstring
2692;;
2693;; env-reply-to = "(" 1*address ")" / nil
2694;;
2695;; env-sender = "(" 1*address ")" / nil
2696;;
2697;; env-subject = nstring
2698;;
2699;; env-to = "(" 1*address ")" / nil
2700
2701(defun imap-parse-envelope ()
2702 (when (eq (char-after) ?\()
2703 (imap-forward)
2704 (vector (prog1 (imap-parse-nstring) ;; date
2705 (imap-forward))
2706 (prog1 (imap-parse-nstring) ;; subject
2707 (imap-forward))
2708 (prog1 (imap-parse-address-list) ;; from
2709 (imap-forward))
2710 (prog1 (imap-parse-address-list) ;; sender
2711 (imap-forward))
2712 (prog1 (imap-parse-address-list) ;; reply-to
2713 (imap-forward))
2714 (prog1 (imap-parse-address-list) ;; to
2715 (imap-forward))
2716 (prog1 (imap-parse-address-list) ;; cc
2717 (imap-forward))
2718 (prog1 (imap-parse-address-list) ;; bcc
2719 (imap-forward))
2720 (prog1 (imap-parse-nstring) ;; in-reply-to
2721 (imap-forward))
2722 (prog1 (imap-parse-nstring) ;; message-id
2723 (imap-forward)))))
2724
2725;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2726
2727(defsubst imap-parse-string-list ()
2728 (cond ((eq (char-after) ?\() ;; body-fld-param
2729 (let (strlist str)
2730 (imap-forward)
2731 (while (setq str (imap-parse-string))
2732 (push str strlist)
2733 ;; buggy stalker communigate pro 3.0 doesn't print SPC
2734 ;; between body-fld-param's sometimes
2735 (or (eq (char-after) ?\")
2736 (imap-forward)))
2737 (nreverse strlist)))
2738 ((imap-parse-nil)
2739 nil)))
2740
2741;; body-extension = nstring / number /
2742;; "(" body-extension *(SP body-extension) ")"
2743;; ; Future expansion. Client implementations
2744;; ; MUST accept body-extension fields. Server
2745;; ; implementations MUST NOT generate
2746;; ; body-extension fields except as defined by
2747;; ; future standard or standards-track
2748;; ; revisions of this specification.
2749
2750(defun imap-parse-body-extension ()
2751 (if (eq (char-after) ?\()
2752 (let (b-e)
2753 (imap-forward)
2754 (push (imap-parse-body-extension) b-e)
2755 (while (eq (char-after) ?\ )
2756 (imap-forward)
2757 (push (imap-parse-body-extension) b-e))
2758 (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
2759 (imap-forward)
2760 (nreverse b-e))
2761 (or (imap-parse-number)
2762 (imap-parse-nstring))))
2763
2764;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2765;; *(SP body-extension)]]
2766;; ; MUST NOT be returned on non-extensible
2767;; ; "BODY" fetch
2768;;
2769;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2770;; *(SP body-extension)]]
2771;; ; MUST NOT be returned on non-extensible
2772;; ; "BODY" fetch
2773
2774(defsubst imap-parse-body-ext ()
2775 (let (ext)
2776 (when (eq (char-after) ?\ ) ;; body-fld-dsp
2777 (imap-forward)
2778 (let (dsp)
2779 (if (eq (char-after) ?\()
2780 (progn
2781 (imap-forward)
2782 (push (imap-parse-string) dsp)
2783 (imap-forward)
2784 (push (imap-parse-string-list) dsp)
2785 (imap-forward))
2786 ;; With assert, the code might not be eval'd.
2787 ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
2788 (imap-parse-nil))
2789 (push (nreverse dsp) ext))
2790 (when (eq (char-after) ?\ ) ;; body-fld-lang
2791 (imap-forward)
2792 (if (eq (char-after) ?\()
2793 (push (imap-parse-string-list) ext)
2794 (push (imap-parse-nstring) ext))
2795 (while (eq (char-after) ?\ ) ;; body-extension
2796 (imap-forward)
2797 (setq ext (append (imap-parse-body-extension) ext)))))
2798 ext))
2799
2800;; body = "(" body-type-1part / body-type-mpart ")"
2801;;
2802;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2803;; *(SP body-extension)]]
2804;; ; MUST NOT be returned on non-extensible
2805;; ; "BODY" fetch
2806;;
2807;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2808;; *(SP body-extension)]]
2809;; ; MUST NOT be returned on non-extensible
2810;; ; "BODY" fetch
2811;;
2812;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP
2813;; body-fld-enc SP body-fld-octets
2814;;
2815;; body-fld-desc = nstring
2816;;
2817;; body-fld-dsp = "(" string SP body-fld-param ")" / nil
2818;;
2819;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2820;; "QUOTED-PRINTABLE") DQUOTE) / string
2821;;
2822;; body-fld-id = nstring
2823;;
2824;; body-fld-lang = nstring / "(" string *(SP string) ")"
2825;;
2826;; body-fld-lines = number
2827;;
2828;; body-fld-md5 = nstring
2829;;
2830;; body-fld-octets = number
2831;;
2832;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2833;;
2834;; body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2835;; [SP body-ext-1part]
2836;;
2837;; body-type-basic = media-basic SP body-fields
2838;; ; MESSAGE subtype MUST NOT be "RFC822"
2839;;
2840;; body-type-msg = media-message SP body-fields SP envelope
2841;; SP body SP body-fld-lines
2842;;
2843;; body-type-text = media-text SP body-fields SP body-fld-lines
2844;;
2845;; body-type-mpart = 1*body SP media-subtype
2846;; [SP body-ext-mpart]
2847;;
2848;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2849;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2850;; ; Defined in [MIME-IMT]
2851;;
2852;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2853;; ; Defined in [MIME-IMT]
2854;;
2855;; media-subtype = string
2856;; ; Defined in [MIME-IMT]
2857;;
2858;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype
2859;; ; Defined in [MIME-IMT]
2860
2861(defun imap-parse-body ()
2862 (let (body)
2863 (when (eq (char-after) ?\()
2864 (imap-forward)
2865 (if (eq (char-after) ?\()
2866 (let (subbody)
2867 (while (and (eq (char-after) ?\()
2868 (setq subbody (imap-parse-body)))
2869 ;; buggy stalker communigate pro 3.0 inserts a SPC between
2870 ;; parts in multiparts
2871 (when (and (eq (char-after) ?\ )
2872 (eq (char-after (1+ (point))) ?\())
2873 (imap-forward))
2874 (push subbody body))
2875 (imap-forward)
2876 (push (imap-parse-string) body) ;; media-subtype
2877 (when (eq (char-after) ?\ ) ;; body-ext-mpart:
2878 (imap-forward)
2879 (if (eq (char-after) ?\() ;; body-fld-param
2880 (push (imap-parse-string-list) body)
2881 (push (and (imap-parse-nil) nil) body))
2882 (setq body
2883 (append (imap-parse-body-ext) body))) ;; body-ext-...
2884 (assert (eq (char-after) ?\)) nil "In imap-parse-body")
2885 (imap-forward)
2886 (nreverse body))
2887
2888 (push (imap-parse-string) body) ;; media-type
2889 (imap-forward)
2890 (push (imap-parse-string) body) ;; media-subtype
2891 (imap-forward)
2892 ;; next line for Sun SIMS bug
2893 (and (eq (char-after) ? ) (imap-forward))
2894 (if (eq (char-after) ?\() ;; body-fld-param
2895 (push (imap-parse-string-list) body)
2896 (push (and (imap-parse-nil) nil) body))
2897 (imap-forward)
2898 (push (imap-parse-nstring) body) ;; body-fld-id
2899 (imap-forward)
2900 (push (imap-parse-nstring) body) ;; body-fld-desc
2901 (imap-forward)
2902 ;; Next `or' for Sun SIMS bug. It regards body-fld-enc as a
2903 ;; nstring and returns nil instead of defaulting back to 7BIT
2904 ;; as the standard says.
2905 ;; Exchange (2007, at least) does this as well.
2906 (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
2907 (imap-forward)
2908 ;; Exchange 2007 can return -1, contrary to the spec...
2909 (if (eq (char-after) ?-)
2910 (progn
2911 (skip-chars-forward "-0-9")
2912 (push nil body))
2913 (push (imap-parse-number) body)) ;; body-fld-octets
2914
2915 ;; Ok, we're done parsing the required parts, what comes now is one of
2916 ;; three things:
2917 ;;
2918 ;; envelope (then we're parsing body-type-msg)
2919 ;; body-fld-lines (then we're parsing body-type-text)
2920 ;; body-ext-1part (then we're parsing body-type-basic)
2921 ;;
2922 ;; The problem is that the two first are in turn optionally followed
2923 ;; by the third. So we parse the first two here (if there are any)...
2924
2925 (when (eq (char-after) ?\ )
2926 (imap-forward)
2927 (let (lines)
2928 (cond ((eq (char-after) ?\() ;; body-type-msg:
2929 (push (imap-parse-envelope) body) ;; envelope
2930 (imap-forward)
2931 (push (imap-parse-body) body) ;; body
2932 ;; buggy stalker communigate pro 3.0 doesn't print
2933 ;; number of lines in message/rfc822 attachment
2934 (if (eq (char-after) ?\))
2935 (push 0 body)
2936 (imap-forward)
2937 (push (imap-parse-number) body))) ;; body-fld-lines
2938 ((setq lines (imap-parse-number)) ;; body-type-text:
2939 (push lines body)) ;; body-fld-lines
2940 (t
2941 (backward-char))))) ;; no match...
2942
2943 ;; ...and then parse the third one here...
2944
2945 (when (eq (char-after) ?\ ) ;; body-ext-1part:
2946 (imap-forward)
2947 (push (imap-parse-nstring) body) ;; body-fld-md5
2948 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2949
2950 (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
2951 (imap-forward)
2952 (nreverse body)))))
2953
2954(when imap-debug ; (untrace-all)
2955 (require 'trace)
2956 (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2957 (mapc (lambda (f) (trace-function-background f imap-debug-buffer))
2958 '(
2959 imap-utf7-encode
2960 imap-utf7-decode
2961 imap-error-text
2962 imap-kerberos4s-p
2963 imap-kerberos4-open
2964 imap-ssl-p
2965 imap-ssl-open
2966 imap-network-p
2967 imap-network-open
2968 imap-interactive-login
2969 imap-kerberos4a-p
2970 imap-kerberos4-auth
2971 imap-cram-md5-p
2972 imap-cram-md5-auth
2973 imap-login-p
2974 imap-login-auth
2975 imap-anonymous-p
2976 imap-anonymous-auth
2977 imap-open-1
2978 imap-open
2979 imap-opened
2980 imap-ping-server
2981 imap-authenticate
2982 imap-close
2983 imap-capability
2984 imap-namespace
2985 imap-send-command-wait
2986 imap-mailbox-put
2987 imap-mailbox-get
2988 imap-mailbox-map-1
2989 imap-mailbox-map
2990 imap-current-mailbox
2991 imap-current-mailbox-p-1
2992 imap-current-mailbox-p
2993 imap-mailbox-select-1
2994 imap-mailbox-select
2995 imap-mailbox-examine-1
2996 imap-mailbox-examine
2997 imap-mailbox-unselect
2998 imap-mailbox-expunge
2999 imap-mailbox-close
3000 imap-mailbox-create-1
3001 imap-mailbox-create
3002 imap-mailbox-delete
3003 imap-mailbox-rename
3004 imap-mailbox-lsub
3005 imap-mailbox-list
3006 imap-mailbox-subscribe
3007 imap-mailbox-unsubscribe
3008 imap-mailbox-status
3009 imap-mailbox-acl-get
3010 imap-mailbox-acl-set
3011 imap-mailbox-acl-delete
3012 imap-current-message
3013 imap-list-to-message-set
3014 imap-fetch-asynch
3015 imap-fetch
3016 imap-fetch-safe
3017 imap-message-put
3018 imap-message-get
3019 imap-message-map
3020 imap-search
3021 imap-message-flag-permanent-p
3022 imap-message-flags-set
3023 imap-message-flags-del
3024 imap-message-flags-add
3025 imap-message-copyuid-1
3026 imap-message-copyuid
3027 imap-message-copy
3028 imap-message-appenduid-1
3029 imap-message-appenduid
3030 imap-message-append
3031 imap-body-lines
3032 imap-envelope-from
3033 imap-send-command-1
3034 imap-send-command
3035 imap-wait-for-tag
3036 imap-sentinel
3037 imap-find-next-line
3038 imap-arrival-filter
3039 imap-parse-greeting
3040 imap-parse-response
3041 imap-parse-resp-text
3042 imap-parse-resp-text-code
3043 imap-parse-data-list
3044 imap-parse-fetch
3045 imap-parse-status
3046 imap-parse-acl
3047 imap-parse-flag-list
3048 imap-parse-envelope
3049 imap-parse-body-extension
3050 imap-parse-body
3051 )))
3052
3053(provide 'imap)
3054
3055;;; imap.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-25 22:07:52 +0000