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