HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update Gnus to No Gnus 0.7 from the Gnus CVS trunk
[bpt/emacs.git] / lisp / gnus / 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
969(defun imap-sasl-auth-p (buffer)
970 (and (condition-case ()
971 (require 'sasl)
972 (error nil))
973 (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
974
975(defun imap-sasl-auth (buffer)
976 "Login to server using the SASL method."
977 (message "imap: Authenticating using SASL...")
978 (with-current-buffer buffer
979 (make-local-variable 'imap-username)
980 (make-local-variable 'imap-sasl-client)
981 (make-local-variable 'imap-sasl-step)
982 (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
983 logged user)
984 (while (not logged)
985 (setq user (or imap-username
986 (read-from-minibuffer
987 (concat "IMAP username for " imap-server " using SASL "
988 (sasl-mechanism-name mechanism) ": ")
989 (or user imap-default-user))))
990 (when user
991 (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
992 imap-sasl-step (sasl-next-step imap-sasl-client nil))
993 (let ((tag (imap-send-command
994 (if (sasl-step-data imap-sasl-step)
995 (format "AUTHENTICATE %s %s"
996 (sasl-mechanism-name mechanism)
997 (sasl-step-data imap-sasl-step))
998 (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
999 buffer)))
1000 (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
1001 (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
1002 (setq imap-continuation nil
1003 imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
1004 (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
1005 (base64-encode-string (sasl-step-data imap-sasl-step) t)
1006 "")))
1007 (if (imap-ok-p (imap-wait-for-tag tag))
1008 (setq imap-username user
1009 logged t)
1010 (message "Login failed...")
1011 (sit-for 1)))))
1012 logged)))
1013
c113de23 1014(defun imap-digest-md5-p (buffer)
a2617484
DL		 1015 (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
1016 (condition-case ()
c113de23 1017 (require 'digest-md5)
a2617484 1018 (error nil))))
c113de23
GM		 1019
1020(defun imap-digest-md5-auth (buffer)
1021 "Login to server using the AUTH DIGEST-MD5 method."
a2617484 1022 (message "imap: Authenticating using DIGEST-MD5...")
c113de23
GM		 1023 (imap-interactive-login
1024 buffer
1025 (lambda (user passwd)
738421d1 1026 (let ((tag
c113de23
GM		 1027 (imap-send-command
1028 (list
1029 "AUTHENTICATE DIGEST-MD5"
1030 (lambda (challenge)
1031 (digest-md5-parse-digest-challenge
1032 (base64-decode-string challenge))
1033 (let* ((digest-uri
738421d1 1034 (digest-md5-digest-uri
c113de23
GM		 1035 "imap" (digest-md5-challenge 'realm)))
1036 (response
738421d1 1037 (digest-md5-digest-response
c113de23
GM		 1038 user passwd digest-uri)))
1039 (base64-encode-string response 'no-line-break))))
1040 )))
1041 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1042 nil
1043 (setq imap-continuation nil)
1044 (imap-send-command-1 "")
1045 (imap-ok-p (imap-wait-for-tag tag)))))))
1046
1047;; Server functions:
1048
1049(defun imap-open-1 (buffer)
1050 (with-current-buffer buffer
1051 (erase-buffer)
1052 (setq imap-current-mailbox nil
1053 imap-current-message nil
1054 imap-state 'initial
1055 imap-process (condition-case ()
738421d1 1056 (funcall (nth 2 (assq imap-stream
c113de23
GM		 1057 imap-stream-alist))
1058 "imap" buffer imap-server imap-port)
1059 ((error quit) nil)))
1060 (when imap-process
1061 (set-process-filter imap-process 'imap-arrival-filter)
1062 (set-process-sentinel imap-process 'imap-sentinel)
1063 (while (and (eq imap-state 'initial)
1064 (memq (process-status imap-process) '(open run)))
1065 (message "Waiting for response from %s..." imap-server)
1066 (accept-process-output imap-process 1))
1067 (message "Waiting for response from %s...done" imap-server)
1068 (and (memq (process-status imap-process) '(open run))
1069 imap-process))))
1070
1071(defun imap-open (server &optional port stream auth buffer)
1072 "Open a IMAP connection to host SERVER at PORT returning a buffer.
1073If PORT is unspecified, a default value is used (143 except
1074for SSL which use 993).
1075STREAM indicates the stream to use, see `imap-streams' for available
1076streams. If nil, it choices the best stream the server is capable of.
1077AUTH indicates authenticator to use, see `imap-authenticators' for
1078available authenticators. If nil, it choices the best stream the
1079server is capable of.
1080BUFFER can be a buffer or a name of a buffer, which is created if
8f688cb0 1081necessary. If nil, the buffer name is generated."
c113de23
GM		 1082 (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
1083 (with-current-buffer (get-buffer-create buffer)
1084 (if (imap-opened buffer)
1085 (imap-close buffer))
01c52d31 1086 (mapc 'make-local-variable imap-local-variables)
c113de23
GM		 1087 (imap-disable-multibyte)
1088 (buffer-disable-undo)
1089 (setq imap-server (or server imap-server))
1090 (setq imap-port (or port imap-port))
1091 (setq imap-auth (or auth imap-auth))
1092 (setq imap-stream (or stream imap-stream))
a2617484 1093 (message "imap: Connecting to %s..." imap-server)
23f87bed
MB		 1094 (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
1095 (imap-open-1 buffer)))
1096 (progn
1097 (message "imap: Connecting to %s...failed" imap-server)
1098 nil)
1099 (when (null imap-stream)
1100 ;; Need to choose stream.
1101 (let ((streams imap-streams))
1102 (while (setq stream (pop streams))
1103 ;; OK to use this stream?
1104 (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
1105 ;; Stream changed?
1106 (if (not (eq imap-default-stream stream))
1107 (with-current-buffer (get-buffer-create
1108 (generate-new-buffer-name " *temp*"))
01c52d31 1109 (mapc 'make-local-variable imap-local-variables)
23f87bed
MB		 1110 (imap-disable-multibyte)
1111 (buffer-disable-undo)
1112 (setq imap-server (or server imap-server))
1113 (setq imap-port (or port imap-port))
1114 (setq imap-auth (or auth imap-auth))
1115 (message "imap: Reconnecting with stream `%s'..." stream)
1116 (if (null (let ((imap-stream stream))
1117 (imap-open-1 (current-buffer))))
1118 (progn
1119 (kill-buffer (current-buffer))
1120 (message
1121 "imap: Reconnecting with stream `%s'...failed"
1122 stream))
1123 ;; We're done, kill the first connection
1124 (imap-close buffer)
ab513ed4
CY		 1125 (let ((name (if (stringp buffer)
1126 buffer
1127 (buffer-name buffer))))
1128 (kill-buffer buffer)
1129 (rename-buffer name))
23f87bed
MB		 1130 (message "imap: Reconnecting with stream `%s'...done"
1131 stream)
1132 (setq imap-stream stream)
1133 (setq imap-capability nil)
1134 (setq streams nil)))
1135 ;; We're done
1136 (message "imap: Connecting to %s...done" imap-server)
1137 (setq imap-stream stream)
1138 (setq imap-capability nil)
1139 (setq streams nil))))))
1140 (when (imap-opened buffer)
1141 (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1142 (when imap-stream
1143 buffer))))
c113de23
GM		 1144
1145(defun imap-opened (&optional buffer)
1146 "Return non-nil if connection to imap server in BUFFER is open.
1147If BUFFER is nil then the current buffer is used."
1148 (and (setq buffer (get-buffer (or buffer (current-buffer))))
1149 (buffer-live-p buffer)
1150 (with-current-buffer buffer
1151 (and imap-process
1152 (memq (process-status imap-process) '(open run))))))
1153
1154(defun imap-authenticate (&optional user passwd buffer)
1155 "Authenticate to server in BUFFER, using current buffer if nil.
1156It uses the authenticator specified when opening the server. If the
1157authenticator requires username/passwords, they are queried from the
1158user and optionally stored in the buffer. If USER and/or PASSWD is
1159specified, the user will not be questioned and the username and/or
1160password is remembered in the buffer."
1161 (with-current-buffer (or buffer (current-buffer))
1162 (if (not (eq imap-state 'nonauth))
1163 (or (eq imap-state 'auth)
01c52d31 1164 (eq imap-state 'selected)
c113de23 1165 (eq imap-state 'examine))
f78cebe3
SM		 1166 (make-local-variable 'imap-username)
1167 (make-local-variable 'imap-password)
c113de23
GM		 1168 (if user (setq imap-username user))
1169 (if passwd (setq imap-password passwd))
23f87bed
MB		 1170 (if imap-auth
1171 (and (funcall (nth 2 (assq imap-auth
1172 imap-authenticator-alist)) buffer)
1173 (setq imap-state 'auth))
1174 ;; Choose authenticator.
1175 (let ((auths imap-authenticators)
1176 auth)
1177 (while (setq auth (pop auths))
1178 ;; OK to use authenticator?
1179 (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1180 (message "imap: Authenticating to `%s' using `%s'..."
1181 imap-server auth)
1182 (setq imap-auth auth)
1183 (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1184 (progn
1185 (message "imap: Authenticating to `%s' using `%s'...done"
1186 imap-server auth)
1187 (setq auths nil))
1188 (message "imap: Authenticating to `%s' using `%s'...failed"
1189 imap-server auth)))))
1190 imap-state))))
c113de23
GM		 1191
1192(defun imap-close (&optional buffer)
1193 "Close connection to server in BUFFER.
1194If BUFFER is nil, the current buffer is used."
1195 (with-current-buffer (or buffer (current-buffer))
23f87bed
MB		 1196 (when (imap-opened)
1197 (condition-case nil
01c52d31 1198 (imap-logout-wait)
23f87bed 1199 (quit nil)))
c113de23
GM		 1200 (when (and imap-process
1201 (memq (process-status imap-process) '(open run)))
1202 (delete-process imap-process))
1203 (setq imap-current-mailbox nil
1204 imap-current-message nil
1205 imap-process nil)
1206 (erase-buffer)
1207 t))
1208
1209(defun imap-capability (&optional identifier buffer)
1210 "Return a list of identifiers which server in BUFFER support.
1211If IDENTIFIER, return non-nil if it's among the servers capabilities.
1212If BUFFER is nil, the current buffer is assumed."
1213 (with-current-buffer (or buffer (current-buffer))
1214 (unless imap-capability
1215 (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1216 (setq imap-capability '(IMAP2))))
1217 (if identifier
1218 (memq (intern (upcase (symbol-name identifier))) imap-capability)
1219 imap-capability)))
1220
01c52d31
MB		 1221(defun imap-id (&optional list-of-values buffer)
1222 "Identify client to server in BUFFER, and return server identity.
1223LIST-OF-VALUES is nil, or a plist with identifier and value
1224strings to send to the server to identify the client.
1225
1226Return a list of identifiers which server in BUFFER support, or
1227nil if it doesn't support ID or returns no information.
1228
1229If BUFFER is nil, the current buffer is assumed."
1230 (with-current-buffer (or buffer (current-buffer))
1231 (when (and (imap-capability 'ID)
1232 (imap-ok-p (imap-send-command-wait
1233 (if (null list-of-values)
1234 "ID NIL"
1235 (concat "ID (" (mapconcat (lambda (el)
1236 (concat "\"" el "\""))
1237 list-of-values
1238 " ") ")")))))
1239 imap-id)))
1240
c113de23
GM		 1241(defun imap-namespace (&optional buffer)
1242 "Return a namespace hierarchy at server in BUFFER.
1243If BUFFER is nil, the current buffer is assumed."
1244 (with-current-buffer (or buffer (current-buffer))
1245 (unless imap-namespace
1246 (when (imap-capability 'NAMESPACE)
1247 (imap-send-command-wait "NAMESPACE")))
1248 imap-namespace))
1249
1250(defun imap-send-command-wait (command &optional buffer)
1251 (imap-wait-for-tag (imap-send-command command buffer) buffer))
1252
01c52d31
MB		 1253(defun imap-logout (&optional buffer)
1254 (or buffer (setq buffer (current-buffer)))
1255 (if imap-logout-timeout
1256 (with-timeout (imap-logout-timeout
1257 (condition-case nil
1258 (with-current-buffer buffer
1259 (delete-process imap-process))
1260 (error)))
1261 (imap-send-command "LOGOUT" buffer))
1262 (imap-send-command "LOGOUT" buffer)))
1263
1264(defun imap-logout-wait (&optional buffer)
1265 (or buffer (setq buffer (current-buffer)))
1266 (if imap-logout-timeout
1267 (with-timeout (imap-logout-timeout
1268 (condition-case nil
1269 (with-current-buffer buffer
1270 (delete-process imap-process))
1271 (error)))
1272 (imap-send-command-wait "LOGOUT" buffer))
1273 (imap-send-command-wait "LOGOUT" buffer)))
1274
c113de23
GM		 1275\f
1276;; Mailbox functions:
1277
1278(defun imap-mailbox-put (propname value &optional mailbox buffer)
1279 (with-current-buffer (or buffer (current-buffer))
1280 (if imap-mailbox-data
1281 (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1282 propname value)
1283 (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1284 propname value mailbox (current-buffer)))
1285 t))
1286
1287(defsubst imap-mailbox-get-1 (propname &optional mailbox)
1288 (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1289 propname))
1290
1291(defun imap-mailbox-get (propname &optional mailbox buffer)
1292 (let ((mailbox (imap-utf7-encode mailbox)))
1293 (with-current-buffer (or buffer (current-buffer))
1294 (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1295
1296(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1297 (with-current-buffer (or buffer (current-buffer))
1298 (let (result)
738421d1 1299 (mapatoms
c113de23
GM		 1300 (lambda (s)
1301 (push (funcall func (if mailbox-decoder
1302 (funcall mailbox-decoder (symbol-name s))
1303 (symbol-name s))) result))
1304 imap-mailbox-data)
1305 result)))
1306
1307(defun imap-mailbox-map (func &optional buffer)
1308 "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1309Function should take a mailbox name (a string) as
1310the only argument."
1311 (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1312
1313(defun imap-current-mailbox (&optional buffer)
1314 (with-current-buffer (or buffer (current-buffer))
1315 (imap-utf7-decode imap-current-mailbox)))
1316
1317(defun imap-current-mailbox-p-1 (mailbox &optional examine)
1318 (and (string= mailbox imap-current-mailbox)
1319 (or (and examine
1320 (eq imap-state 'examine))
1321 (and (not examine)
1322 (eq imap-state 'selected)))))
1323
1324(defun imap-current-mailbox-p (mailbox &optional examine buffer)
1325 (with-current-buffer (or buffer (current-buffer))
1326 (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1327
1328(defun imap-mailbox-select-1 (mailbox &optional examine)
1329 "Select MAILBOX on server in BUFFER.
1330If EXAMINE is non-nil, do a read-only select."
1331 (if (imap-current-mailbox-p-1 mailbox examine)
1332 imap-current-mailbox
1333 (setq imap-current-mailbox mailbox)
1334 (if (imap-ok-p (imap-send-command-wait
738421d1 1335 (concat (if examine "EXAMINE" "SELECT") " \""
c113de23
GM		 1336 mailbox "\"")))
1337 (progn
1338 (setq imap-message-data (make-vector imap-message-prime 0)
1339 imap-state (if examine 'examine 'selected))
1340 imap-current-mailbox)
1341 ;; Failed SELECT/EXAMINE unselects current mailbox
1342 (setq imap-current-mailbox nil))))
1343
738421d1 1344(defun imap-mailbox-select (mailbox &optional examine buffer)
c113de23 1345 (with-current-buffer (or buffer (current-buffer))
738421d1 1346 (imap-utf7-decode
c113de23
GM		 1347 (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1348
1349(defun imap-mailbox-examine-1 (mailbox &optional buffer)
1350 (with-current-buffer (or buffer (current-buffer))
738421d1 1351 (imap-mailbox-select-1 mailbox 'examine)))
c113de23
GM		 1352
1353(defun imap-mailbox-examine (mailbox &optional buffer)
1354 "Examine MAILBOX on server in BUFFER."
738421d1 1355 (imap-mailbox-select mailbox 'examine buffer))
c113de23
GM		 1356
1357(defun imap-mailbox-unselect (&optional buffer)
1358 "Close current folder in BUFFER, without expunging articles."
1359 (with-current-buffer (or buffer (current-buffer))
1360 (when (or (eq imap-state 'auth)
1361 (and (imap-capability 'UNSELECT)
1362 (imap-ok-p (imap-send-command-wait "UNSELECT")))
738421d1 1363 (and (imap-ok-p
c113de23
GM		 1364 (imap-send-command-wait (concat "EXAMINE \""
1365 imap-current-mailbox
1366 "\"")))
1367 (imap-ok-p (imap-send-command-wait "CLOSE"))))
1368 (setq imap-current-mailbox nil
1369 imap-message-data nil
1370 imap-state 'auth)
1371 t)))
1372
23f87bed 1373(defun imap-mailbox-expunge (&optional asynch buffer)
c113de23 1374 "Expunge articles in current folder in BUFFER.
23f87bed 1375If ASYNCH, do not wait for succesful completion of the command.
c113de23
GM		 1376If BUFFER is nil the current buffer is assumed."
1377 (with-current-buffer (or buffer (current-buffer))
1378 (when (and imap-current-mailbox (not (eq imap-state 'examine)))
23f87bed
MB		 1379 (if asynch
1380 (imap-send-command "EXPUNGE")
1381 (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
c113de23 1382
23f87bed 1383(defun imap-mailbox-close (&optional asynch buffer)
c113de23 1384 "Expunge articles and close current folder in BUFFER.
23f87bed 1385If ASYNCH, do not wait for succesful completion of the command.
c113de23
GM		 1386If BUFFER is nil the current buffer is assumed."
1387 (with-current-buffer (or buffer (current-buffer))
23f87bed
MB		 1388 (when imap-current-mailbox
1389 (if asynch
1390 (imap-add-callback (imap-send-command "CLOSE")
1391 `(lambda (tag status)
1392 (message "IMAP mailbox `%s' closed... %s"
1393 imap-current-mailbox status)
1394 (when (eq ,imap-current-mailbox
1395 imap-current-mailbox)
1396 ;; Don't wipe out data if another mailbox
1397 ;; was selected...
1398 (setq imap-current-mailbox nil
1399 imap-message-data nil
1400 imap-state 'auth))))
1401 (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1402 (setq imap-current-mailbox nil
1403 imap-message-data nil
1404 imap-state 'auth)))
c113de23
GM		 1405 t)))
1406
1407(defun imap-mailbox-create-1 (mailbox)
1408 (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1409
1410(defun imap-mailbox-create (mailbox &optional buffer)
1411 "Create MAILBOX on server in BUFFER.
1412If BUFFER is nil the current buffer is assumed."
1413 (with-current-buffer (or buffer (current-buffer))
1414 (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1415
1416(defun imap-mailbox-delete (mailbox &optional buffer)
1417 "Delete MAILBOX on server in BUFFER.
1418If BUFFER is nil the current buffer is assumed."
1419 (let ((mailbox (imap-utf7-encode mailbox)))
1420 (with-current-buffer (or buffer (current-buffer))
1421 (imap-ok-p
1422 (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1423
1424(defun imap-mailbox-rename (oldname newname &optional buffer)
1425 "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1426If BUFFER is nil the current buffer is assumed."
1427 (let ((oldname (imap-utf7-encode oldname))
1428 (newname (imap-utf7-encode newname)))
1429 (with-current-buffer (or buffer (current-buffer))
1430 (imap-ok-p
1431 (imap-send-command-wait (list "RENAME \"" oldname "\" "
1432 "\"" newname "\""))))))
1433
738421d1 1434(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
c113de23
GM		 1435 "Return a list of subscribed mailboxes on server in BUFFER.
1436If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
1437non-nil, a hierarchy delimiter is added to root. REFERENCE is a
1438implementation-specific string that has to be passed to lsub command."
1439 (with-current-buffer (or buffer (current-buffer))
1440 ;; Make sure we know the hierarchy separator for root's hierarchy
1441 (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1442 (imap-send-command-wait (concat "LIST \"" reference "\" \""
1443 (imap-utf7-encode root) "\"")))
1444 ;; clear list data (NB not delimiter and other stuff)
1445 (imap-mailbox-map-1 (lambda (mailbox)
1446 (imap-mailbox-put 'lsub nil mailbox)))
1447 (when (imap-ok-p
738421d1 1448 (imap-send-command-wait
c113de23
GM		 1449 (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1450 (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1451 "%\"")))
1452 (let (out)
1453 (imap-mailbox-map-1 (lambda (mailbox)
1454 (when (imap-mailbox-get-1 'lsub mailbox)
1455 (push (imap-utf7-decode mailbox) out))))
1456 (nreverse out)))))
1457
1458(defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1459 "Return a list of mailboxes matching ROOT on server in BUFFER.
1460If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1461root. REFERENCE is a implementation-specific string that has to be
1462passed to list command."
1463 (with-current-buffer (or buffer (current-buffer))
1464 ;; Make sure we know the hierarchy separator for root's hierarchy
1465 (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1466 (imap-send-command-wait (concat "LIST \"" reference "\" \""
1467 (imap-utf7-encode root) "\"")))
1468 ;; clear list data (NB not delimiter and other stuff)
1469 (imap-mailbox-map-1 (lambda (mailbox)
1470 (imap-mailbox-put 'list nil mailbox)))
1471 (when (imap-ok-p
738421d1 1472 (imap-send-command-wait
c113de23
GM		 1473 (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1474 (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1475 "%\"")))
1476 (let (out)
1477 (imap-mailbox-map-1 (lambda (mailbox)
1478 (when (imap-mailbox-get-1 'list mailbox)
1479 (push (imap-utf7-decode mailbox) out))))
1480 (nreverse out)))))
1481
1482(defun imap-mailbox-subscribe (mailbox &optional buffer)
1483 "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1484Returns non-nil if successful."
1485 (with-current-buffer (or buffer (current-buffer))
738421d1 1486 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
c113de23
GM		 1487 (imap-utf7-encode mailbox)
1488 "\"")))))
1489
1490(defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1491 "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1492Returns non-nil if successful."
1493 (with-current-buffer (or buffer (current-buffer))
738421d1 1494 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
c113de23
GM		 1495 (imap-utf7-encode mailbox)
1496 "\"")))))
1497
1498(defun imap-mailbox-status (mailbox items &optional buffer)
1499 "Get status items ITEM in MAILBOX from server in BUFFER.
1500ITEMS can be a symbol or a list of symbols, valid symbols are one of
1501the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1502or 'unseen. If ITEMS is a list of symbols, a list of values is
4f014d55 1503returned, if ITEMS is a symbol only its value is returned."
c113de23 1504 (with-current-buffer (or buffer (current-buffer))
738421d1 1505 (when (imap-ok-p
c113de23
GM		 1506 (imap-send-command-wait (list "STATUS \""
1507 (imap-utf7-encode mailbox)
1508 "\" "
23f87bed
MB		 1509 (upcase
1510 (format "%s"
1511 (if (listp items)
1512 items
1513 (list items)))))))
c113de23
GM		 1514 (if (listp items)
1515 (mapcar (lambda (item)
1516 (imap-mailbox-get item mailbox))
1517 items)
1518 (imap-mailbox-get items mailbox)))))
1519
23f87bed
MB		 1520(defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1521 "Send status item request ITEM on MAILBOX to server in BUFFER.
1522ITEMS can be a symbol or a list of symbols, valid symbols are one of
1523the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1524or 'unseen. The IMAP command tag is returned."
1525 (with-current-buffer (or buffer (current-buffer))
1526 (imap-send-command (list "STATUS \""
1527 (imap-utf7-encode mailbox)
1528 "\" "
1529 (format "%s"
1530 (if (listp items)
1531 items
1532 (list items)))))))
1533
c113de23
GM		 1534(defun imap-mailbox-acl-get (&optional mailbox buffer)
1535 "Get ACL on mailbox from server in BUFFER."
1536 (let ((mailbox (imap-utf7-encode mailbox)))
1537 (with-current-buffer (or buffer (current-buffer))
1538 (when (imap-ok-p
1539 (imap-send-command-wait (list "GETACL \""
1540 (or mailbox imap-current-mailbox)
1541 "\"")))
1542 (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1543
1544(defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1545 "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1546 (let ((mailbox (imap-utf7-encode mailbox)))
1547 (with-current-buffer (or buffer (current-buffer))
1548 (imap-ok-p
1549 (imap-send-command-wait (list "SETACL \""
1550 (or mailbox imap-current-mailbox)
1551 "\" "
1552 identifier
1553 " "
1554 rights))))))
1555
1556(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1557 "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1558 (let ((mailbox (imap-utf7-encode mailbox)))
1559 (with-current-buffer (or buffer (current-buffer))
1560 (imap-ok-p
1561 (imap-send-command-wait (list "DELETEACL \""
1562 (or mailbox imap-current-mailbox)
1563 "\" "
1564 identifier))))))
1565
1566\f
1567;; Message functions:
1568
1569(defun imap-current-message (&optional buffer)
1570 (with-current-buffer (or buffer (current-buffer))
1571 imap-current-message))
1572
1573(defun imap-list-to-message-set (list)
1574 (mapconcat (lambda (item)
1575 (number-to-string item))
1576 (if (listp list)
1577 list
1578 (list list))
1579 ","))
1580
1581(defun imap-range-to-message-set (range)
1582 (mapconcat
1583 (lambda (item)
1584 (if (consp item)
23f87bed
MB		 1585 (format "%d:%d"
1586 (car item) (cdr item))
c113de23
GM		 1587 (format "%d" item)))
1588 (if (and (listp range) (not (listp (cdr range))))
1589 (list range) ;; make (1 . 2) into ((1 . 2))
1590 range)
1591 ","))
1592
1593(defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1594 (with-current-buffer (or buffer (current-buffer))
1595 (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1596 (if (listp uids)
1597 (imap-list-to-message-set uids)
1598 uids)
1599 props))))
1600
1601(defun imap-fetch (uids props &optional receive nouidfetch buffer)
1602 "Fetch properties PROPS from message set UIDS from server in BUFFER.
1603UIDS can be a string, number or a list of numbers. If RECEIVE
c430597d 1604is non-nil return these properties."
c113de23 1605 (with-current-buffer (or buffer (current-buffer))
738421d1 1606 (when (imap-ok-p (imap-send-command-wait
c113de23
GM		 1607 (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1608 (if (listp uids)
1609 (imap-list-to-message-set uids)
1610 uids)
1611 props)))
1612 (if (or (null receive) (stringp uids))
1613 t
1614 (if (listp uids)
1615 (mapcar (lambda (uid)
1616 (if (listp receive)
1617 (mapcar (lambda (prop)
1618 (imap-message-get uid prop))
1619 receive)
1620 (imap-message-get uid receive)))
1621 uids)
1622 (imap-message-get uids receive))))))
738421d1 1623
c113de23
GM		 1624(defun imap-message-put (uid propname value &optional buffer)
1625 (with-current-buffer (or buffer (current-buffer))
1626 (if imap-message-data
1627 (put (intern (number-to-string uid) imap-message-data)
1628 propname value)
1629 (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1630 uid propname value (current-buffer)))
1631 t))
1632
1633(defun imap-message-get (uid propname &optional buffer)
1634 (with-current-buffer (or buffer (current-buffer))
1635 (get (intern-soft (number-to-string uid) imap-message-data)
1636 propname)))
1637
1638(defun imap-message-map (func propname &optional buffer)
1639 "Map a function across each mailbox in `imap-message-data', returning a list."
1640 (with-current-buffer (or buffer (current-buffer))
1641 (let (result)
1642 (mapatoms
1643 (lambda (s)
1644 (push (funcall func (get s 'UID) (get s propname)) result))
1645 imap-message-data)
1646 result)))
1647
1648(defmacro imap-message-envelope-date (uid &optional buffer)
1649 `(with-current-buffer (or ,buffer (current-buffer))
1650 (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1651
1652(defmacro imap-message-envelope-subject (uid &optional buffer)
1653 `(with-current-buffer (or ,buffer (current-buffer))
1654 (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1655
1656(defmacro imap-message-envelope-from (uid &optional buffer)
1657 `(with-current-buffer (or ,buffer (current-buffer))
1658 (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1659
1660(defmacro imap-message-envelope-sender (uid &optional buffer)
1661 `(with-current-buffer (or ,buffer (current-buffer))
1662 (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1663
1664(defmacro imap-message-envelope-reply-to (uid &optional buffer)
1665 `(with-current-buffer (or ,buffer (current-buffer))
1666 (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1667
1668(defmacro imap-message-envelope-to (uid &optional buffer)
1669 `(with-current-buffer (or ,buffer (current-buffer))
1670 (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1671
1672(defmacro imap-message-envelope-cc (uid &optional buffer)
1673 `(with-current-buffer (or ,buffer (current-buffer))
1674 (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1675
1676(defmacro imap-message-envelope-bcc (uid &optional buffer)
1677 `(with-current-buffer (or ,buffer (current-buffer))
1678 (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1679
1680(defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1681 `(with-current-buffer (or ,buffer (current-buffer))
1682 (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1683
1684(defmacro imap-message-envelope-message-id (uid &optional buffer)
1685 `(with-current-buffer (or ,buffer (current-buffer))
1686 (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1687
1688(defmacro imap-message-body (uid &optional buffer)
1689 `(with-current-buffer (or ,buffer (current-buffer))
1690 (imap-message-get ,uid 'BODY)))
1691
1692(defun imap-search (predicate &optional buffer)
1693 (with-current-buffer (or buffer (current-buffer))
1694 (imap-mailbox-put 'search 'dummy)
1695 (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1696 (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
23f87bed
MB		 1697 (progn
1698 (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1699 nil)
c113de23
GM		 1700 (imap-mailbox-get-1 'search imap-current-mailbox)))))
1701
1702(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
e7f767c2 1703 "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
c113de23
GM		 1704 (with-current-buffer (or buffer (current-buffer))
1705 (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1706 (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1707
1708(defun imap-message-flags-set (articles flags &optional silent buffer)
1709 (when (and articles flags)
1710 (with-current-buffer (or buffer (current-buffer))
1711 (imap-ok-p (imap-send-command-wait
1712 (concat "UID STORE " articles
1713 " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1714
1715(defun imap-message-flags-del (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-add (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-copyuid-1 (mailbox)
1730 (if (imap-capability 'UIDPLUS)
1731 (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1732 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1733 (let ((old-mailbox imap-current-mailbox)
1734 (state imap-state)
1735 (imap-message-data (make-vector 2 0)))
1736 (when (imap-mailbox-examine-1 mailbox)
1737 (prog1
1738 (and (imap-fetch "*" "UID")
1739 (list (imap-mailbox-get-1 'uidvalidity mailbox)
1740 (apply 'max (imap-message-map
1741 (lambda (uid prop) uid) 'UID))))
1742 (if old-mailbox
1743 (imap-mailbox-select old-mailbox (eq state 'examine))
1744 (imap-mailbox-unselect)))))))
1745
1746(defun imap-message-copyuid (mailbox &optional buffer)
1747 (with-current-buffer (or buffer (current-buffer))
1748 (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1749
1750(defun imap-message-copy (articles mailbox
1751 &optional dont-create no-copyuid buffer)
1752 "Copy ARTICLES (a string message set) to MAILBOX on server in
1753BUFFER, creating mailbox if it doesn't exist. If dont-create is
1754non-nil, it will not create a mailbox. On success, return a list with
1755the UIDVALIDITY of the mailbox the article(s) was copied to as the
1756first element, rest of list contain the saved articles' UIDs."
1757 (when articles
1758 (with-current-buffer (or buffer (current-buffer))
1759 (let ((mailbox (imap-utf7-encode mailbox)))
1760 (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1761 (imap-current-target-mailbox mailbox))
1762 (if (imap-ok-p (imap-send-command-wait cmd))
1763 t
1764 (when (and (not dont-create)
23f87bed
MB		 1765 ;; removed because of buggy Oracle server
1766 ;; that doesn't send TRYCREATE tags (which
1767 ;; is a MUST according to specifications):
1768 ;;(imap-mailbox-get-1 'trycreate mailbox)
1769 (imap-mailbox-create-1 mailbox))
c113de23
GM		 1770 (imap-ok-p (imap-send-command-wait cmd)))))
1771 (or no-copyuid
1772 (imap-message-copyuid-1 mailbox)))))))
738421d1 1773
c113de23
GM		 1774(defun imap-message-appenduid-1 (mailbox)
1775 (if (imap-capability 'UIDPLUS)
1776 (imap-mailbox-get-1 'appenduid mailbox)
1777 (let ((old-mailbox imap-current-mailbox)
1778 (state imap-state)
1779 (imap-message-data (make-vector 2 0)))
1780 (when (imap-mailbox-examine-1 mailbox)
1781 (prog1
1782 (and (imap-fetch "*" "UID")
1783 (list (imap-mailbox-get-1 'uidvalidity mailbox)
1784 (apply 'max (imap-message-map
1785 (lambda (uid prop) uid) 'UID))))
1786 (if old-mailbox
1787 (imap-mailbox-select old-mailbox (eq state 'examine))
1788 (imap-mailbox-unselect)))))))
1789
1790(defun imap-message-appenduid (mailbox &optional buffer)
1791 (with-current-buffer (or buffer (current-buffer))
1792 (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1793
1794(defun imap-message-append (mailbox article &optional flags date-time buffer)
1795 "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1796FLAGS and DATE-TIME is currently not used. Return a cons holding
1797uidvalidity of MAILBOX and UID the newly created article got, or nil
1798on failure."
1799 (let ((mailbox (imap-utf7-encode mailbox)))
1800 (with-current-buffer (or buffer (current-buffer))
1801 (and (let ((imap-current-target-mailbox mailbox))
738421d1
SS		 1802 (imap-ok-p
1803 (imap-send-command-wait
c113de23
GM		 1804 (list "APPEND \"" mailbox "\" " article))))
1805 (imap-message-appenduid-1 mailbox)))))
738421d1 1806
c113de23
GM		 1807(defun imap-body-lines (body)
1808 "Return number of lines in article by looking at the mime bodystructure BODY."
1809 (if (listp body)
1810 (if (stringp (car body))
1811 (cond ((and (string= (upcase (car body)) "TEXT")
1812 (numberp (nth 7 body)))
1813 (nth 7 body))
1814 ((and (string= (upcase (car body)) "MESSAGE")
1815 (numberp (nth 9 body)))
1816 (nth 9 body))
1817 (t 0))
1818 (apply '+ (mapcar 'imap-body-lines body)))
1819 0))
1820
1821(defun imap-envelope-from (from)
1822 "Return a from string line."
1823 (and from
1824 (concat (aref from 0)
1825 (if (aref from 0) " <")
738421d1
SS		 1826 (aref from 2)
1827 "@"
c113de23
GM		 1828 (aref from 3)
1829 (if (aref from 0) ">"))))
1830
1831\f
1832;; Internal functions.
1833
23f87bed
MB		 1834(defun imap-add-callback (tag func)
1835 (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1836
c113de23
GM		 1837(defun imap-send-command-1 (cmdstr)
1838 (setq cmdstr (concat cmdstr imap-client-eol))
1839 (and imap-log
23f87bed 1840 (with-current-buffer (get-buffer-create imap-log-buffer)
c113de23
GM		 1841 (imap-disable-multibyte)
1842 (buffer-disable-undo)
1843 (goto-char (point-max))
1844 (insert cmdstr)))
1845 (process-send-string imap-process cmdstr))
1846
1847(defun imap-send-command (command &optional buffer)
1848 (with-current-buffer (or buffer (current-buffer))
1849 (if (not (listp command)) (setq command (list command)))
1850 (let ((tag (setq imap-tag (1+ imap-tag)))
1851 cmd cmdstr)
1852 (setq cmdstr (concat (number-to-string imap-tag) " "))
1853 (while (setq cmd (pop command))
1854 (cond ((stringp cmd)
1855 (setq cmdstr (concat cmdstr cmd)))
1856 ((bufferp cmd)
1857 (let ((eol imap-client-eol)
1858 (calcfirst imap-calculate-literal-size-first)
1859 size)
1860 (with-current-buffer cmd
1861 (if calcfirst
1862 (setq size (buffer-size)))
1863 (when (not (equal eol "\r\n"))
1864 ;; XXX modifies buffer!
1865 (goto-char (point-min))
1866 (while (search-forward "\r\n" nil t)
1867 (replace-match eol)))
1868 (if (not calcfirst)
1869 (setq size (buffer-size))))
738421d1 1870 (setq cmdstr
c113de23
GM		 1871 (concat cmdstr (format "{%d}" size))))
1872 (unwind-protect
1873 (progn
1874 (imap-send-command-1 cmdstr)
1875 (setq cmdstr nil)
1876 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
23f87bed 1877 (setq command nil) ;; abort command if no cont-req
c113de23
GM		 1878 (let ((process imap-process)
1879 (stream imap-stream)
1880 (eol imap-client-eol))
1881 (with-current-buffer cmd
1882 (and imap-log
1883 (with-current-buffer (get-buffer-create
23f87bed 1884 imap-log-buffer)
c113de23
GM		 1885 (imap-disable-multibyte)
1886 (buffer-disable-undo)
1887 (goto-char (point-max))
1888 (insert-buffer-substring cmd)))
1889 (process-send-region process (point-min)
1890 (point-max)))
1891 (process-send-string process imap-client-eol))))
1892 (setq imap-continuation nil)))
1893 ((functionp cmd)
1894 (imap-send-command-1 cmdstr)
1895 (setq cmdstr nil)
1896 (unwind-protect
1897 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
23f87bed 1898 (setq command nil) ;; abort command if no cont-req
c113de23
GM		 1899 (setq command (cons (funcall cmd imap-continuation)
1900 command)))
1901 (setq imap-continuation nil)))
1902 (t
1903 (error "Unknown command type"))))
1904 (if cmdstr
1905 (imap-send-command-1 cmdstr))
1906 tag)))
1907
1908(defun imap-wait-for-tag (tag &optional buffer)
1909 (with-current-buffer (or buffer (current-buffer))
23f87bed
MB		 1910 (let (imap-have-messaged)
1911 (while (and (null imap-continuation)
1912 (memq (process-status imap-process) '(open run))
1913 (< imap-reached-tag tag))
1914 (let ((len (/ (point-max) 1024))
1915 message-log-max)
1916 (unless (< len 10)
1917 (setq imap-have-messaged t)
1918 (message "imap read: %dk" len))
1919 (accept-process-output imap-process
1920 (truncate imap-read-timeout)
1921 (truncate (* (- imap-read-timeout
1922 (truncate imap-read-timeout))
1923 1000)))))
1924 ;; A process can die _before_ we have processed everything it
1925 ;; has to say. Moreover, this can happen in between the call to
1926 ;; accept-process-output and the call to process-status in an
1927 ;; iteration of the loop above.
1928 (when (and (null imap-continuation)
1929 (< imap-reached-tag tag))
1930 (accept-process-output imap-process 0 0))
1931 (when imap-have-messaged
1932 (message ""))
1933 (and (memq (process-status imap-process) '(open run))
1934 (or (assq tag imap-failed-tags)
1935 (if imap-continuation
1936 'INCOMPLETE
1937 'OK))))))
c113de23
GM		 1938
1939(defun imap-sentinel (process string)
1940 (delete-process process))
1941
1942(defun imap-find-next-line ()
1943 "Return point at end of current line, taking into account literals.
1944Return nil if no complete line has arrived."
1945 (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1946 imap-server-eol)
1947 nil t)
1948 (if (match-string 1)
1949 (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1950 nil
1951 (goto-char (+ (point) (string-to-number (match-string 1))))
1952 (imap-find-next-line))
1953 (point))))
1954
1955(defun imap-arrival-filter (proc string)
1956 "IMAP process filter."
23f87bed
MB		 1957 ;; Sometimes, we are called even though the process has died.
1958 ;; Better abstain from doing stuff in that case.
1959 (when (buffer-name (process-buffer proc))
1960 (with-current-buffer (process-buffer proc)
1961 (goto-char (point-max))
1962 (insert string)
1963 (and imap-log
1964 (with-current-buffer (get-buffer-create imap-log-buffer)
1965 (imap-disable-multibyte)
1966 (buffer-disable-undo)
1967 (goto-char (point-max))
1968 (insert string)))
1969 (let (end)
1970 (goto-char (point-min))
1971 (while (setq end (imap-find-next-line))
1972 (save-restriction
1973 (narrow-to-region (point-min) end)
1974 (delete-backward-char (length imap-server-eol))
1975 (goto-char (point-min))
1976 (unwind-protect
1977 (cond ((eq imap-state 'initial)
1978 (imap-parse-greeting))
1979 ((or (eq imap-state 'auth)
1980 (eq imap-state 'nonauth)
1981 (eq imap-state 'selected)
1982 (eq imap-state 'examine))
1983 (imap-parse-response))
1984 (t
1985 (message "Unknown state %s in arrival filter"
1986 imap-state)))
1987 (delete-region (point-min) (point-max)))))))))
c113de23
GM		 1988
1989\f
1990;; Imap parser.
1991
1992(defsubst imap-forward ()
1993 (or (eobp) (forward-char)))
1994
1995;; number = 1*DIGIT
1996;; ; Unsigned 32-bit integer
1997;; ; (0 <= n < 4,294,967,296)
1998
1999(defsubst imap-parse-number ()
2000 (when (looking-at "[0-9]+")
2001 (prog1
2002 (string-to-number (match-string 0))
2003 (goto-char (match-end 0)))))
2004
2005;; literal = "{" number "}" CRLF *CHAR8
2006;; ; Number represents the number of CHAR8s
2007
2008(defsubst imap-parse-literal ()
2009 (when (looking-at "{\\([0-9]+\\)}\r\n")
2010 (let ((pos (match-end 0))
2011 (len (string-to-number (match-string 1))))
2012 (if (< (point-max) (+ pos len))
2013 nil
2014 (goto-char (+ pos len))
2015 (buffer-substring pos (+ pos len))))))
2016
2017;; string = quoted / literal
2018;;
2019;; quoted = DQUOTE *QUOTED-CHAR DQUOTE
2020;;
2021;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
2022;; "\" quoted-specials
2023;;
2024;; quoted-specials = DQUOTE / "\"
2025;;
2026;; TEXT-CHAR = <any CHAR except CR and LF>
2027
2028(defsubst imap-parse-string ()
2029 (cond ((eq (char-after) ?\")
2030 (forward-char 1)
2031 (let ((p (point)) (name ""))
2032 (skip-chars-forward "^\"\\\\")
2033 (setq name (buffer-substring p (point)))
2034 (while (eq (char-after) ?\\)
2035 (setq p (1+ (point)))
2036 (forward-char 2)
2037 (skip-chars-forward "^\"\\\\")
2038 (setq name (concat name (buffer-substring p (point)))))
2039 (forward-char 1)
2040 name))
2041 ((eq (char-after) ?{)
2042 (imap-parse-literal))))
2043
2044;; nil = "NIL"
2045
2046(defsubst imap-parse-nil ()
2047 (if (looking-at "NIL")
2048 (goto-char (match-end 0))))
2049
2050;; nstring = string / nil
2051
2052(defsubst imap-parse-nstring ()
2053 (or (imap-parse-string)
2054 (and (imap-parse-nil)
2055 nil)))
2056
2057;; astring = atom / string
2058;;
2059;; atom = 1*ATOM-CHAR
2060;;
2061;; ATOM-CHAR = <any CHAR except atom-specials>
2062;;
2063;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards /
2064;; quoted-specials
2065;;
2066;; list-wildcards = "%" / "*"
2067;;
2068;; quoted-specials = DQUOTE / "\"
2069
2070(defsubst imap-parse-astring ()
2071 (or (imap-parse-string)
738421d1 2072 (buffer-substring (point)
c113de23
GM		 2073 (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
2074 (goto-char (1- (match-end 0)))
2075 (end-of-line)
2076 (point)))))
2077
2078;; address = "(" addr-name SP addr-adl SP addr-mailbox SP
2079;; addr-host ")"
2080;;
2081;; addr-adl = nstring
2082;; ; Holds route from [RFC-822] route-addr if
0ff9b955 2083;; ; non-nil
c113de23
GM		 2084;;
2085;; addr-host = nstring
0ff9b955 2086;; ; nil indicates [RFC-822] group syntax.
c113de23
GM		 2087;; ; Otherwise, holds [RFC-822] domain name
2088;;
2089;; addr-mailbox = nstring
0ff9b955
PJ		 2090;; ; nil indicates end of [RFC-822] group; if
2091;; ; non-nil and addr-host is nil, holds
c113de23
GM		 2092;; ; [RFC-822] group name.
2093;; ; Otherwise, holds [RFC-822] local-part
2094;; ; after removing [RFC-822] quoting
2095;;
2096;; addr-name = nstring
0ff9b955 2097;; ; If non-nil, holds phrase from [RFC-822]
c113de23
GM		 2098;; ; mailbox after removing [RFC-822] quoting
2099;;
2100
2101(defsubst imap-parse-address ()
2102 (let (address)
2103 (when (eq (char-after) ?\()
2104 (imap-forward)
2105 (setq address (vector (prog1 (imap-parse-nstring)
2106 (imap-forward))
2107 (prog1 (imap-parse-nstring)
2108 (imap-forward))
2109 (prog1 (imap-parse-nstring)
2110 (imap-forward))
2111 (imap-parse-nstring)))
2112 (when (eq (char-after) ?\))
2113 (imap-forward)
2114 address))))
2115
2116;; address-list = "(" 1*address ")" / nil
2117;;
2118;; nil = "NIL"
2119
2120(defsubst imap-parse-address-list ()
2121 (if (eq (char-after) ?\()
2122 (let (address addresses)
2123 (imap-forward)
2124 (while (and (not (eq (char-after) ?\)))
2125 ;; next line for MS Exchange bug
2126 (progn (and (eq (char-after) ? ) (imap-forward)) t)
2127 (setq address (imap-parse-address)))
2128 (setq addresses (cons address addresses)))
2129 (when (eq (char-after) ?\))
2130 (imap-forward)
2131 (nreverse addresses)))
23f87bed
MB		 2132 ;; With assert, the code might not be eval'd.
2133 ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
28d38c0b 2134 (imap-parse-nil)))
c113de23
GM		 2135
2136;; mailbox = "INBOX" / astring
2137;; ; INBOX is case-insensitive. All case variants of
2138;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
2139;; ; not as an astring. An astring which consists of
2140;; ; the case-insensitive sequence "I" "N" "B" "O" "X"
2141;; ; is considered to be INBOX and not an astring.
2142;; ; Refer to section 5.1 for further
2143;; ; semantic details of mailbox names.
2144
2145(defsubst imap-parse-mailbox ()
2146 (let ((mailbox (imap-parse-astring)))
2147 (if (string-equal "INBOX" (upcase mailbox))
2148 "INBOX"
2149 mailbox)))
2150
2151;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
2152;;
2153;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text
2154;; ; Authentication condition
2155;;
2156;; resp-cond-bye = "BYE" SP resp-text
2157
2158(defun imap-parse-greeting ()
2159 "Parse a IMAP greeting."
2160 (cond ((looking-at "\\* OK ")
2161 (setq imap-state 'nonauth))
2162 ((looking-at "\\* PREAUTH ")
2163 (setq imap-state 'auth))
2164 ((looking-at "\\* BYE ")
2165 (setq imap-state 'closed))))
2166
2167;; response = *(continue-req / response-data) response-done
2168;;
2169;; continue-req = "+" SP (resp-text / base64) CRLF
2170;;
2171;; response-data = "*" SP (resp-cond-state / resp-cond-bye /
2172;; mailbox-data / message-data / capability-data) CRLF
2173;;
2174;; response-done = response-tagged / response-fatal
2175;;
2176;; response-fatal = "*" SP resp-cond-bye CRLF
2177;; ; Server closes connection immediately
2178;;
2179;; response-tagged = tag SP resp-cond-state CRLF
2180;;
2181;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
2182;; ; Status condition
2183;;
2184;; resp-cond-bye = "BYE" SP resp-text
2185;;
2186;; mailbox-data = "FLAGS" SP flag-list /
23f87bed 2187;; "LIST" SP mailbox-list /
c113de23
GM		 2188;; "LSUB" SP mailbox-list /
2189;; "SEARCH" *(SP nz-number) /
2190;; "STATUS" SP mailbox SP "("
2191;; [status-att SP number *(SP status-att SP number)] ")" /
2192;; number SP "EXISTS" /
2193;; number SP "RECENT"
2194;;
2195;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
2196;;
2197;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
2198;; *(SP capability)
2199;; ; IMAP4rev1 servers which offer RFC 1730
2200;; ; compatibility MUST list "IMAP4" as the first
2201;; ; capability.
2202
2203(defun imap-parse-response ()
2204 "Parse a IMAP command response."
2205 (let (token)
2206 (case (setq token (read (current-buffer)))
2207 (+ (setq imap-continuation
2208 (or (buffer-substring (min (point-max) (1+ (point)))
2209 (point-max))
2210 t)))
2211 (* (case (prog1 (setq token (read (current-buffer)))
2212 (imap-forward))
2213 (OK (imap-parse-resp-text))
2214 (NO (imap-parse-resp-text))
2215 (BAD (imap-parse-resp-text))
2216 (BYE (imap-parse-resp-text))
2217 (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
2218 (LIST (imap-parse-data-list 'list))
2219 (LSUB (imap-parse-data-list 'lsub))
738421d1
SS		 2220 (SEARCH (imap-mailbox-put
2221 'search
c113de23
GM		 2222 (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2223 (STATUS (imap-parse-status))
738421d1 2224 (CAPABILITY (setq imap-capability
23f87bed
MB		 2225 (read (concat "(" (upcase (buffer-substring
2226 (point) (point-max)))
2227 ")"))))
01c52d31
MB		 2228 (ID (setq imap-id (read (buffer-substring (point)
2229 (point-max)))))
c113de23
GM		 2230 (ACL (imap-parse-acl))
2231 (t (case (prog1 (read (current-buffer))
2232 (imap-forward))
2233 (EXISTS (imap-mailbox-put 'exists token))
2234 (RECENT (imap-mailbox-put 'recent token))
2235 (EXPUNGE t)
2236 (FETCH (imap-parse-fetch token))
2237 (t (message "Garbage: %s" (buffer-string)))))))
2238 (t (let (status)
2239 (if (not (integerp token))
2240 (message "Garbage: %s" (buffer-string))
2241 (case (prog1 (setq status (read (current-buffer)))
2242 (imap-forward))
2243 (OK (progn
2244 (setq imap-reached-tag (max imap-reached-tag token))
2245 (imap-parse-resp-text)))
2246 (NO (progn
2247 (setq imap-reached-tag (max imap-reached-tag token))
2248 (save-excursion
2249 (imap-parse-resp-text))
2250 (let (code text)
2251 (when (eq (char-after) ?\[)
2252 (setq code (buffer-substring (point)
2253 (search-forward "]")))
2254 (imap-forward))
2255 (setq text (buffer-substring (point) (point-max)))
738421d1 2256 (push (list token status code text)
c113de23
GM		 2257 imap-failed-tags))))
2258 (BAD (progn
2259 (setq imap-reached-tag (max imap-reached-tag token))
2260 (save-excursion
2261 (imap-parse-resp-text))
2262 (let (code text)
2263 (when (eq (char-after) ?\[)
2264 (setq code (buffer-substring (point)
2265 (search-forward "]")))
2266 (imap-forward))
2267 (setq text (buffer-substring (point) (point-max)))
2268 (push (list token status code text) imap-failed-tags)
2269 (error "Internal error, tag %s status %s code %s text %s"
2270 token status code text))))
23f87bed
MB		 2271 (t (message "Garbage: %s" (buffer-string))))
2272 (when (assq token imap-callbacks)
2273 (funcall (cdr (assq token imap-callbacks)) token status)
2274 (setq imap-callbacks
2275 (imap-remassoc token imap-callbacks)))))))))
c113de23
GM		 2276
2277;; resp-text = ["[" resp-text-code "]" SP] text
2278;;
2279;; text = 1*TEXT-CHAR
2280;;
2281;; TEXT-CHAR = <any CHAR except CR and LF>
2282
2283(defun imap-parse-resp-text ()
2284 (imap-parse-resp-text-code))
2285
2286;; resp-text-code = "ALERT" /
2287;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
738421d1 2288;; "NEWNAME" SP string SP string /
c113de23 2289;; "PARSE" /
738421d1 2290;; "PERMANENTFLAGS" SP "("
c113de23 2291;; [flag-perm *(SP flag-perm)] ")" /
738421d1
SS		 2292;; "READ-ONLY" /
2293;; "READ-WRITE" /
23f87bed 2294;; "TRYCREATE" /
738421d1 2295;; "UIDNEXT" SP nz-number /
c113de23
GM		 2296;; "UIDVALIDITY" SP nz-number /
2297;; "UNSEEN" SP nz-number /
2298;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2299;;
2300;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid
2301;;
2302;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set
2303;;
2304;; set = sequence-num / (sequence-num ":" sequence-num) /
2305;; (set "," set)
2306;; ; Identifies a set of messages. For message
2307;; ; sequence numbers, these are consecutive
2308;; ; numbers from 1 to the number of messages in
2309;; ; the mailbox
2310;; ; Comma delimits individual numbers, colon
2311;; ; delimits between two numbers inclusive.
2312;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2313;; ; 14,15 for a mailbox with 15 messages.
738421d1 2314;;
c113de23
GM		 2315;; sequence-num = nz-number / "*"
2316;; ; * is the largest number in use. For message
2317;; ; sequence numbers, it is the number of messages
2318;; ; in the mailbox. For unique identifiers, it is
2319;; ; the unique identifier of the last message in
2320;; ; the mailbox.
2321;;
2322;; flag-perm = flag / "\*"
2323;;
2324;; flag = "\Answered" / "\Flagged" / "\Deleted" /
2325;; "\Seen" / "\Draft" / flag-keyword / flag-extension
2326;; ; Does not include "\Recent"
2327;;
2328;; flag-extension = "\" atom
2329;; ; Future expansion. Client implementations
2330;; ; MUST accept flag-extension flags. Server
2331;; ; implementations MUST NOT generate
2332;; ; flag-extension flags except as defined by
2333;; ; future standard or standards-track
2334;; ; revisions of this specification.
2335;;
2336;; flag-keyword = atom
2337;;
2338;; resp-text-atom = 1*<any ATOM-CHAR except "]">
2339
2340(defun imap-parse-resp-text-code ()
23f87bed
MB		 2341 ;; xxx next line for stalker communigate pro 3.3.1 bug
2342 (when (looking-at " \\[")
2343 (imap-forward))
c113de23
GM		 2344 (when (eq (char-after) ?\[)
2345 (imap-forward)
2346 (cond ((search-forward "PERMANENTFLAGS " nil t)
2347 (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
23f87bed
MB		 2348 ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2349 (imap-mailbox-put 'uidnext (match-string 1)))
c113de23 2350 ((search-forward "UNSEEN " nil t)
23f87bed 2351 (imap-mailbox-put 'first-unseen (read (current-buffer))))
c113de23
GM		 2352 ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2353 (imap-mailbox-put 'uidvalidity (match-string 1)))
2354 ((search-forward "READ-ONLY" nil t)
2355 (imap-mailbox-put 'read-only t))
2356 ((search-forward "NEWNAME " nil t)
2357 (let (oldname newname)
2358 (setq oldname (imap-parse-string))
2359 (imap-forward)
2360 (setq newname (imap-parse-string))
2361 (imap-mailbox-put 'newname newname oldname)))
2362 ((search-forward "TRYCREATE" nil t)
2363 (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2364 ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2365 (imap-mailbox-put 'appenduid
2366 (list (match-string 1)
2367 (string-to-number (match-string 2)))
2368 imap-current-target-mailbox))
2369 ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2370 (imap-mailbox-put 'copyuid (list (match-string 1)
2371 (match-string 2)
2372 (match-string 3))
2373 imap-current-target-mailbox))
2374 ((search-forward "ALERT] " nil t)
2375 (message "Imap server %s information: %s" imap-server
2376 (buffer-substring (point) (point-max)))))))
2377
2378;; mailbox-list = "(" [mbx-list-flags] ")" SP
2379;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2380;;
2381;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag
2382;; *(SP mbx-list-oflag) /
2383;; mbx-list-oflag *(SP mbx-list-oflag)
2384;;
2385;; mbx-list-oflag = "\Noinferiors" / flag-extension
2386;; ; Other flags; multiple possible per LIST response
2387;;
2388;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked"
2389;; ; Selectability flags; only one per LIST response
2390;;
2391;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
2392;; "\" quoted-specials
2393;;
2394;; quoted-specials = DQUOTE / "\"
2395
2396(defun imap-parse-data-list (type)
2397 (let (flags delimiter mailbox)
2398 (setq flags (imap-parse-flag-list))
2399 (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2400 (setq delimiter (match-string 1))
2401 (goto-char (1+ (match-end 0)))
2402 (when (setq mailbox (imap-parse-mailbox))
2403 (imap-mailbox-put type t mailbox)
2404 (imap-mailbox-put 'list-flags flags mailbox)
2405 (imap-mailbox-put 'delimiter delimiter mailbox)))))
2406
2407;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope /
2408;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2409;; "INTERNALDATE" SPACE date_time /
2410;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2411;; "RFC822.SIZE" SPACE number /
2412;; "BODY" ["STRUCTURE"] SPACE body /
2413;; "BODY" section ["<" number ">"] SPACE nstring /
2414;; "UID" SPACE uniqueid) ")"
738421d1 2415;;
c113de23
GM		 2416;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
2417;; SPACE time SPACE zone <">
738421d1 2418;;
c113de23
GM		 2419;; section ::= "[" [section_text / (nz_number *["." nz_number]
2420;; ["." (section_text / "MIME")])] "]"
738421d1 2421;;
c113de23
GM		 2422;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2423;; SPACE header_list / "TEXT"
738421d1 2424;;
c113de23 2425;; header_fld_name ::= astring
738421d1 2426;;
c113de23
GM		 2427;; header_list ::= "(" 1#header_fld_name ")"
2428
2429(defsubst imap-parse-header-list ()
2430 (when (eq (char-after) ?\()
2431 (let (strlist)
2432 (while (not (eq (char-after) ?\)))
2433 (imap-forward)
2434 (push (imap-parse-astring) strlist))
2435 (imap-forward)
2436 (nreverse strlist))))
2437
2438(defsubst imap-parse-fetch-body-section ()
738421d1 2439 (let ((section
c113de23
GM		 2440 (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2441 (if (eq (char-before) ? )
2442 (prog1
2443 (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2444 (search-forward "]" nil t))
2445 section)))
2446
2447(defun imap-parse-fetch (response)
2448 (when (eq (char-after) ?\()
738421d1 2449 (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
23f87bed 2450 rfc822size body bodydetail bodystructure flags-empty)
c113de23
GM		 2451 (while (not (eq (char-after) ?\)))
2452 (imap-forward)
2453 (let ((token (read (current-buffer))))
2454 (imap-forward)
2455 (cond ((eq token 'UID)
23f87bed
MB		 2456 (setq uid (condition-case ()
2457 (read (current-buffer))
2458 (error))))
c113de23 2459 ((eq token 'FLAGS)
23f87bed
MB		 2460 (setq flags (imap-parse-flag-list))
2461 (if (not flags)
2462 (setq flags-empty 't)))
c113de23
GM		 2463 ((eq token 'ENVELOPE)
2464 (setq envelope (imap-parse-envelope)))
2465 ((eq token 'INTERNALDATE)
2466 (setq internaldate (imap-parse-string)))
2467 ((eq token 'RFC822)
2468 (setq rfc822 (imap-parse-nstring)))
2469 ((eq token 'RFC822.HEADER)
2470 (setq rfc822header (imap-parse-nstring)))
2471 ((eq token 'RFC822.TEXT)
2472 (setq rfc822text (imap-parse-nstring)))
2473 ((eq token 'RFC822.SIZE)
2474 (setq rfc822size (read (current-buffer))))
2475 ((eq token 'BODY)
2476 (if (eq (char-before) ?\[)
2477 (push (list
2478 (upcase (imap-parse-fetch-body-section))
2479 (and (eq (char-after) ?<)
2480 (buffer-substring (1+ (point))
2481 (search-forward ">" nil t)))
2482 (progn (imap-forward)
2483 (imap-parse-nstring)))
2484 bodydetail)
2485 (setq body (imap-parse-body))))
2486 ((eq token 'BODYSTRUCTURE)
2487 (setq bodystructure (imap-parse-body))))))
2488 (when uid
2489 (setq imap-current-message uid)
2490 (imap-message-put uid 'UID uid)
23f87bed 2491 (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
c113de23
GM		 2492 (and envelope (imap-message-put uid 'ENVELOPE envelope))
2493 (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2494 (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2495 (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2496 (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2497 (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2498 (and body (imap-message-put uid 'BODY body))
2499 (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2500 (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2501 (run-hooks 'imap-fetch-data-hook)))))
2502
2503;; mailbox-data = ...
2504;; "STATUS" SP mailbox SP "("
738421d1 2505;; [status-att SP number
c113de23
GM		 2506;; *(SP status-att SP number)] ")"
2507;; ...
2508;;
2509;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2510;; "UNSEEN"
2511
2512(defun imap-parse-status ()
2513 (let ((mailbox (imap-parse-mailbox)))
23f87bed
MB		 2514 (if (eq (char-after) ? )
2515 (forward-char))
2516 (when (and mailbox (eq (char-after) ?\())
2517 (while (and (not (eq (char-after) ?\)))
2518 (or (forward-char) t)
2519 (looking-at "\\([A-Za-z]+\\) "))
2520 (let ((token (match-string 1)))
2521 (goto-char (match-end 0))
2522 (cond ((string= token "MESSAGES")
c113de23 2523 (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
23f87bed 2524 ((string= token "RECENT")
c113de23 2525 (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
23f87bed
MB		 2526 ((string= token "UIDNEXT")
2527 (and (looking-at "[0-9]+")
2528 (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2529 (goto-char (match-end 0))))
2530 ((string= token "UIDVALIDITY")
2531 (and (looking-at "[0-9]+")
2532 (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2533 (goto-char (match-end 0))))
2534 ((string= token "UNSEEN")
c113de23
GM		 2535 (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2536 (t
738421d1 2537 (message "Unknown status data %s in mailbox %s ignored"
23f87bed
MB		 2538 token mailbox)
2539 (read (current-buffer)))))))))
c113de23
GM		 2540
2541;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2542;; rights)
2543;;
2544;; identifier ::= astring
2545;;
2546;; rights ::= astring
2547
2548(defun imap-parse-acl ()
2549 (let ((mailbox (imap-parse-mailbox))
2550 identifier rights acl)
2551 (while (eq (char-after) ?\ )
2552 (imap-forward)
2553 (setq identifier (imap-parse-astring))
2554 (imap-forward)
2555 (setq rights (imap-parse-astring))
2556 (setq acl (append acl (list (cons identifier rights)))))
2557 (imap-mailbox-put 'acl acl mailbox)))
2558
2559;; flag-list = "(" [flag *(SP flag)] ")"
2560;;
2561;; flag = "\Answered" / "\Flagged" / "\Deleted" /
2562;; "\Seen" / "\Draft" / flag-keyword / flag-extension
2563;; ; Does not include "\Recent"
2564;;
2565;; flag-keyword = atom
2566;;
2567;; flag-extension = "\" atom
2568;; ; Future expansion. Client implementations
2569;; ; MUST accept flag-extension flags. Server
2570;; ; implementations MUST NOT generate
2571;; ; flag-extension flags except as defined by
2572;; ; future standard or standards-track
2573;; ; revisions of this specification.
2574
2575(defun imap-parse-flag-list ()
2576 (let (flag-list start)
e62e7654 2577 (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
a2617484 2578 (while (and (not (eq (char-after) ?\)))
23f87bed
MB		 2579 (setq start (progn
2580 (imap-forward)
2581 ;; next line for Courier IMAP bug.
2582 (skip-chars-forward " ")
2583 (point)))
01c52d31 2584 (> (skip-chars-forward "^ )" (point-at-eol)) 0))
a2617484 2585 (push (buffer-substring start (point)) flag-list))
e62e7654 2586 (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
a2617484
DL		 2587 (imap-forward)
2588 (nreverse flag-list)))
c113de23
GM		 2589
2590;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP
2591;; env-reply-to SP env-to SP env-cc SP env-bcc SP
2592;; env-in-reply-to SP env-message-id ")"
2593;;
2594;; env-bcc = "(" 1*address ")" / nil
2595;;
2596;; env-cc = "(" 1*address ")" / nil
2597;;
2598;; env-date = nstring
2599;;
2600;; env-from = "(" 1*address ")" / nil
2601;;
2602;; env-in-reply-to = nstring
2603;;
2604;; env-message-id = nstring
2605;;
2606;; env-reply-to = "(" 1*address ")" / nil
2607;;
2608;; env-sender = "(" 1*address ")" / nil
2609;;
2610;; env-subject = nstring
2611;;
2612;; env-to = "(" 1*address ")" / nil
2613
2614(defun imap-parse-envelope ()
2615 (when (eq (char-after) ?\()
2616 (imap-forward)
23f87bed 2617 (vector (prog1 (imap-parse-nstring) ;; date
c113de23 2618 (imap-forward))
23f87bed 2619 (prog1 (imap-parse-nstring) ;; subject
c113de23 2620 (imap-forward))
23f87bed 2621 (prog1 (imap-parse-address-list) ;; from
c113de23 2622 (imap-forward))
23f87bed 2623 (prog1 (imap-parse-address-list) ;; sender
c113de23 2624 (imap-forward))
23f87bed 2625 (prog1 (imap-parse-address-list) ;; reply-to
c113de23 2626 (imap-forward))
23f87bed 2627 (prog1 (imap-parse-address-list) ;; to
c113de23 2628 (imap-forward))
23f87bed 2629 (prog1 (imap-parse-address-list) ;; cc
c113de23 2630 (imap-forward))
23f87bed 2631 (prog1 (imap-parse-address-list) ;; bcc
c113de23 2632 (imap-forward))
23f87bed 2633 (prog1 (imap-parse-nstring) ;; in-reply-to
c113de23 2634 (imap-forward))
23f87bed 2635 (prog1 (imap-parse-nstring) ;; message-id
c113de23
GM		 2636 (imap-forward)))))
2637
2638;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2639
2640(defsubst imap-parse-string-list ()
23f87bed 2641 (cond ((eq (char-after) ?\() ;; body-fld-param
c113de23
GM		 2642 (let (strlist str)
2643 (imap-forward)
2644 (while (setq str (imap-parse-string))
2645 (push str strlist)
2646 ;; buggy stalker communigate pro 3.0 doesn't print SPC
2647 ;; between body-fld-param's sometimes
2648 (or (eq (char-after) ?\")
2649 (imap-forward)))
2650 (nreverse strlist)))
2651 ((imap-parse-nil)
2652 nil)))
2653
2654;; body-extension = nstring / number /
2655;; "(" body-extension *(SP body-extension) ")"
2656;; ; Future expansion. Client implementations
2657;; ; MUST accept body-extension fields. Server
2658;; ; implementations MUST NOT generate
2659;; ; body-extension fields except as defined by
2660;; ; future standard or standards-track
2661;; ; revisions of this specification.
2662
2663(defun imap-parse-body-extension ()
2664 (if (eq (char-after) ?\()
2665 (let (b-e)
2666 (imap-forward)
2667 (push (imap-parse-body-extension) b-e)
2668 (while (eq (char-after) ?\ )
2669 (imap-forward)
2670 (push (imap-parse-body-extension) b-e))
e62e7654 2671 (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
c113de23
GM		 2672 (imap-forward)
2673 (nreverse b-e))
2674 (or (imap-parse-number)
2675 (imap-parse-nstring))))
2676
2677;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2678;; *(SP body-extension)]]
2679;; ; MUST NOT be returned on non-extensible
2680;; ; "BODY" fetch
2681;;
2682;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2683;; *(SP body-extension)]]
2684;; ; MUST NOT be returned on non-extensible
2685;; ; "BODY" fetch
2686
2687(defsubst imap-parse-body-ext ()
2688 (let (ext)
23f87bed 2689 (when (eq (char-after) ?\ ) ;; body-fld-dsp
c113de23
GM		 2690 (imap-forward)
2691 (let (dsp)
2692 (if (eq (char-after) ?\()
2693 (progn
2694 (imap-forward)
2695 (push (imap-parse-string) dsp)
2696 (imap-forward)
2697 (push (imap-parse-string-list) dsp)
2698 (imap-forward))
23f87bed
MB		 2699 ;; With assert, the code might not be eval'd.
2700 ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
28d38c0b 2701 (imap-parse-nil))
c113de23 2702 (push (nreverse dsp) ext))
23f87bed 2703 (when (eq (char-after) ?\ ) ;; body-fld-lang
c113de23
GM		 2704 (imap-forward)
2705 (if (eq (char-after) ?\()
2706 (push (imap-parse-string-list) ext)
2707 (push (imap-parse-nstring) ext))
23f87bed 2708 (while (eq (char-after) ?\ ) ;; body-extension
c113de23
GM		 2709 (imap-forward)
2710 (setq ext (append (imap-parse-body-extension) ext)))))
2711 ext))
2712
2713;; body = "(" body-type-1part / body-type-mpart ")"
2714;;
2715;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2716;; *(SP body-extension)]]
2717;; ; MUST NOT be returned on non-extensible
2718;; ; "BODY" fetch
2719;;
2720;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2721;; *(SP body-extension)]]
2722;; ; MUST NOT be returned on non-extensible
2723;; ; "BODY" fetch
2724;;
2725;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP
2726;; body-fld-enc SP body-fld-octets
2727;;
2728;; body-fld-desc = nstring
2729;;
2730;; body-fld-dsp = "(" string SP body-fld-param ")" / nil
2731;;
2732;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2733;; "QUOTED-PRINTABLE") DQUOTE) / string
2734;;
2735;; body-fld-id = nstring
2736;;
2737;; body-fld-lang = nstring / "(" string *(SP string) ")"
2738;;
2739;; body-fld-lines = number
2740;;
2741;; body-fld-md5 = nstring
2742;;
2743;; body-fld-octets = number
2744;;
2745;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2746;;
2747;; body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2748;; [SP body-ext-1part]
2749;;
2750;; body-type-basic = media-basic SP body-fields
2751;; ; MESSAGE subtype MUST NOT be "RFC822"
2752;;
2753;; body-type-msg = media-message SP body-fields SP envelope
2754;; SP body SP body-fld-lines
2755;;
2756;; body-type-text = media-text SP body-fields SP body-fld-lines
2757;;
2758;; body-type-mpart = 1*body SP media-subtype
2759;; [SP body-ext-mpart]
2760;;
2761;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2762;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2763;; ; Defined in [MIME-IMT]
2764;;
2765;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2766;; ; Defined in [MIME-IMT]
2767;;
2768;; media-subtype = string
2769;; ; Defined in [MIME-IMT]
2770;;
2771;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype
2772;; ; Defined in [MIME-IMT]
2773
2774(defun imap-parse-body ()
2775 (let (body)
2776 (when (eq (char-after) ?\()
2777 (imap-forward)
2778 (if (eq (char-after) ?\()
2779 (let (subbody)
2780 (while (and (eq (char-after) ?\()
2781 (setq subbody (imap-parse-body)))
23f87bed 2782 ;; buggy stalker communigate pro 3.0 insert a SPC between
c113de23
GM		 2783 ;; parts in multiparts
2784 (when (and (eq (char-after) ?\ )
2785 (eq (char-after (1+ (point))) ?\())
2786 (imap-forward))
2787 (push subbody body))
2788 (imap-forward)
23f87bed
MB		 2789 (push (imap-parse-string) body) ;; media-subtype
2790 (when (eq (char-after) ?\ ) ;; body-ext-mpart:
c113de23 2791 (imap-forward)
23f87bed 2792 (if (eq (char-after) ?\() ;; body-fld-param
c113de23
GM		 2793 (push (imap-parse-string-list) body)
2794 (push (and (imap-parse-nil) nil) body))
2795 (setq body
23f87bed 2796 (append (imap-parse-body-ext) body))) ;; body-ext-...
e62e7654 2797 (assert (eq (char-after) ?\)) nil "In imap-parse-body")
c113de23
GM		 2798 (imap-forward)
2799 (nreverse body))
2800
23f87bed 2801 (push (imap-parse-string) body) ;; media-type
c113de23 2802 (imap-forward)
23f87bed 2803 (push (imap-parse-string) body) ;; media-subtype
c113de23
GM		 2804 (imap-forward)
2805 ;; next line for Sun SIMS bug
2806 (and (eq (char-after) ? ) (imap-forward))
23f87bed 2807 (if (eq (char-after) ?\() ;; body-fld-param
c113de23
GM		 2808 (push (imap-parse-string-list) body)
2809 (push (and (imap-parse-nil) nil) body))
2810 (imap-forward)
23f87bed 2811 (push (imap-parse-nstring) body) ;; body-fld-id
c113de23 2812 (imap-forward)
23f87bed 2813 (push (imap-parse-nstring) body) ;; body-fld-desc
c113de23 2814 (imap-forward)
a2617484 2815 ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
0ff9b955 2816 ;; nstring and return nil instead of defaulting back to 7BIT
a2617484 2817 ;; as the standard says.
23f87bed 2818 (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
c113de23 2819 (imap-forward)
23f87bed 2820 (push (imap-parse-number) body) ;; body-fld-octets
c113de23 2821
23f87bed 2822 ;; ok, we're done parsing the required parts, what comes now is one
c113de23
GM		 2823 ;; of three things:
2824 ;;
2825 ;; envelope (then we're parsing body-type-msg)
2826 ;; body-fld-lines (then we're parsing body-type-text)
2827 ;; body-ext-1part (then we're parsing body-type-basic)
2828 ;;
23f87bed
MB		 2829 ;; the problem is that the two first are in turn optionally followed
2830;; by the third. So we parse the first two here (if there are any)...
c113de23
GM		 2831
2832 (when (eq (char-after) ?\ )
2833 (imap-forward)
2834 (let (lines)
23f87bed
MB		 2835 (cond ((eq (char-after) ?\() ;; body-type-msg:
2836 (push (imap-parse-envelope) body) ;; envelope
c113de23 2837 (imap-forward)
23f87bed 2838 (push (imap-parse-body) body) ;; body
c113de23
GM		 2839 ;; buggy stalker communigate pro 3.0 doesn't print
2840 ;; number of lines in message/rfc822 attachment
2841 (if (eq (char-after) ?\))
2842 (push 0 body)
2843 (imap-forward)
2844 (push (imap-parse-number) body))) ;; body-fld-lines
23f87bed
MB		 2845 ((setq lines (imap-parse-number)) ;; body-type-text:
2846 (push lines body)) ;; body-fld-lines
c113de23 2847 (t
23f87bed 2848 (backward-char))))) ;; no match...
c113de23
GM		 2849
2850 ;; ...and then parse the third one here...
2851
23f87bed 2852 (when (eq (char-after) ?\ ) ;; body-ext-1part:
c113de23 2853 (imap-forward)
23f87bed
MB		 2854 (push (imap-parse-nstring) body) ;; body-fld-md5
2855 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
738421d1 2856
e62e7654 2857 (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
c113de23
GM		 2858 (imap-forward)
2859 (nreverse body)))))
2860
2861(when imap-debug ; (untrace-all)
2862 (require 'trace)
23f87bed 2863 (buffer-disable-undo (get-buffer-create imap-debug-buffer))
01c52d31
MB		 2864 (mapc (lambda (f) (trace-function-background f imap-debug-buffer))
2865 '(
2866 imap-utf7-encode
2867 imap-utf7-decode
2868 imap-error-text
2869 imap-kerberos4s-p
2870 imap-kerberos4-open
2871 imap-ssl-p
2872 imap-ssl-open
2873 imap-network-p
2874 imap-network-open
2875 imap-interactive-login
2876 imap-kerberos4a-p
2877 imap-kerberos4-auth
2878 imap-cram-md5-p
2879 imap-cram-md5-auth
2880 imap-login-p
2881 imap-login-auth
2882 imap-anonymous-p
2883 imap-anonymous-auth
2884 imap-open-1
2885 imap-open
2886 imap-opened
2887 imap-authenticate
2888 imap-close
2889 imap-capability
2890 imap-namespace
2891 imap-send-command-wait
2892 imap-mailbox-put
2893 imap-mailbox-get
2894 imap-mailbox-map-1
2895 imap-mailbox-map
2896 imap-current-mailbox
2897 imap-current-mailbox-p-1
2898 imap-current-mailbox-p
2899 imap-mailbox-select-1
2900 imap-mailbox-select
2901 imap-mailbox-examine-1
2902 imap-mailbox-examine
2903 imap-mailbox-unselect
2904 imap-mailbox-expunge
2905 imap-mailbox-close
2906 imap-mailbox-create-1
2907 imap-mailbox-create
2908 imap-mailbox-delete
2909 imap-mailbox-rename
2910 imap-mailbox-lsub
2911 imap-mailbox-list
2912 imap-mailbox-subscribe
2913 imap-mailbox-unsubscribe
2914 imap-mailbox-status
2915 imap-mailbox-acl-get
2916 imap-mailbox-acl-set
2917 imap-mailbox-acl-delete
2918 imap-current-message
2919 imap-list-to-message-set
2920 imap-fetch-asynch
2921 imap-fetch
2922 imap-message-put
2923 imap-message-get
2924 imap-message-map
2925 imap-search
2926 imap-message-flag-permanent-p
2927 imap-message-flags-set
2928 imap-message-flags-del
2929 imap-message-flags-add
2930 imap-message-copyuid-1
2931 imap-message-copyuid
2932 imap-message-copy
2933 imap-message-appenduid-1
2934 imap-message-appenduid
2935 imap-message-append
2936 imap-body-lines
2937 imap-envelope-from
2938 imap-send-command-1
2939 imap-send-command
2940 imap-wait-for-tag
2941 imap-sentinel
2942 imap-find-next-line
2943 imap-arrival-filter
2944 imap-parse-greeting
2945 imap-parse-response
2946 imap-parse-resp-text
2947 imap-parse-resp-text-code
2948 imap-parse-data-list
2949 imap-parse-fetch
2950 imap-parse-status
2951 imap-parse-acl
2952 imap-parse-flag-list
2953 imap-parse-envelope
2954 imap-parse-body-extension
2955 imap-parse-body
2956 )))
738421d1 2957
c113de23
GM		 2958(provide 'imap)
2959
ab5796a9 2960;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
c113de23 2961;;; imap.el ends here
Unnamed repository; edit this file 'description' to name the repository.