HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
New directory
[bpt/emacs.git] / lisp / gnus / imap.el
CommitLineData
c113de23 1;;; imap.el --- imap library
f9936da6 2;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
c113de23
GM		 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;;
738421d1 47;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
c113de23
GM		 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
738421d1 60;; imap-message-envelope-date, imap-message-envelope-subject,
c113de23
GM		 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
a2617484
DL		 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.
c113de23
GM		 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:
738421d1 123;;
c113de23
GM		 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
c113de23
GM		 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")
2d5fdf63
DL		 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)))))
c113de23
GM		 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
176IMAP commands on stdin and return responses to stdout. Each entry in
177the 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
185IMAP commands on stdin and return responses to stdout. Each entry in
186the list is tried until a successful connection is made."
187 :group 'imap
188 :type '(repeat string))
189
f9936da6
SZ		 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")
c113de23
GM		 194 "A string, or list of strings, containing commands for SSL connections.
195Within a string, %s is replaced with the server address and %p with
196port number on server. The program should accept IMAP commands on
197stdin and return responses to stdout. Each entry in the list is tried
198until 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.
208Within a string, %s is replaced with the server address, %p with port
209number on server, %g with `imap-shell-host', and %l with
210`imap-default-user'. The program should read IMAP commands from stdin
211and write IMAP response to stdout. Each entry in the list is tried
212until 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
72e97196 242\(NAME CHECK OPEN)
c113de23
GM		 243
244NAME names the stream, CHECK is a function returning non-nil if the
72e97196 245server supports the stream and OPEN is a function for opening the
c113de23
GM		 246stream.")
247
738421d1 248(defvar imap-authenticators '(gssapi
c113de23
GM		 249 kerberos4
250 digest-md5
251 cram-md5
252 login
253 anonymous)
254 "Priority of authenticators to consider when authenticating to server.")
255
738421d1 256(defvar imap-authenticator-alist
c113de23
GM		 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
72e97196 265\(NAME CHECK AUTHENTICATE)
c113de23
GM		 266
267NAME names the authenticator. CHECK is a function returning non-nil if
268the server support the authenticator and AUTHENTICATE is a function
72e97196 269for doing the actual authentication.")
c113de23
GM		 270
271(defvar imap-use-utf7 t
272 "If non-nil, do utf7 encoding/decoding of mailbox names.
273Since the UTF7 decoding currently only decodes into ISO-8859-1
274characters, you may disable this decoding if you need to access UTF7
275encoded 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)
738421d1 314(defvar imap-state 'closed
c113de23
GM		 315 "IMAP state.
316Valid states are `closed', `initial', `nonauth', `auth', `selected'
317and `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
738421d1 355(defvar imap-failed-tags nil
c113de23
GM		 356 "Alist of tags that failed.
357Each element is a list with four elements; tag (a integer), response
358state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
359human 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.
72e97196 369The actual value is really the text on the continuation line.")
c113de23
GM		 370
371(defvar imap-log nil
372 "Name of buffer for imap session trace.
373For example: (setq imap-log \"*imap-log*\")")
374
375(defvar imap-debug nil ;"*imap-debug*"
376 "Name of buffer for random debug spew.
377For 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.
389If 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)
738421d1 408 (error (message
c113de23
GM		 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)
738421d1 450 (process (start-process
c113de23
GM		 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)
a2617484
DL		 490 (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
491 (if response (concat "done, " response) "failed"))
c113de23
GM		 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))
738421d1 500
c113de23
GM		 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)
738421d1 512 (process (start-process
c113de23
GM		 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)
f9936da6 571 (process-connection-type nil)
c113de23 572 process)
f9936da6
SZ		 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)
c113de23
GM		 583 (with-current-buffer buffer
584 (goto-char (point-min))
585 (while (and (memq (process-status process) '(open run))
f9936da6 586 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
c113de23
GM		 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)
a2617484 605 (message "imap: Opening SSL connection with `%s'...failed" cmd)
c113de23
GM		 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)
738421d1 643 (process (start-process
c113de23
GM		 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)
a2617484 671 (message "imap: Opening IMAP connection with `%s'...failed" cmd)
c113de23
GM		 672 nil)))
673
674(defun imap-starttls-p (buffer)
a2617484
DL		 675 (and (imap-capability 'STARTTLS buffer)
676 (condition-case ()
677 (progn
678 (require 'starttls)
679 (call-process "starttls"))
680 (error nil))))
c113de23
GM		 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)
a2617484
DL		 686 (process (starttls-open-stream name buffer server port))
687 done)
688 (message "imap: Connecting with STARTTLS...")
c113de23
GM		 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))
a2617484
DL		 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)))
738421d1 716
c113de23
GM		 717;; Server functions; authenticator stuff:
718
719(defun imap-interactive-login (buffer loginfunc)
720 "Login to server in BUFFER.
721LOGINFUNC is passed a username and a password, it should return t if
8f688cb0 722it where successful authenticating itself to the server, nil otherwise.
c113de23
GM		 723Returns t if login was successful, nil otherwise."
724 (with-current-buffer buffer
f78cebe3
SM		 725 (make-local-variable 'imap-username)
726 (make-local-variable 'imap-password)
c113de23
GM		 727 (let (user passwd ret)
728 ;; (condition-case ()
729 (while (or (not user) (not passwd))
730 (setq user (or imap-username
738421d1 731 (read-from-minibuffer
c113de23
GM		 732 (concat "IMAP username for " imap-server ": ")
733 (or user imap-default-user))))
734 (setq passwd (or imap-password
735 (imap-read-passwd
738421d1 736 (concat "IMAP password for " user "@"
c113de23
GM		 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)
a2617484
DL		 761 (message "imap: Authenticating using GSSAPI...%s"
762 (if (eq imap-stream 'gssapi) "done" "failed"))
c113de23
GM		 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)
a2617484
DL		 769 (message "imap: Authenticating using Kerberos 4...%s"
770 (if (eq imap-stream 'kerberos4) "done" "failed"))
c113de23
GM		 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."
a2617484
DL		 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"))))
738421d1
SS		 795
796
c113de23
GM		 797
798(defun imap-login-p (buffer)
a2617484
DL		 799 (and (not (imap-capability 'LOGINDISABLED buffer))
800 (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
c113de23
GM		 801
802(defun imap-login-auth (buffer)
803 "Login to server using the LOGIN command."
a2617484 804 (message "imap: Plaintext authentication...")
738421d1 805 (imap-interactive-login buffer
c113de23 806 (lambda (user passwd)
738421d1
SS		 807 (imap-ok-p (imap-send-command-wait
808 (concat "LOGIN \"" user "\" \""
c113de23
GM		 809 passwd "\""))))))
810
811(defun imap-anonymous-p (buffer)
812 t)
813
814(defun imap-anonymous-auth (buffer)
8f688cb0 815 (message "imap: Logging in anonymously...")
c113de23
GM		 816 (with-current-buffer buffer
817 (imap-ok-p (imap-send-command-wait
738421d1 818 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
c113de23
GM		 819 (system-name)) "\"")))))
820
821(defun imap-digest-md5-p (buffer)
a2617484
DL		 822 (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
823 (condition-case ()
c113de23 824 (require 'digest-md5)
a2617484 825 (error nil))))
c113de23
GM		 826
827(defun imap-digest-md5-auth (buffer)
828 "Login to server using the AUTH DIGEST-MD5 method."
a2617484 829 (message "imap: Authenticating using DIGEST-MD5...")
c113de23
GM		 830 (imap-interactive-login
831 buffer
832 (lambda (user passwd)
738421d1 833 (let ((tag
c113de23
GM		 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
738421d1 841 (digest-md5-digest-uri
c113de23
GM		 842 "imap" (digest-md5-challenge 'realm)))
843 (response
738421d1 844 (digest-md5-digest-response
c113de23
GM		 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 ()
738421d1 863 (funcall (nth 2 (assq imap-stream
c113de23
GM		 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.
880If PORT is unspecified, a default value is used (143 except
881for SSL which use 993).
882STREAM indicates the stream to use, see `imap-streams' for available
883streams. If nil, it choices the best stream the server is capable of.
884AUTH indicates authenticator to use, see `imap-authenticators' for
885available authenticators. If nil, it choices the best stream the
886server is capable of.
887BUFFER can be a buffer or a name of a buffer, which is created if
8f688cb0 888necessary. If nil, the buffer name is generated."
c113de23
GM		 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))
f78cebe3 893 (mapcar 'make-local-variable imap-local-variables)
c113de23
GM		 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))
a2617484
DL		 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)
738421d1 910 (setq stream-changed (not (eq (or imap-stream
a2617484
DL		 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)
738421d1 923 (message "imap: Reconnecting with stream `%s'...failed"
a2617484
DL		 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))
738421d1 931 (if (funcall (nth 1 (assq auth imap-authenticator-alist))
a2617484
DL		 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))
c113de23
GM		 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.
944If 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.
953It uses the authenticator specified when opening the server. If the
954authenticator requires username/passwords, they are queried from the
955user and optionally stored in the buffer. If USER and/or PASSWD is
956specified, the user will not be questioned and the username and/or
957password 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))
f78cebe3
SM		 963 (make-local-variable 'imap-username)
964 (make-local-variable 'imap-password)
c113de23
GM		 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.
972If 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.
988If IDENTIFIER, return non-nil if it's among the servers capabilities.
989If 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.
1000If 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)
738421d1 1034 (mapatoms
c113de23
GM		 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.
1044Function should take a mailbox name (a string) as
1045the 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.
1065If 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
738421d1 1070 (concat (if examine "EXAMINE" "SELECT") " \""
c113de23
GM		 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
738421d1 1079(defun imap-mailbox-select (mailbox &optional examine buffer)
c113de23 1080 (with-current-buffer (or buffer (current-buffer))
738421d1 1081 (imap-utf7-decode
c113de23
GM		 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))
738421d1 1086 (imap-mailbox-select-1 mailbox 'examine)))
c113de23
GM		 1087
1088(defun imap-mailbox-examine (mailbox &optional buffer)
1089 "Examine MAILBOX on server in BUFFER."
738421d1 1090 (imap-mailbox-select mailbox 'examine buffer))
c113de23
GM		 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")))
738421d1 1098 (and (imap-ok-p
c113de23
GM		 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.
1110If 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.
1117If 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.
1131If 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.
1137If 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.
1145If 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
738421d1 1153(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
c113de23
GM		 1154 "Return a list of subscribed mailboxes on server in BUFFER.
1155If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
1156non-nil, a hierarchy delimiter is added to root. REFERENCE is a
1157implementation-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
738421d1 1167 (imap-send-command-wait
c113de23
GM		 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.
1179If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1180root. REFERENCE is a implementation-specific string that has to be
1181passed 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
738421d1 1191 (imap-send-command-wait
c113de23
GM		 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.
1203Returns non-nil if successful."
1204 (with-current-buffer (or buffer (current-buffer))
738421d1 1205 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
c113de23
GM		 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.
1211Returns non-nil if successful."
1212 (with-current-buffer (or buffer (current-buffer))
738421d1 1213 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
c113de23
GM		 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.
1219ITEMS can be a symbol or a list of symbols, valid symbols are one of
1220the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1221or 'unseen. If ITEMS is a list of symbols, a list of values is
4f014d55 1222returned, if ITEMS is a symbol only its value is returned."
c113de23 1223 (with-current-buffer (or buffer (current-buffer))
738421d1 1224 (when (imap-ok-p
c113de23
GM		 1225 (imap-send-command-wait (list "STATUS \""
1226 (imap-utf7-encode mailbox)
1227 "\" "
1228 (format "%s"
1229 (if (listp items)
738421d1 1230 items
c113de23
GM		 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.
1307UIDS can be a string, number or a list of numbers. If RECEIVE
1308is non-nil return theese properties."
1309 (with-current-buffer (or buffer (current-buffer))
738421d1 1310 (when (imap-ok-p (imap-send-command-wait
c113de23
GM		 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))))))
738421d1 1327
c113de23
GM		 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
1455BUFFER, creating mailbox if it doesn't exist. If dont-create is
1456non-nil, it will not create a mailbox. On success, return a list with
1457the UIDVALIDITY of the mailbox the article(s) was copied to as the
1458first 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)))))))
738421d1 1472
c113de23
GM		 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.
1495FLAGS and DATE-TIME is currently not used. Return a cons holding
1496uidvalidity of MAILBOX and UID the newly created article got, or nil
1497on failure."
1498 (let ((mailbox (imap-utf7-encode mailbox)))
1499 (with-current-buffer (or buffer (current-buffer))
1500 (and (let ((imap-current-target-mailbox mailbox))
738421d1
SS		 1501 (imap-ok-p
1502 (imap-send-command-wait
c113de23
GM		 1503 (list "APPEND \"" mailbox "\" " article))))
1504 (imap-message-appenduid-1 mailbox)))))
738421d1 1505
c113de23
GM		 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) " <")
738421d1
SS		 1525 (aref from 2)
1526 "@"
c113de23
GM		 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))))
738421d1 1566 (setq cmdstr
c113de23
GM		 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.
1621Return 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
738421d1 1659 (message "Unknown state %s in arrival filter"
c113de23
GM		 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)
738421d1 1746 (buffer-substring (point)
c113de23
GM		 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
0ff9b955 1757;; ; non-nil
c113de23
GM		 1758;;
1759;; addr-host = nstring
0ff9b955 1760;; ; nil indicates [RFC-822] group syntax.
c113de23
GM		 1761;; ; Otherwise, holds [RFC-822] domain name
1762;;
1763;; addr-mailbox = nstring
0ff9b955
PJ		 1764;; ; nil indicates end of [RFC-822] group; if
1765;; ; non-nil and addr-host is nil, holds
c113de23
GM		 1766;; ; [RFC-822] group name.
1767;; ; Otherwise, holds [RFC-822] local-part
1768;; ; after removing [RFC-822] quoting
1769;;
1770;; addr-name = nstring
0ff9b955 1771;; ; If non-nil, holds phrase from [RFC-822]
c113de23
GM		 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))
738421d1
SS		 1892 (SEARCH (imap-mailbox-put
1893 'search
c113de23
GM		 1894 (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
1895 (STATUS (imap-parse-status))
738421d1 1896 (CAPABILITY (setq imap-capability
c113de23
GM		 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)))
738421d1 1926 (push (list token status code text)
c113de23
GM		 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) ")" ] /
738421d1 1954;; "NEWNAME" SP string SP string /
c113de23 1955;; "PARSE" /
738421d1 1956;; "PERMANENTFLAGS" SP "("
c113de23 1957;; [flag-perm *(SP flag-perm)] ")" /
738421d1
SS		 1958;; "READ-ONLY" /
1959;; "READ-WRITE" /
c113de23 1960;; "TRYCREATE" /
738421d1 1961;; "UIDNEXT" SP nz-number /
c113de23
GM		 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.
738421d1 1980;;
c113de23
GM		 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) ")"
738421d1 2078;;
c113de23
GM		 2079;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
2080;; SPACE time SPACE zone <">
738421d1 2081;;
c113de23
GM		 2082;; section ::= "[" [section_text / (nz_number *["." nz_number]
2083;; ["." (section_text / "MIME")])] "]"
738421d1 2084;;
c113de23
GM		 2085;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2086;; SPACE header_list / "TEXT"
738421d1 2087;;
c113de23 2088;; header_fld_name ::= astring
738421d1 2089;;
c113de23
GM		 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 ()
738421d1 2102 (let ((section
c113de23
GM		 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) ?\()
738421d1 2112 (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
c113de23
GM		 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 "("
738421d1 2164;; [status-att SP number
c113de23
GM		 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
738421d1 2189 (message "Unknown status data %s in mailbox %s ignored"
c113de23
GM		 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)
a2617484
DL		 2228 (assert (eq (char-after) ?\())
2229 (while (and (not (eq (char-after) ?\)))
2230 (setq start (progn (imap-forward) (point)))
2d5fdf63 2231 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
a2617484
DL		 2232 (push (buffer-substring start (point)) flag-list))
2233 (assert (eq (char-after) ?\)))
2234 (imap-forward)
2235 (nreverse flag-list)))
c113de23
GM		 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)
a2617484 2460 ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
0ff9b955 2461 ;; nstring and return nil instead of defaulting back to 7BIT
a2617484
DL		 2462 ;; as the standard says.
2463 (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc
c113de23
GM		 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..
738421d1 2501
c113de23
GM		 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))
738421d1 2509 (mapcar (lambda (f) (trace-function-background f imap-debug))
c113de23
GM		 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 )))
738421d1 2603
c113de23
GM		 2604(provide 'imap)
2605
2606;;; imap.el ends here
Unnamed repository; edit this file 'description' to name the repository.