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