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