1 ;;; imap.el --- imap library
2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
3 ;; Free Software Foundation, Inc.
5 ;; Author: Simon Josefsson <jas@pdc.kth.se>
8 ;; This file is part of GNU Emacs.
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)
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.
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.
27 ;; imap.el is a elisp library providing an interface for talking to
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.
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.
42 ;; imap-open, imap-opened, imap-authenticate, imap-close,
43 ;; imap-capability, imap-namespace, imap-error-text
47 ;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
48 ;; imap-current-mailbox-p, imap-search, imap-mailbox-select,
49 ;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge
50 ;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete
51 ;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list
52 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
53 ;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete
57 ;; imap-fetch-asynch, imap-fetch,
58 ;; imap-current-message, imap-list-to-message-set,
59 ;; imap-message-get, imap-message-map
60 ;; imap-message-envelope-date, imap-message-envelope-subject,
61 ;; imap-message-envelope-from, imap-message-envelope-sender,
62 ;; imap-message-envelope-reply-to, imap-message-envelope-to,
63 ;; imap-message-envelope-cc, imap-message-envelope-bcc
64 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
65 ;; imap-message-body, imap-message-flag-permanent-p
66 ;; imap-message-flags-set, imap-message-flags-del
67 ;; imap-message-flags-add, imap-message-copyuid
68 ;; imap-message-copy, imap-message-appenduid
69 ;; imap-message-append, imap-envelope-from
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.
76 ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
77 ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
78 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
79 ;; LOGINDISABLED) (with use of external library starttls.el and
80 ;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
81 ;; (with use of external program `imtest'). It also take advantage
82 ;; the UNSELECT extension in Cyrus IMAPD.
84 ;; Without the work of John McClary Prevost and Jim Radford this library
85 ;; would not have seen the light of day. Many thanks.
87 ;; This is a transcript of short interactive session for demonstration
90 ;; (imap-open "my.mail.server")
91 ;; => " *imap* my.mail.server:0"
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.
98 ;; (imap-authenticate "myusername" "mypassword")
101 ;; (imap-mailbox-lsub "*")
102 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
104 ;; (imap-mailbox-list "INBOX.n%")
105 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
107 ;; (imap-mailbox-select "INBOX.nnimap")
110 ;; (imap-mailbox-get 'exists)
113 ;; (imap-mailbox-get 'uidvalidity)
116 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
119 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
120 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
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.
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
139 (eval-when-compile (require 'cl
))
141 (autoload 'base64-decode-string
"base64")
142 (autoload 'base64-encode-string
"base64")
143 (autoload 'starttls-open-stream
"starttls")
144 (autoload 'starttls-negotiate
"starttls")
145 (autoload 'digest-md5-parse-digest-challenge
"digest-md5")
146 (autoload 'digest-md5-digest-response
"digest-md5")
147 (autoload 'digest-md5-digest-uri
"digest-md5")
148 (autoload 'digest-md5-challenge
"digest-md5")
149 (autoload 'rfc2104-hash
"rfc2104")
150 (autoload 'md5
"md5")
151 (autoload 'utf7-encode
"utf7")
152 (autoload 'utf7-decode
"utf7")
153 (autoload 'format-spec
"format-spec")
154 (autoload 'format-spec-make
"format-spec")
155 ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These
156 ;; days we have point-at-eol anyhow.
157 (if (fboundp 'point-at-eol
)
158 (defalias 'imap-point-at-eol
'point-at-eol
)
159 (defun imap-point-at-eol ()
167 "Low-level IMAP issues."
171 (defcustom imap-kerberos4-program
'("imtest -m kerberos_v4 -u %l -p %p %s"
173 "List of strings containing commands for Kerberos 4 authentication.
174 %s is replaced with server hostname, %p with port to connect to, and
175 %l with the value of `imap-default-user'. The program should accept
176 IMAP commands on stdin and return responses to stdout. Each entry in
177 the list is tried until a successful connection is made."
179 :type
'(repeat string
))
181 (defcustom imap-gssapi-program
'("imtest -m gssapi -u %l -p %p %s")
182 "List of strings containing commands for GSSAPI (krb5) authentication.
183 %s is replaced with server hostname, %p with port to connect to, and
184 %l with the value of `imap-default-user'. The program should accept
185 IMAP commands on stdin and return responses to stdout. Each entry in
186 the list is tried until a successful connection is made."
188 :type
'(repeat string
))
190 (defcustom imap-ssl-program
'("openssl s_client -quiet -ssl3 -connect %s:%p"
191 "openssl s_client -quiet -ssl2 -connect %s:%p"
192 "s_client -quiet -ssl3 -connect %s:%p"
193 "s_client -quiet -ssl2 -connect %s:%p")
194 "A string, or list of strings, containing commands for SSL connections.
195 Within a string, %s is replaced with the server address and %p with
196 port number on server. The program should accept IMAP commands on
197 stdin and return responses to stdout. Each entry in the list is tried
198 until a successful connection is made."
200 :type
'(choice string
203 (defcustom imap-shell-program
'("ssh %s imapd"
205 "ssh %g ssh %s imapd"
206 "rsh %g rsh %s imapd")
207 "A list of strings, containing commands for IMAP connection.
208 Within a string, %s is replaced with the server address, %p with port
209 number on server, %g with `imap-shell-host', and %l with
210 `imap-default-user'. The program should read IMAP commands from stdin
211 and write IMAP response to stdout. Each entry in the list is tried
212 until a successful connection is made."
214 :type
'(repeat string
))
216 (defvar imap-shell-host
"gateway"
217 "Hostname of rlogin proxy.")
219 (defvar imap-default-user
(user-login-name)
220 "Default username to use.")
222 (defvar imap-error nil
223 "Error codes from the last command.")
225 ;; Various variables.
227 (defvar imap-fetch-data-hook nil
228 "Hooks called after receiving each FETCH response.")
230 (defvar imap-streams
'(gssapi kerberos4 starttls ssl network shell
)
231 "Priority of streams to consider when opening connection to server.")
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.
244 NAME names the stream, CHECK is a function returning non-nil if the
245 server supports the stream and OPEN is a function for opening the
248 (defvar imap-authenticators
'(gssapi
254 "Priority of authenticators to consider when authenticating to server.")
256 (defvar imap-authenticator-alist
257 '((gssapi imap-gssapi-auth-p imap-gssapi-auth
)
258 (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth
)
259 (cram-md5 imap-cram-md5-p imap-cram-md5-auth
)
260 (login imap-login-p imap-login-auth
)
261 (anonymous imap-anonymous-p imap-anonymous-auth
)
262 (digest-md5 imap-digest-md5-p imap-digest-md5-auth
))
263 "Definition of authenticators.
265 \(NAME CHECK AUTHENTICATE)
267 NAME names the authenticator. CHECK is a function returning non-nil if
268 the server support the authenticator and AUTHENTICATE is a function
269 for doing the actual authentication.")
271 (defvar imap-use-utf7 t
272 "If non-nil, do utf7 encoding/decoding of mailbox names.
273 Since the UTF7 decoding currently only decodes into ISO-8859-1
274 characters, you may disable this decoding if you need to access UTF7
275 encoded mailboxes which doesn't translate into ISO-8859-1.")
277 ;; Internal constants. Change theese and die.
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
293 imap-current-target-mailbox
302 imap-calculate-literal-size-first
305 ;; Internal variables.
307 (defvar imap-stream nil
)
308 (defvar imap-auth nil
)
309 (defvar imap-server nil
)
310 (defvar imap-port nil
)
311 (defvar imap-username nil
)
312 (defvar imap-password nil
)
313 (defvar imap-calculate-literal-size-first nil
)
314 (defvar imap-state
'closed
316 Valid states are `closed', `initial', `nonauth', `auth', `selected'
319 (defvar imap-server-eol
"\r\n"
320 "The EOL string sent from the server.")
322 (defvar imap-client-eol
"\r\n"
323 "The EOL string we send to the server.")
325 (defvar imap-current-mailbox nil
326 "Current mailbox name.")
328 (defvar imap-current-target-mailbox nil
329 "Current target mailbox for COPY and APPEND commands.")
331 (defvar imap-mailbox-data nil
332 "Obarray with mailbox data.")
334 (defvar imap-mailbox-prime
997
335 "Length of imap-mailbox-data.")
337 (defvar imap-current-message nil
338 "Current message number.")
340 (defvar imap-message-data nil
341 "Obarray with message data.")
343 (defvar imap-message-prime
997
344 "Length of imap-message-data.")
346 (defvar imap-capability nil
347 "Capability for server.")
349 (defvar imap-namespace nil
350 "Namespace for current server.")
352 (defvar imap-reached-tag
0
353 "Lower limit on command tags that have been parsed.")
355 (defvar imap-failed-tags nil
356 "Alist of tags that failed.
357 Each element is a list with four elements; tag (a integer), response
358 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
359 human readable response text (a string).")
362 "Command tag number.")
364 (defvar imap-process nil
367 (defvar imap-continuation nil
368 "Non-nil indicates that the server emitted a continuation request.
369 The actual value is really the text on the continuation line.")
372 "Name of buffer for imap session trace.
373 For example: (setq imap-log \"*imap-log*\")")
375 (defvar imap-debug nil
;"*imap-debug*"
376 "Name of buffer for random debug spew.
377 For example: (setq imap-debug \"*imap-debug*\")")
380 ;; Utility functions:
382 (defsubst imap-disable-multibyte
()
383 "Enable multibyte in the current buffer."
384 (when (fboundp 'set-buffer-multibyte
)
385 (set-buffer-multibyte nil
)))
387 (defun imap-read-passwd (prompt &rest args
)
388 "Read a password using PROMPT.
389 If ARGS, PROMPT is used as an argument to `format'."
390 (let ((prompt (if args
391 (apply 'format prompt args
)
393 (funcall (if (or (fboundp 'read-passwd
)
395 (fboundp 'read-passwd
))
396 (and (load "passwd" t
)
397 (fboundp 'read-passwd
)))
399 (autoload 'ange-ftp-read-passwd
"ange-ftp")
400 'ange-ftp-read-passwd
)
403 (defsubst imap-utf7-encode
(string)
407 (utf7-encode string t
)
409 "imap: Could not UTF7 encode `%s', using it unencoded..."
414 (defsubst imap-utf7-decode
(string)
418 (utf7-decode string t
)
420 "imap: Could not UTF7 decode `%s', using it undecoded..."
425 (defsubst imap-ok-p
(status)
428 (setq imap-error status
)
431 (defun imap-error-text (&optional buffer
)
432 (with-current-buffer (or buffer
(current-buffer))
433 (nth 3 (car imap-failed-tags
))))
436 ;; Server functions; stream stuff:
438 (defun imap-kerberos4-stream-p (buffer)
439 (imap-capability 'AUTH
=KERBEROS_V4 buffer
))
441 (defun imap-kerberos4-open (name buffer server port
)
442 (let ((cmds imap-kerberos4-program
)
444 (while (and (not done
) (setq cmd
(pop cmds
)))
445 (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd
)
447 (let* ((port (or port imap-default-port
))
448 (coding-system-for-read imap-coding-system-for-read
)
449 (coding-system-for-write imap-coding-system-for-write
)
450 (process (start-process
451 name buffer shell-file-name shell-command-switch
456 ?p
(number-to-string port
)
457 ?l imap-default-user
))))
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:")
469 ;; cyrus 1.6 imtest print "S: " before server greeting
470 (or (not (looking-at "S: "))
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:
479 "^\\(Authenticat.*\\)" nil t
))
480 (setq response
(match-string 1)))))
481 (accept-process-output process
1)
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
)))
490 (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
491 (if response
(concat "done, " response
) "failed"))
492 (if (and response
(let ((case-fold-search nil
))
493 (not (string-match "failed" response
))))
495 (if (memq (process-status process
) '(open run
))
496 (imap-send-command-wait "LOGOUT"))
497 (delete-process process
)
501 (defun imap-gssapi-stream-p (buffer)
502 (imap-capability 'AUTH
=GSSAPI buffer
))
504 (defun imap-gssapi-open (name buffer server port
)
505 (let ((cmds imap-gssapi-program
)
507 (while (and (not done
) (setq cmd
(pop cmds
)))
508 (message "Opening GSSAPI IMAP connection with `%s'..." cmd
)
509 (let* ((port (or port imap-default-port
))
510 (coding-system-for-read imap-coding-system-for-read
)
511 (coding-system-for-write imap-coding-system-for-write
)
512 (process (start-process
513 name buffer shell-file-name shell-command-switch
518 ?p
(number-to-string port
)
519 ?l imap-default-user
))))
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:")
530 ;; cyrus 1.6 imtest print "S: " before server greeting
531 (or (not (looking-at "S: "))
534 (not (and (imap-parse-greeting)
535 ;; success in imtest 1.6:
537 "^\\(Authenticat.*\\)" nil t
)
538 (setq response
(match-string 1)))))
539 (accept-process-output process
1)
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
)))
548 (message "GSSAPI IMAP connection: %s" (or response
"failed"))
549 (if (and response
(let ((case-fold-search nil
))
550 (not (string-match "failed" response
))))
552 (if (memq (process-status process
) '(open run
))
553 (imap-send-command-wait "LOGOUT"))
554 (delete-process process
)
558 (defun imap-ssl-p (buffer)
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
)))
566 (while (and (not done
) (setq cmd
(pop cmds
)))
567 (message "imap: Opening SSL connection with `%s'..." cmd
)
568 (let* ((port (or port imap-default-ssl-port
))
569 (coding-system-for-read imap-coding-system-for-read
)
570 (coding-system-for-write imap-coding-system-for-write
)
571 (process-connection-type nil
)
574 (setq process
(start-process
575 name buffer shell-file-name
580 ?p
(number-to-string port
)))))
581 (process-kill-without-query process
)
583 (with-current-buffer buffer
584 (goto-char (point-min))
585 (while (and (memq (process-status process
) '(open run
))
586 (set-buffer buffer
) ;; XXX "blue moon" nntp.el bug
587 (goto-char (point-max))
589 (not (imap-parse-greeting)))
590 (accept-process-output process
1)
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
)))
599 (when (memq (process-status process
) '(open run
))
600 (setq done process
))))))
603 (message "imap: Opening SSL connection with `%s'...done" cmd
)
605 (message "imap: Opening SSL connection with `%s'...failed" cmd
)
608 (defun imap-network-p (buffer)
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
)))
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)
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
))
631 (defun imap-shell-p (buffer)
634 (defun imap-shell-open (name buffer server port
)
635 (let ((cmds imap-shell-program
)
637 (while (and (not done
) (setq cmd
(pop cmds
)))
638 (message "imap: Opening IMAP connection with `%s'..." cmd
)
639 (setq imap-client-eol
"\n")
640 (let* ((port (or port imap-default-port
))
641 (coding-system-for-read imap-coding-system-for-read
)
642 (coding-system-for-write imap-coding-system-for-write
)
643 (process (start-process
644 name buffer shell-file-name shell-command-switch
650 ?p
(number-to-string port
)
651 ?l imap-default-user
)))))
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)
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
)))))
669 (message "imap: Opening IMAP connection with `%s'...done" cmd
)
671 (message "imap: Opening IMAP connection with `%s'...failed" cmd
)
674 (defun imap-starttls-p (buffer)
675 (and (imap-capability 'STARTTLS buffer
)
679 (call-process "starttls"))
682 (defun imap-starttls-open (name buffer server port
)
683 (let* ((port (or port imap-default-port
))
684 (coding-system-for-read imap-coding-system-for-read
)
685 (coding-system-for-write imap-coding-system-for-write
)
686 (process (starttls-open-stream name buffer server port
))
688 (message "imap: Connecting with STARTTLS...")
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)
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
))
703 (set-process-filter imap-process
'imap-arrival-filter
)
704 (when (and (eq imap-stream
'starttls
)
705 (imap-ok-p (imap-send-command-wait "STARTTLS")))
706 (starttls-negotiate imap-process
)))
707 (set-process-filter imap-process nil
)))
708 (when (memq (process-status process
) '(open run
))
709 (setq done process
)))
712 (message "imap: Connecting with STARTTLS...done")
714 (message "imap: Connecting with STARTTLS...failed")
717 ;; Server functions; authenticator stuff:
719 (defun imap-interactive-login (buffer loginfunc
)
720 "Login to server in BUFFER.
721 LOGINFUNC is passed a username and a password, it should return t if
722 it where successful authenticating itself to the server, nil otherwise.
723 Returns t if login was successful, nil otherwise."
724 (with-current-buffer buffer
725 (make-local-variable 'imap-username
)
726 (make-local-variable 'imap-password
)
727 (let (user passwd ret
)
728 ;; (condition-case ()
729 (while (or (not user
) (not passwd
))
730 (setq user
(or imap-username
731 (read-from-minibuffer
732 (concat "IMAP username for " imap-server
": ")
733 (or user imap-default-user
))))
734 (setq passwd
(or imap-password
736 (concat "IMAP password for " user
"@"
738 (when (and user passwd
)
739 (if (funcall loginfunc user passwd
)
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...")
749 ;; (quit (with-current-buffer buffer
752 ;; (error (with-current-buffer buffer
757 (defun imap-gssapi-auth-p (buffer)
758 (imap-capability 'AUTH
=GSSAPI buffer
))
760 (defun imap-gssapi-auth (buffer)
761 (message "imap: Authenticating using GSSAPI...%s"
762 (if (eq imap-stream
'gssapi
) "done" "failed"))
763 (eq imap-stream
'gssapi
))
765 (defun imap-kerberos4-auth-p (buffer)
766 (imap-capability 'AUTH
=KERBEROS_V4 buffer
))
768 (defun imap-kerberos4-auth (buffer)
769 (message "imap: Authenticating using Kerberos 4...%s"
770 (if (eq imap-stream
'kerberos4
) "done" "failed"))
771 (eq imap-stream
'kerberos4
))
773 (defun imap-cram-md5-p (buffer)
774 (imap-capability 'AUTH
=CRAM-MD5 buffer
))
776 (defun imap-cram-md5-auth (buffer)
777 "Login to server using the AUTH CRAM-MD5 method."
778 (message "imap: Authenticating using CRAM-MD5...")
779 (let ((done (imap-interactive-login
781 (lambda (user passwd
)
783 (imap-send-command-wait
785 "AUTHENTICATE CRAM-MD5"
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
)))
793 (message "imap: Authenticating using CRAM-MD5...done")
794 (message "imap: Authenticating using CRAM-MD5...failed"))))
798 (defun imap-login-p (buffer)
799 (and (not (imap-capability 'LOGINDISABLED buffer
))
800 (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer
))))
802 (defun imap-login-auth (buffer)
803 "Login to server using the LOGIN command."
804 (message "imap: Plaintext authentication...")
805 (imap-interactive-login buffer
806 (lambda (user passwd
)
807 (imap-ok-p (imap-send-command-wait
808 (concat "LOGIN \"" user
"\" \""
811 (defun imap-anonymous-p (buffer)
814 (defun imap-anonymous-auth (buffer)
815 (message "imap: Logging in anonymously...")
816 (with-current-buffer buffer
817 (imap-ok-p (imap-send-command-wait
818 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
819 (system-name)) "\"")))))
821 (defun imap-digest-md5-p (buffer)
822 (and (imap-capability 'AUTH
=DIGEST-MD5 buffer
)
824 (require 'digest-md5
)
827 (defun imap-digest-md5-auth (buffer)
828 "Login to server using the AUTH DIGEST-MD5 method."
829 (message "imap: Authenticating using DIGEST-MD5...")
830 (imap-interactive-login
832 (lambda (user passwd
)
836 "AUTHENTICATE DIGEST-MD5"
838 (digest-md5-parse-digest-challenge
839 (base64-decode-string challenge
))
841 (digest-md5-digest-uri
842 "imap" (digest-md5-challenge 'realm
)))
844 (digest-md5-digest-response
845 user passwd digest-uri
)))
846 (base64-encode-string response
'no-line-break
))))
848 (if (not (eq (imap-wait-for-tag tag
) 'INCOMPLETE
))
850 (setq imap-continuation nil
)
851 (imap-send-command-1 "")
852 (imap-ok-p (imap-wait-for-tag tag
)))))))
856 (defun imap-open-1 (buffer)
857 (with-current-buffer buffer
859 (setq imap-current-mailbox nil
860 imap-current-message nil
862 imap-process
(condition-case ()
863 (funcall (nth 2 (assq imap-stream
865 "imap" buffer imap-server imap-port
)
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
))
878 (defun imap-open (server &optional port stream auth buffer
)
879 "Open a IMAP connection to host SERVER at PORT returning a buffer.
880 If PORT is unspecified, a default value is used (143 except
881 for SSL which use 993).
882 STREAM indicates the stream to use, see `imap-streams' for available
883 streams. If nil, it choices the best stream the server is capable of.
884 AUTH indicates authenticator to use, see `imap-authenticators' for
885 available authenticators. If nil, it choices the best stream the
886 server is capable of.
887 BUFFER can be a buffer or a name of a buffer, which is created if
888 necessary. If nil, the buffer name is generated."
889 (setq buffer
(or buffer
(format " *imap* %s:%d" server
(or port
0))))
890 (with-current-buffer (get-buffer-create buffer
)
891 (if (imap-opened buffer
)
893 (mapcar 'make-local-variable imap-local-variables
)
894 (imap-disable-multibyte)
895 (buffer-disable-undo)
896 (setq imap-server
(or server imap-server
))
897 (setq imap-port
(or port imap-port
))
898 (setq imap-auth
(or auth imap-auth
))
899 (setq imap-stream
(or stream imap-stream
))
900 (message "imap: Connecting to %s..." imap-server
)
901 (if (let ((imap-stream (or imap-stream imap-default-stream
)))
902 (imap-open-1 buffer
))
904 (let (stream-changed)
905 (message "imap: Connecting to %s...done" imap-server
)
906 (when (null imap-stream
)
907 (let ((streams imap-streams
))
908 (while (setq stream
(pop streams
))
909 (if (funcall (nth 1 (assq stream imap-stream-alist
)) buffer
)
910 (setq stream-changed
(not (eq (or imap-stream
916 (error "Couldn't figure out a stream for server"))))
918 (message "imap: Reconnecting with stream `%s'..." imap-stream
)
920 (if (imap-open-1 buffer
)
921 (message "imap: Reconnecting with stream `%s'...done"
923 (message "imap: Reconnecting with stream `%s'...failed"
925 (setq imap-capability nil
))
926 (if (imap-opened buffer
)
927 ;; Choose authenticator
928 (when (and (null imap-auth
) (not (eq imap-state
'auth
)))
929 (let ((auths imap-authenticators
))
930 (while (setq auth
(pop auths
))
931 (if (funcall (nth 1 (assq auth imap-authenticator-alist
))
936 (error "Couldn't figure out authenticator for server"))))))
937 (message "imap: Connecting to %s...failed" imap-server
))
938 (when (imap-opened buffer
)
939 (setq imap-mailbox-data
(make-vector imap-mailbox-prime
0))
942 (defun imap-opened (&optional buffer
)
943 "Return non-nil if connection to imap server in BUFFER is open.
944 If BUFFER is nil then the current buffer is used."
945 (and (setq buffer
(get-buffer (or buffer
(current-buffer))))
946 (buffer-live-p buffer
)
947 (with-current-buffer buffer
949 (memq (process-status imap-process
) '(open run
))))))
951 (defun imap-authenticate (&optional user passwd buffer
)
952 "Authenticate to server in BUFFER, using current buffer if nil.
953 It uses the authenticator specified when opening the server. If the
954 authenticator requires username/passwords, they are queried from the
955 user and optionally stored in the buffer. If USER and/or PASSWD is
956 specified, the user will not be questioned and the username and/or
957 password is remembered in the buffer."
958 (with-current-buffer (or buffer
(current-buffer))
959 (if (not (eq imap-state
'nonauth
))
960 (or (eq imap-state
'auth
)
961 (eq imap-state
'select
)
962 (eq imap-state
'examine
))
963 (make-local-variable 'imap-username
)
964 (make-local-variable 'imap-password
)
965 (if user
(setq imap-username user
))
966 (if passwd
(setq imap-password passwd
))
967 (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist
)) buffer
)
968 (setq imap-state
'auth
)))))
970 (defun imap-close (&optional buffer
)
971 "Close connection to server in BUFFER.
972 If BUFFER is nil, the current buffer is used."
973 (with-current-buffer (or buffer
(current-buffer))
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
986 (defun imap-capability (&optional identifier buffer
)
987 "Return a list of identifiers which server in BUFFER support.
988 If IDENTIFIER, return non-nil if it's among the servers capabilities.
989 If BUFFER is nil, the current buffer is assumed."
990 (with-current-buffer (or buffer
(current-buffer))
991 (unless imap-capability
992 (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
993 (setq imap-capability
'(IMAP2))))
995 (memq (intern (upcase (symbol-name identifier
))) imap-capability
)
998 (defun imap-namespace (&optional buffer
)
999 "Return a namespace hierarchy at server in BUFFER.
1000 If BUFFER is nil, the current buffer is assumed."
1001 (with-current-buffer (or buffer
(current-buffer))
1002 (unless imap-namespace
1003 (when (imap-capability 'NAMESPACE
)
1004 (imap-send-command-wait "NAMESPACE")))
1007 (defun imap-send-command-wait (command &optional buffer
)
1008 (imap-wait-for-tag (imap-send-command command buffer
) buffer
))
1011 ;; Mailbox functions:
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
)
1018 (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1019 propname value mailbox
(current-buffer)))
1022 (defsubst imap-mailbox-get-1
(propname &optional mailbox
)
1023 (get (intern-soft (or mailbox imap-current-mailbox
) imap-mailbox-data
)
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
)))))
1031 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer
)
1032 (with-current-buffer (or buffer
(current-buffer))
1036 (push (funcall func
(if mailbox-decoder
1037 (funcall mailbox-decoder
(symbol-name s
))
1038 (symbol-name s
))) result
))
1042 (defun imap-mailbox-map (func &optional buffer
)
1043 "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1044 Function should take a mailbox name (a string) as
1046 (imap-mailbox-map-1 func
'imap-utf7-decode buffer
))
1048 (defun imap-current-mailbox (&optional buffer
)
1049 (with-current-buffer (or buffer
(current-buffer))
1050 (imap-utf7-decode imap-current-mailbox
)))
1052 (defun imap-current-mailbox-p-1 (mailbox &optional examine
)
1053 (and (string= mailbox imap-current-mailbox
)
1055 (eq imap-state
'examine
))
1057 (eq imap-state
'selected
)))))
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
)))
1063 (defun imap-mailbox-select-1 (mailbox &optional examine
)
1064 "Select MAILBOX on server in BUFFER.
1065 If EXAMINE is non-nil, do a read-only select."
1066 (if (imap-current-mailbox-p-1 mailbox examine
)
1067 imap-current-mailbox
1068 (setq imap-current-mailbox mailbox
)
1069 (if (imap-ok-p (imap-send-command-wait
1070 (concat (if examine
"EXAMINE" "SELECT") " \""
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
))))
1079 (defun imap-mailbox-select (mailbox &optional examine buffer
)
1080 (with-current-buffer (or buffer
(current-buffer))
1082 (imap-mailbox-select-1 (imap-utf7-encode mailbox
) examine
))))
1084 (defun imap-mailbox-examine-1 (mailbox &optional buffer
)
1085 (with-current-buffer (or buffer
(current-buffer))
1086 (imap-mailbox-select-1 mailbox
'examine
)))
1088 (defun imap-mailbox-examine (mailbox &optional buffer
)
1089 "Examine MAILBOX on server in BUFFER."
1090 (imap-mailbox-select mailbox
'examine buffer
))
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")))
1099 (imap-send-command-wait (concat "EXAMINE \""
1100 imap-current-mailbox
1102 (imap-ok-p (imap-send-command-wait "CLOSE"))))
1103 (setq imap-current-mailbox nil
1104 imap-message-data nil
1108 (defun imap-mailbox-expunge (&optional buffer
)
1109 "Expunge articles in current folder in BUFFER.
1110 If BUFFER is nil the current buffer is assumed."
1111 (with-current-buffer (or buffer
(current-buffer))
1112 (when (and imap-current-mailbox
(not (eq imap-state
'examine
)))
1113 (imap-ok-p (imap-send-command-wait "EXPUNGE")))))
1115 (defun imap-mailbox-close (&optional buffer
)
1116 "Expunge articles and close current folder in BUFFER.
1117 If BUFFER is nil the current buffer is assumed."
1118 (with-current-buffer (or buffer
(current-buffer))
1119 (when (and imap-current-mailbox
1120 (imap-ok-p (imap-send-command-wait "CLOSE")))
1121 (setq imap-current-mailbox nil
1122 imap-message-data nil
1126 (defun imap-mailbox-create-1 (mailbox)
1127 (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox
"\""))))
1129 (defun imap-mailbox-create (mailbox &optional buffer
)
1130 "Create MAILBOX on server in BUFFER.
1131 If BUFFER is nil the current buffer is assumed."
1132 (with-current-buffer (or buffer
(current-buffer))
1133 (imap-mailbox-create-1 (imap-utf7-encode mailbox
))))
1135 (defun imap-mailbox-delete (mailbox &optional buffer
)
1136 "Delete MAILBOX on server in BUFFER.
1137 If BUFFER is nil the current buffer is assumed."
1138 (let ((mailbox (imap-utf7-encode mailbox
)))
1139 (with-current-buffer (or buffer
(current-buffer))
1141 (imap-send-command-wait (list "DELETE \"" mailbox
"\""))))))
1143 (defun imap-mailbox-rename (oldname newname
&optional buffer
)
1144 "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1145 If BUFFER is nil the current buffer is assumed."
1146 (let ((oldname (imap-utf7-encode oldname
))
1147 (newname (imap-utf7-encode newname
)))
1148 (with-current-buffer (or buffer
(current-buffer))
1150 (imap-send-command-wait (list "RENAME \"" oldname
"\" "
1151 "\"" newname
"\""))))))
1153 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer
)
1154 "Return a list of subscribed mailboxes on server in BUFFER.
1155 If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
1156 non-nil, a hierarchy delimiter is added to root. REFERENCE is a
1157 implementation-specific string that has to be passed to lsub command."
1158 (with-current-buffer (or buffer
(current-buffer))
1159 ;; Make sure we know the hierarchy separator for root's hierarchy
1160 (when (and add-delimiter
(null (imap-mailbox-get-1 'delimiter root
)))
1161 (imap-send-command-wait (concat "LIST \"" reference
"\" \""
1162 (imap-utf7-encode root
) "\"")))
1163 ;; clear list data (NB not delimiter and other stuff)
1164 (imap-mailbox-map-1 (lambda (mailbox)
1165 (imap-mailbox-put 'lsub nil mailbox
)))
1167 (imap-send-command-wait
1168 (concat "LSUB \"" reference
"\" \"" (imap-utf7-encode root
)
1169 (and add-delimiter
(imap-mailbox-get-1 'delimiter root
))
1172 (imap-mailbox-map-1 (lambda (mailbox)
1173 (when (imap-mailbox-get-1 'lsub mailbox
)
1174 (push (imap-utf7-decode mailbox
) out
))))
1177 (defun imap-mailbox-list (root &optional reference add-delimiter buffer
)
1178 "Return a list of mailboxes matching ROOT on server in BUFFER.
1179 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1180 root. REFERENCE is a implementation-specific string that has to be
1181 passed to list command."
1182 (with-current-buffer (or buffer
(current-buffer))
1183 ;; Make sure we know the hierarchy separator for root's hierarchy
1184 (when (and add-delimiter
(null (imap-mailbox-get-1 'delimiter root
)))
1185 (imap-send-command-wait (concat "LIST \"" reference
"\" \""
1186 (imap-utf7-encode root
) "\"")))
1187 ;; clear list data (NB not delimiter and other stuff)
1188 (imap-mailbox-map-1 (lambda (mailbox)
1189 (imap-mailbox-put 'list nil mailbox
)))
1191 (imap-send-command-wait
1192 (concat "LIST \"" reference
"\" \"" (imap-utf7-encode root
)
1193 (and add-delimiter
(imap-mailbox-get-1 'delimiter root
))
1196 (imap-mailbox-map-1 (lambda (mailbox)
1197 (when (imap-mailbox-get-1 'list mailbox
)
1198 (push (imap-utf7-decode mailbox
) out
))))
1201 (defun imap-mailbox-subscribe (mailbox &optional buffer
)
1202 "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1203 Returns non-nil if successful."
1204 (with-current-buffer (or buffer
(current-buffer))
1205 (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1206 (imap-utf7-encode mailbox
)
1209 (defun imap-mailbox-unsubscribe (mailbox &optional buffer
)
1210 "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1211 Returns non-nil if successful."
1212 (with-current-buffer (or buffer
(current-buffer))
1213 (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1214 (imap-utf7-encode mailbox
)
1217 (defun imap-mailbox-status (mailbox items
&optional buffer
)
1218 "Get status items ITEM in MAILBOX from server in BUFFER.
1219 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1220 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1221 or 'unseen. If ITEMS is a list of symbols, a list of values is
1222 returned, if ITEMS is a symbol only its value is returned."
1223 (with-current-buffer (or buffer
(current-buffer))
1225 (imap-send-command-wait (list "STATUS \""
1226 (imap-utf7-encode mailbox
)
1233 (mapcar (lambda (item)
1234 (imap-mailbox-get item mailbox
))
1236 (imap-mailbox-get items mailbox
)))))
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))
1243 (imap-send-command-wait (list "GETACL \""
1244 (or mailbox imap-current-mailbox
)
1246 (imap-mailbox-get-1 'acl
(or mailbox imap-current-mailbox
))))))
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))
1253 (imap-send-command-wait (list "SETACL \""
1254 (or mailbox imap-current-mailbox
)
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))
1265 (imap-send-command-wait (list "DELETEACL \""
1266 (or mailbox imap-current-mailbox
)
1271 ;; Message functions:
1273 (defun imap-current-message (&optional buffer
)
1274 (with-current-buffer (or buffer
(current-buffer))
1275 imap-current-message
))
1277 (defun imap-list-to-message-set (list)
1278 (mapconcat (lambda (item)
1279 (number-to-string item
))
1285 (defun imap-range-to-message-set (range)
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))
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 ")
1301 (imap-list-to-message-set uids
)
1305 (defun imap-fetch (uids props
&optional receive nouidfetch buffer
)
1306 "Fetch properties PROPS from message set UIDS from server in BUFFER.
1307 UIDS can be a string, number or a list of numbers. If RECEIVE
1308 is non-nil return theese properties."
1309 (with-current-buffer (or buffer
(current-buffer))
1310 (when (imap-ok-p (imap-send-command-wait
1311 (format "%sFETCH %s %s" (if nouidfetch
"" "UID ")
1313 (imap-list-to-message-set uids
)
1316 (if (or (null receive
) (stringp uids
))
1319 (mapcar (lambda (uid)
1321 (mapcar (lambda (prop)
1322 (imap-message-get uid prop
))
1324 (imap-message-get uid receive
)))
1326 (imap-message-get uids receive
))))))
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
)
1333 (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1334 uid propname value
(current-buffer)))
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
)
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))
1348 (push (funcall func
(get s
'UID
) (get s propname
)) result
))
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)))
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)))
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)))
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)))
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)))
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)))
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)))
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)))
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)))
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)))
1392 (defmacro imap-message-body
(uid &optional buffer
)
1393 `(with-current-buffer (or ,buffer
(current-buffer))
1394 (imap-message-get ,uid
'BODY
)))
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
)))))
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
)))))
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
")"))))))
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
")"))))))
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
")"))))))
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
)
1437 (imap-message-data (make-vector 2 0)))
1438 (when (imap-mailbox-examine-1 mailbox
)
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
))))
1445 (imap-mailbox-select old-mailbox
(eq state
'examine
))
1446 (imap-mailbox-unselect)))))))
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
))))
1452 (defun imap-message-copy (articles mailbox
1453 &optional dont-create no-copyuid buffer
)
1454 "Copy ARTICLES (a string message set) to MAILBOX on server in
1455 BUFFER, creating mailbox if it doesn't exist. If dont-create is
1456 non-nil, it will not create a mailbox. On success, return a list with
1457 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1458 first element, rest of list contain the saved articles' UIDs."
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
))
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
)))))
1471 (imap-message-copyuid-1 mailbox
)))))))
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
)
1478 (imap-message-data (make-vector 2 0)))
1479 (when (imap-mailbox-examine-1 mailbox
)
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
))))
1486 (imap-mailbox-select old-mailbox
(eq state
'examine
))
1487 (imap-mailbox-unselect)))))))
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
))))
1493 (defun imap-message-append (mailbox article
&optional flags date-time buffer
)
1494 "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1495 FLAGS and DATE-TIME is currently not used. Return a cons holding
1496 uidvalidity of MAILBOX and UID the newly created article got, or nil
1498 (let ((mailbox (imap-utf7-encode mailbox
)))
1499 (with-current-buffer (or buffer
(current-buffer))
1500 (and (let ((imap-current-target-mailbox mailbox
))
1502 (imap-send-command-wait
1503 (list "APPEND \"" mailbox
"\" " article
))))
1504 (imap-message-appenduid-1 mailbox
)))))
1506 (defun imap-body-lines (body)
1507 "Return number of lines in article by looking at the mime bodystructure BODY."
1509 (if (stringp (car body
))
1510 (cond ((and (string= (upcase (car body
)) "TEXT")
1511 (numberp (nth 7 body
)))
1513 ((and (string= (upcase (car body
)) "MESSAGE")
1514 (numberp (nth 9 body
)))
1517 (apply '+ (mapcar 'imap-body-lines body
)))
1520 (defun imap-envelope-from (from)
1521 "Return a from string line."
1523 (concat (aref from
0)
1524 (if (aref from
0) " <")
1528 (if (aref from
0) ">"))))
1531 ;; Internal functions.
1533 (defun imap-send-command-1 (cmdstr)
1534 (setq cmdstr
(concat cmdstr imap-client-eol
))
1536 (with-current-buffer (get-buffer-create imap-log
)
1537 (imap-disable-multibyte)
1538 (buffer-disable-undo)
1539 (goto-char (point-max))
1541 (process-send-string imap-process cmdstr
))
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
)))
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
)))
1553 (let ((eol imap-client-eol
)
1554 (calcfirst imap-calculate-literal-size-first
)
1556 (with-current-buffer cmd
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
)))
1565 (setq size
(buffer-size))))
1567 (concat cmdstr
(format "{%d}" size
))))
1570 (imap-send-command-1 cmdstr
)
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
1579 (with-current-buffer (get-buffer-create
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)
1587 (process-send-string process imap-client-eol
))))
1588 (setq imap-continuation nil
)))
1590 (imap-send-command-1 cmdstr
)
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
)
1597 (setq imap-continuation nil
)))
1599 (error "Unknown command type"))))
1601 (imap-send-command-1 cmdstr
))
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
)))
1610 (accept-process-output imap-process
1)))
1611 (or (assq tag imap-failed-tags
)
1612 (if imap-continuation
1616 (defun imap-sentinel (process string
)
1617 (delete-process process
))
1619 (defun imap-find-next-line ()
1620 "Return point at end of current line, taking into account literals.
1621 Return nil if no complete line has arrived."
1622 (when (re-search-forward (concat imap-server-eol
"\\|{\\([0-9]+\\)}"
1625 (if (match-string 1)
1626 (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1628 (goto-char (+ (point) (string-to-number (match-string 1))))
1629 (imap-find-next-line))
1632 (defun imap-arrival-filter (proc string
)
1633 "IMAP process filter."
1634 (with-current-buffer (process-buffer proc
)
1635 (goto-char (point-max))
1638 (with-current-buffer (get-buffer-create imap-log
)
1639 (imap-disable-multibyte)
1640 (buffer-disable-undo)
1641 (goto-char (point-max))
1644 (goto-char (point-min))
1645 (while (setq end
(imap-find-next-line))
1647 (narrow-to-region (point-min) end
)
1648 (delete-backward-char (length imap-server-eol
))
1649 (goto-char (point-min))
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))
1659 (message "Unknown state %s in arrival filter"
1661 (delete-region (point-min) (point-max))))))))
1666 (defsubst imap-forward
()
1667 (or (eobp) (forward-char)))
1670 ;; ; Unsigned 32-bit integer
1671 ;; ; (0 <= n < 4,294,967,296)
1673 (defsubst imap-parse-number
()
1674 (when (looking-at "[0-9]+")
1676 (string-to-number (match-string 0))
1677 (goto-char (match-end 0)))))
1679 ;; literal = "{" number "}" CRLF *CHAR8
1680 ;; ; Number represents the number of CHAR8s
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
))
1688 (goto-char (+ pos len
))
1689 (buffer-substring pos
(+ pos len
))))))
1691 ;; string = quoted / literal
1693 ;; quoted = DQUOTE *QUOTED-CHAR DQUOTE
1695 ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
1696 ;; "\" quoted-specials
1698 ;; quoted-specials = DQUOTE / "\"
1700 ;; TEXT-CHAR = <any CHAR except CR and LF>
1702 (defsubst imap-parse-string
()
1703 (cond ((eq (char-after) ?
\")
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)))
1711 (skip-chars-forward "^\"\\\\")
1712 (setq name
(concat name
(buffer-substring p
(point)))))
1715 ((eq (char-after) ?
{)
1716 (imap-parse-literal))))
1720 (defsubst imap-parse-nil
()
1721 (if (looking-at "NIL")
1722 (goto-char (match-end 0))))
1724 ;; nstring = string / nil
1726 (defsubst imap-parse-nstring
()
1727 (or (imap-parse-string)
1728 (and (imap-parse-nil)
1731 ;; astring = atom / string
1733 ;; atom = 1*ATOM-CHAR
1735 ;; ATOM-CHAR = <any CHAR except atom-specials>
1737 ;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards /
1740 ;; list-wildcards = "%" / "*"
1742 ;; quoted-specials = DQUOTE / "\"
1744 (defsubst imap-parse-astring
()
1745 (or (imap-parse-string)
1746 (buffer-substring (point)
1747 (if (re-search-forward "[(){ \r\n%*\"\\]" nil t
)
1748 (goto-char (1- (match-end 0)))
1752 ;; address = "(" addr-name SP addr-adl SP addr-mailbox SP
1755 ;; addr-adl = nstring
1756 ;; ; Holds route from [RFC-822] route-addr if
1759 ;; addr-host = nstring
1760 ;; ; nil indicates [RFC-822] group syntax.
1761 ;; ; Otherwise, holds [RFC-822] domain name
1763 ;; addr-mailbox = nstring
1764 ;; ; nil indicates end of [RFC-822] group; if
1765 ;; ; non-nil and addr-host is nil, holds
1766 ;; ; [RFC-822] group name.
1767 ;; ; Otherwise, holds [RFC-822] local-part
1768 ;; ; after removing [RFC-822] quoting
1770 ;; addr-name = nstring
1771 ;; ; If non-nil, holds phrase from [RFC-822]
1772 ;; ; mailbox after removing [RFC-822] quoting
1775 (defsubst imap-parse-address
()
1777 (when (eq (char-after) ?\
()
1779 (setq address
(vector (prog1 (imap-parse-nstring)
1781 (prog1 (imap-parse-nstring)
1783 (prog1 (imap-parse-nstring)
1785 (imap-parse-nstring)))
1786 (when (eq (char-after) ?\
))
1790 ;; address-list = "(" 1*address ")" / nil
1794 (defsubst imap-parse-address-list
()
1795 (if (eq (char-after) ?\
()
1796 (let (address addresses
)
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) ?\
))
1805 (nreverse addresses
)))
1806 ;; (assert (imap-parse-nil)) ; With assert, the code might not be eval'd.
1809 ;; mailbox = "INBOX" / astring
1810 ;; ; INBOX is case-insensitive. All case variants of
1811 ;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
1812 ;; ; not as an astring. An astring which consists of
1813 ;; ; the case-insensitive sequence "I" "N" "B" "O" "X"
1814 ;; ; is considered to be INBOX and not an astring.
1815 ;; ; Refer to section 5.1 for further
1816 ;; ; semantic details of mailbox names.
1818 (defsubst imap-parse-mailbox
()
1819 (let ((mailbox (imap-parse-astring)))
1820 (if (string-equal "INBOX" (upcase mailbox
))
1824 ;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
1826 ;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text
1827 ;; ; Authentication condition
1829 ;; resp-cond-bye = "BYE" SP resp-text
1831 (defun imap-parse-greeting ()
1832 "Parse a IMAP greeting."
1833 (cond ((looking-at "\\* OK ")
1834 (setq imap-state
'nonauth
))
1835 ((looking-at "\\* PREAUTH ")
1836 (setq imap-state
'auth
))
1837 ((looking-at "\\* BYE ")
1838 (setq imap-state
'closed
))))
1840 ;; response = *(continue-req / response-data) response-done
1842 ;; continue-req = "+" SP (resp-text / base64) CRLF
1844 ;; response-data = "*" SP (resp-cond-state / resp-cond-bye /
1845 ;; mailbox-data / message-data / capability-data) CRLF
1847 ;; response-done = response-tagged / response-fatal
1849 ;; response-fatal = "*" SP resp-cond-bye CRLF
1850 ;; ; Server closes connection immediately
1852 ;; response-tagged = tag SP resp-cond-state CRLF
1854 ;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
1855 ;; ; Status condition
1857 ;; resp-cond-bye = "BYE" SP resp-text
1859 ;; mailbox-data = "FLAGS" SP flag-list /
1860 ;; "LIST" SP mailbox-list /
1861 ;; "LSUB" SP mailbox-list /
1862 ;; "SEARCH" *(SP nz-number) /
1863 ;; "STATUS" SP mailbox SP "("
1864 ;; [status-att SP number *(SP status-att SP number)] ")" /
1865 ;; number SP "EXISTS" /
1866 ;; number SP "RECENT"
1868 ;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
1870 ;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
1872 ;; ; IMAP4rev1 servers which offer RFC 1730
1873 ;; ; compatibility MUST list "IMAP4" as the first
1876 (defun imap-parse-response ()
1877 "Parse a IMAP command response."
1879 (case (setq token
(read (current-buffer)))
1880 (+ (setq imap-continuation
1881 (or (buffer-substring (min (point-max) (1+ (point)))
1884 (* (case (prog1 (setq token
(read (current-buffer)))
1886 (OK (imap-parse-resp-text))
1887 (NO (imap-parse-resp-text))
1888 (BAD (imap-parse-resp-text))
1889 (BYE (imap-parse-resp-text))
1890 (FLAGS (imap-mailbox-put 'flags
(imap-parse-flag-list)))
1891 (LIST (imap-parse-data-list 'list
))
1892 (LSUB (imap-parse-data-list 'lsub
))
1893 (SEARCH (imap-mailbox-put
1895 (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
1896 (STATUS (imap-parse-status))
1897 (CAPABILITY (setq imap-capability
1898 (read (concat "(" (upcase (buffer-substring
1899 (point) (point-max)))
1901 (ACL (imap-parse-acl))
1902 (t (case (prog1 (read (current-buffer))
1904 (EXISTS (imap-mailbox-put 'exists token
))
1905 (RECENT (imap-mailbox-put 'recent token
))
1907 (FETCH (imap-parse-fetch token
))
1908 (t (message "Garbage: %s" (buffer-string)))))))
1910 (if (not (integerp token
))
1911 (message "Garbage: %s" (buffer-string))
1912 (case (prog1 (setq status
(read (current-buffer)))
1915 (setq imap-reached-tag
(max imap-reached-tag token
))
1916 (imap-parse-resp-text)))
1918 (setq imap-reached-tag
(max imap-reached-tag token
))
1920 (imap-parse-resp-text))
1922 (when (eq (char-after) ?\
[)
1923 (setq code
(buffer-substring (point)
1924 (search-forward "]")))
1926 (setq text
(buffer-substring (point) (point-max)))
1927 (push (list token status code text
)
1928 imap-failed-tags
))))
1930 (setq imap-reached-tag
(max imap-reached-tag token
))
1932 (imap-parse-resp-text))
1934 (when (eq (char-after) ?\
[)
1935 (setq code
(buffer-substring (point)
1936 (search-forward "]")))
1938 (setq text
(buffer-substring (point) (point-max)))
1939 (push (list token status code text
) imap-failed-tags
)
1940 (error "Internal error, tag %s status %s code %s text %s"
1941 token status code text
))))
1942 (t (message "Garbage: %s" (buffer-string))))))))))
1944 ;; resp-text = ["[" resp-text-code "]" SP] text
1946 ;; text = 1*TEXT-CHAR
1948 ;; TEXT-CHAR = <any CHAR except CR and LF>
1950 (defun imap-parse-resp-text ()
1951 (imap-parse-resp-text-code))
1953 ;; resp-text-code = "ALERT" /
1954 ;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
1955 ;; "NEWNAME" SP string SP string /
1957 ;; "PERMANENTFLAGS" SP "("
1958 ;; [flag-perm *(SP flag-perm)] ")" /
1962 ;; "UIDNEXT" SP nz-number /
1963 ;; "UIDVALIDITY" SP nz-number /
1964 ;; "UNSEEN" SP nz-number /
1965 ;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
1967 ;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid
1969 ;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set
1971 ;; set = sequence-num / (sequence-num ":" sequence-num) /
1973 ;; ; Identifies a set of messages. For message
1974 ;; ; sequence numbers, these are consecutive
1975 ;; ; numbers from 1 to the number of messages in
1977 ;; ; Comma delimits individual numbers, colon
1978 ;; ; delimits between two numbers inclusive.
1979 ;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
1980 ;; ; 14,15 for a mailbox with 15 messages.
1982 ;; sequence-num = nz-number / "*"
1983 ;; ; * is the largest number in use. For message
1984 ;; ; sequence numbers, it is the number of messages
1985 ;; ; in the mailbox. For unique identifiers, it is
1986 ;; ; the unique identifier of the last message in
1989 ;; flag-perm = flag / "\*"
1991 ;; flag = "\Answered" / "\Flagged" / "\Deleted" /
1992 ;; "\Seen" / "\Draft" / flag-keyword / flag-extension
1993 ;; ; Does not include "\Recent"
1995 ;; flag-extension = "\" atom
1996 ;; ; Future expansion. Client implementations
1997 ;; ; MUST accept flag-extension flags. Server
1998 ;; ; implementations MUST NOT generate
1999 ;; ; flag-extension flags except as defined by
2000 ;; ; future standard or standards-track
2001 ;; ; revisions of this specification.
2003 ;; flag-keyword = atom
2005 ;; resp-text-atom = 1*<any ATOM-CHAR except "]">
2007 (defun imap-parse-resp-text-code ()
2008 (when (eq (char-after) ?\
[)
2010 (cond ((search-forward "PERMANENTFLAGS " nil t
)
2011 (imap-mailbox-put 'permanentflags
(imap-parse-flag-list)))
2012 ((search-forward "UIDNEXT " nil t
)
2013 (imap-mailbox-put 'uidnext
(read (current-buffer))))
2014 ((search-forward "UNSEEN " nil t
)
2015 (imap-mailbox-put 'unseen
(read (current-buffer))))
2016 ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2017 (imap-mailbox-put 'uidvalidity
(match-string 1)))
2018 ((search-forward "READ-ONLY" nil t
)
2019 (imap-mailbox-put 'read-only t
))
2020 ((search-forward "NEWNAME " nil t
)
2021 (let (oldname newname
)
2022 (setq oldname
(imap-parse-string))
2024 (setq newname
(imap-parse-string))
2025 (imap-mailbox-put 'newname newname oldname
)))
2026 ((search-forward "TRYCREATE" nil t
)
2027 (imap-mailbox-put 'trycreate t imap-current-target-mailbox
))
2028 ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2029 (imap-mailbox-put 'appenduid
2030 (list (match-string 1)
2031 (string-to-number (match-string 2)))
2032 imap-current-target-mailbox
))
2033 ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2034 (imap-mailbox-put 'copyuid
(list (match-string 1)
2037 imap-current-target-mailbox
))
2038 ((search-forward "ALERT] " nil t
)
2039 (message "Imap server %s information: %s" imap-server
2040 (buffer-substring (point) (point-max)))))))
2042 ;; mailbox-list = "(" [mbx-list-flags] ")" SP
2043 ;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2045 ;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag
2046 ;; *(SP mbx-list-oflag) /
2047 ;; mbx-list-oflag *(SP mbx-list-oflag)
2049 ;; mbx-list-oflag = "\Noinferiors" / flag-extension
2050 ;; ; Other flags; multiple possible per LIST response
2052 ;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked"
2053 ;; ; Selectability flags; only one per LIST response
2055 ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
2056 ;; "\" quoted-specials
2058 ;; quoted-specials = DQUOTE / "\"
2060 (defun imap-parse-data-list (type)
2061 (let (flags delimiter mailbox
)
2062 (setq flags
(imap-parse-flag-list))
2063 (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2064 (setq delimiter
(match-string 1))
2065 (goto-char (1+ (match-end 0)))
2066 (when (setq mailbox
(imap-parse-mailbox))
2067 (imap-mailbox-put type t mailbox
)
2068 (imap-mailbox-put 'list-flags flags mailbox
)
2069 (imap-mailbox-put 'delimiter delimiter mailbox
)))))
2071 ;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope /
2072 ;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2073 ;; "INTERNALDATE" SPACE date_time /
2074 ;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2075 ;; "RFC822.SIZE" SPACE number /
2076 ;; "BODY" ["STRUCTURE"] SPACE body /
2077 ;; "BODY" section ["<" number ">"] SPACE nstring /
2078 ;; "UID" SPACE uniqueid) ")"
2080 ;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
2081 ;; SPACE time SPACE zone <">
2083 ;; section ::= "[" [section_text / (nz_number *["." nz_number]
2084 ;; ["." (section_text / "MIME")])] "]"
2086 ;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2087 ;; SPACE header_list / "TEXT"
2089 ;; header_fld_name ::= astring
2091 ;; header_list ::= "(" 1#header_fld_name ")"
2093 (defsubst imap-parse-header-list
()
2094 (when (eq (char-after) ?\
()
2096 (while (not (eq (char-after) ?\
)))
2098 (push (imap-parse-astring) strlist
))
2100 (nreverse strlist
))))
2102 (defsubst imap-parse-fetch-body-section
()
2104 (buffer-substring (point) (1- (re-search-forward "[] ]" nil t
)))))
2105 (if (eq (char-before) ?
)
2107 (mapconcat 'identity
(cons section
(imap-parse-header-list)) " ")
2108 (search-forward "]" nil t
))
2111 (defun imap-parse-fetch (response)
2112 (when (eq (char-after) ?\
()
2113 (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2114 rfc822size body bodydetail bodystructure
)
2115 (while (not (eq (char-after) ?\
)))
2117 (let ((token (read (current-buffer))))
2119 (cond ((eq token
'UID
)
2120 (setq uid
(ignore-errors (read (current-buffer)))))
2122 (setq flags
(imap-parse-flag-list)))
2123 ((eq token
'ENVELOPE
)
2124 (setq envelope
(imap-parse-envelope)))
2125 ((eq token
'INTERNALDATE
)
2126 (setq internaldate
(imap-parse-string)))
2128 (setq rfc822
(imap-parse-nstring)))
2129 ((eq token
'RFC822.HEADER
)
2130 (setq rfc822header
(imap-parse-nstring)))
2131 ((eq token
'RFC822.TEXT
)
2132 (setq rfc822text
(imap-parse-nstring)))
2133 ((eq token
'RFC822.SIZE
)
2134 (setq rfc822size
(read (current-buffer))))
2136 (if (eq (char-before) ?\
[)
2138 (upcase (imap-parse-fetch-body-section))
2139 (and (eq (char-after) ?
<)
2140 (buffer-substring (1+ (point))
2141 (search-forward ">" nil t
)))
2142 (progn (imap-forward)
2143 (imap-parse-nstring)))
2145 (setq body
(imap-parse-body))))
2146 ((eq token
'BODYSTRUCTURE
)
2147 (setq bodystructure
(imap-parse-body))))))
2149 (setq imap-current-message uid
)
2150 (imap-message-put uid
'UID uid
)
2151 (and flags
(imap-message-put uid
'FLAGS flags
))
2152 (and envelope
(imap-message-put uid
'ENVELOPE envelope
))
2153 (and internaldate
(imap-message-put uid
'INTERNALDATE internaldate
))
2154 (and rfc822
(imap-message-put uid
'RFC822 rfc822
))
2155 (and rfc822header
(imap-message-put uid
'RFC822.HEADER rfc822header
))
2156 (and rfc822text
(imap-message-put uid
'RFC822.TEXT rfc822text
))
2157 (and rfc822size
(imap-message-put uid
'RFC822.SIZE rfc822size
))
2158 (and body
(imap-message-put uid
'BODY body
))
2159 (and bodydetail
(imap-message-put uid
'BODYDETAIL bodydetail
))
2160 (and bodystructure
(imap-message-put uid
'BODYSTRUCTURE bodystructure
))
2161 (run-hooks 'imap-fetch-data-hook
)))))
2163 ;; mailbox-data = ...
2164 ;; "STATUS" SP mailbox SP "("
2165 ;; [status-att SP number
2166 ;; *(SP status-att SP number)] ")"
2169 ;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2172 (defun imap-parse-status ()
2173 (let ((mailbox (imap-parse-mailbox)))
2174 (when (and mailbox
(search-forward "(" nil t
))
2175 (while (not (eq (char-after) ?\
)))
2176 (let ((token (read (current-buffer))))
2177 (cond ((eq token
'MESSAGES
)
2178 (imap-mailbox-put 'messages
(read (current-buffer)) mailbox
))
2180 (imap-mailbox-put 'recent
(read (current-buffer)) mailbox
))
2181 ((eq token
'UIDNEXT
)
2182 (imap-mailbox-put 'uidnext
(read (current-buffer)) mailbox
))
2183 ((eq token
'UIDVALIDITY
)
2184 (and (looking-at " \\([0-9]+\\)")
2185 (imap-mailbox-put 'uidvalidity
(match-string 1) mailbox
)
2186 (goto-char (match-end 1))))
2188 (imap-mailbox-put 'unseen
(read (current-buffer)) mailbox
))
2190 (message "Unknown status data %s in mailbox %s ignored"
2191 token mailbox
))))))))
2193 ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2196 ;; identifier ::= astring
2198 ;; rights ::= astring
2200 (defun imap-parse-acl ()
2201 (let ((mailbox (imap-parse-mailbox))
2202 identifier rights acl
)
2203 (while (eq (char-after) ?\
)
2205 (setq identifier
(imap-parse-astring))
2207 (setq rights
(imap-parse-astring))
2208 (setq acl
(append acl
(list (cons identifier rights
)))))
2209 (imap-mailbox-put 'acl acl mailbox
)))
2211 ;; flag-list = "(" [flag *(SP flag)] ")"
2213 ;; flag = "\Answered" / "\Flagged" / "\Deleted" /
2214 ;; "\Seen" / "\Draft" / flag-keyword / flag-extension
2215 ;; ; Does not include "\Recent"
2217 ;; flag-keyword = atom
2219 ;; flag-extension = "\" atom
2220 ;; ; Future expansion. Client implementations
2221 ;; ; MUST accept flag-extension flags. Server
2222 ;; ; implementations MUST NOT generate
2223 ;; ; flag-extension flags except as defined by
2224 ;; ; future standard or standards-track
2225 ;; ; revisions of this specification.
2227 (defun imap-parse-flag-list ()
2228 (let (flag-list start
)
2229 (assert (eq (char-after) ?\
())
2230 (while (and (not (eq (char-after) ?\
)))
2231 (setq start
(progn (imap-forward) (point)))
2232 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
2233 (push (buffer-substring start
(point)) flag-list
))
2234 (assert (eq (char-after) ?\
)))
2236 (nreverse flag-list
)))
2238 ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP
2239 ;; env-reply-to SP env-to SP env-cc SP env-bcc SP
2240 ;; env-in-reply-to SP env-message-id ")"
2242 ;; env-bcc = "(" 1*address ")" / nil
2244 ;; env-cc = "(" 1*address ")" / nil
2246 ;; env-date = nstring
2248 ;; env-from = "(" 1*address ")" / nil
2250 ;; env-in-reply-to = nstring
2252 ;; env-message-id = nstring
2254 ;; env-reply-to = "(" 1*address ")" / nil
2256 ;; env-sender = "(" 1*address ")" / nil
2258 ;; env-subject = nstring
2260 ;; env-to = "(" 1*address ")" / nil
2262 (defun imap-parse-envelope ()
2263 (when (eq (char-after) ?\
()
2265 (vector (prog1 (imap-parse-nstring);; date
2267 (prog1 (imap-parse-nstring);; subject
2269 (prog1 (imap-parse-address-list);; from
2271 (prog1 (imap-parse-address-list);; sender
2273 (prog1 (imap-parse-address-list);; reply-to
2275 (prog1 (imap-parse-address-list);; to
2277 (prog1 (imap-parse-address-list);; cc
2279 (prog1 (imap-parse-address-list);; bcc
2281 (prog1 (imap-parse-nstring);; in-reply-to
2283 (prog1 (imap-parse-nstring);; message-id
2286 ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2288 (defsubst imap-parse-string-list
()
2289 (cond ((eq (char-after) ?\
();; body-fld-param
2292 (while (setq str
(imap-parse-string))
2294 ;; buggy stalker communigate pro 3.0 doesn't print SPC
2295 ;; between body-fld-param's sometimes
2296 (or (eq (char-after) ?
\")
2298 (nreverse strlist
)))
2302 ;; body-extension = nstring / number /
2303 ;; "(" body-extension *(SP body-extension) ")"
2304 ;; ; Future expansion. Client implementations
2305 ;; ; MUST accept body-extension fields. Server
2306 ;; ; implementations MUST NOT generate
2307 ;; ; body-extension fields except as defined by
2308 ;; ; future standard or standards-track
2309 ;; ; revisions of this specification.
2311 (defun imap-parse-body-extension ()
2312 (if (eq (char-after) ?\
()
2315 (push (imap-parse-body-extension) b-e
)
2316 (while (eq (char-after) ?\
)
2318 (push (imap-parse-body-extension) b-e
))
2319 (assert (eq (char-after) ?\
)))
2322 (or (imap-parse-number)
2323 (imap-parse-nstring))))
2325 ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2326 ;; *(SP body-extension)]]
2327 ;; ; MUST NOT be returned on non-extensible
2330 ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2331 ;; *(SP body-extension)]]
2332 ;; ; MUST NOT be returned on non-extensible
2335 (defsubst imap-parse-body-ext
()
2337 (when (eq (char-after) ?\
);; body-fld-dsp
2340 (if (eq (char-after) ?\
()
2343 (push (imap-parse-string) dsp
)
2345 (push (imap-parse-string-list) dsp
)
2347 ;; (assert (imap-parse-nil)) ; Code in assert might not be eval'd.
2349 (push (nreverse dsp
) ext
))
2350 (when (eq (char-after) ?\
);; body-fld-lang
2352 (if (eq (char-after) ?\
()
2353 (push (imap-parse-string-list) ext
)
2354 (push (imap-parse-nstring) ext
))
2355 (while (eq (char-after) ?\
);; body-extension
2357 (setq ext
(append (imap-parse-body-extension) ext
)))))
2360 ;; body = "(" body-type-1part / body-type-mpart ")"
2362 ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2363 ;; *(SP body-extension)]]
2364 ;; ; MUST NOT be returned on non-extensible
2367 ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2368 ;; *(SP body-extension)]]
2369 ;; ; MUST NOT be returned on non-extensible
2372 ;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP
2373 ;; body-fld-enc SP body-fld-octets
2375 ;; body-fld-desc = nstring
2377 ;; body-fld-dsp = "(" string SP body-fld-param ")" / nil
2379 ;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2380 ;; "QUOTED-PRINTABLE") DQUOTE) / string
2382 ;; body-fld-id = nstring
2384 ;; body-fld-lang = nstring / "(" string *(SP string) ")"
2386 ;; body-fld-lines = number
2388 ;; body-fld-md5 = nstring
2390 ;; body-fld-octets = number
2392 ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
2394 ;; body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2395 ;; [SP body-ext-1part]
2397 ;; body-type-basic = media-basic SP body-fields
2398 ;; ; MESSAGE subtype MUST NOT be "RFC822"
2400 ;; body-type-msg = media-message SP body-fields SP envelope
2401 ;; SP body SP body-fld-lines
2403 ;; body-type-text = media-text SP body-fields SP body-fld-lines
2405 ;; body-type-mpart = 1*body SP media-subtype
2406 ;; [SP body-ext-mpart]
2408 ;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2409 ;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2410 ;; ; Defined in [MIME-IMT]
2412 ;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2413 ;; ; Defined in [MIME-IMT]
2415 ;; media-subtype = string
2416 ;; ; Defined in [MIME-IMT]
2418 ;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype
2419 ;; ; Defined in [MIME-IMT]
2421 (defun imap-parse-body ()
2423 (when (eq (char-after) ?\
()
2425 (if (eq (char-after) ?\
()
2427 (while (and (eq (char-after) ?\
()
2428 (setq subbody
(imap-parse-body)))
2429 ;; buggy stalker communigate pro 3.0 insert a SPC between
2430 ;; parts in multiparts
2431 (when (and (eq (char-after) ?\
)
2432 (eq (char-after (1+ (point))) ?\
())
2434 (push subbody body
))
2436 (push (imap-parse-string) body
);; media-subtype
2437 (when (eq (char-after) ?\
);; body-ext-mpart:
2439 (if (eq (char-after) ?\
();; body-fld-param
2440 (push (imap-parse-string-list) body
)
2441 (push (and (imap-parse-nil) nil
) body
))
2443 (append (imap-parse-body-ext) body
)));; body-ext-...
2444 (assert (eq (char-after) ?\
)))
2448 (push (imap-parse-string) body
);; media-type
2450 (push (imap-parse-string) body
);; media-subtype
2452 ;; next line for Sun SIMS bug
2453 (and (eq (char-after) ?
) (imap-forward))
2454 (if (eq (char-after) ?\
();; body-fld-param
2455 (push (imap-parse-string-list) body
)
2456 (push (and (imap-parse-nil) nil
) body
))
2458 (push (imap-parse-nstring) body
);; body-fld-id
2460 (push (imap-parse-nstring) body
);; body-fld-desc
2462 ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2463 ;; nstring and return nil instead of defaulting back to 7BIT
2464 ;; as the standard says.
2465 (push (or (imap-parse-nstring) "7BIT") body
);; body-fld-enc
2467 (push (imap-parse-number) body
);; body-fld-octets
2469 ;; ok, we're done parsing the required parts, what comes now is one
2472 ;; envelope (then we're parsing body-type-msg)
2473 ;; body-fld-lines (then we're parsing body-type-text)
2474 ;; body-ext-1part (then we're parsing body-type-basic)
2476 ;; the problem is that the two first are in turn optionally followed
2477 ;; by the third. So we parse the first two here (if there are any)...
2479 (when (eq (char-after) ?\
)
2482 (cond ((eq (char-after) ?\
();; body-type-msg:
2483 (push (imap-parse-envelope) body
);; envelope
2485 (push (imap-parse-body) body
);; body
2486 ;; buggy stalker communigate pro 3.0 doesn't print
2487 ;; number of lines in message/rfc822 attachment
2488 (if (eq (char-after) ?\
))
2491 (push (imap-parse-number) body
))) ;; body-fld-lines
2492 ((setq lines
(imap-parse-number)) ;; body-type-text:
2493 (push lines body
)) ;; body-fld-lines
2495 (backward-char))))) ;; no match...
2497 ;; ...and then parse the third one here...
2499 (when (eq (char-after) ?\
);; body-ext-1part:
2501 (push (imap-parse-nstring) body
);; body-fld-md5
2502 (setq body
(append (imap-parse-body-ext) body
)));; body-ext-1part..
2504 (assert (eq (char-after) ?\
)))
2508 (when imap-debug
; (untrace-all)
2510 (buffer-disable-undo (get-buffer-create imap-debug
))
2511 (mapcar (lambda (f) (trace-function-background f imap-debug
))
2523 imap-interactive-login
2539 imap-send-command-wait
2544 imap-current-mailbox
2545 imap-current-mailbox-p-1
2546 imap-current-mailbox-p
2547 imap-mailbox-select-1
2549 imap-mailbox-examine-1
2550 imap-mailbox-examine
2551 imap-mailbox-unselect
2552 imap-mailbox-expunge
2554 imap-mailbox-create-1
2560 imap-mailbox-subscribe
2561 imap-mailbox-unsubscribe
2563 imap-mailbox-acl-get
2564 imap-mailbox-acl-set
2565 imap-mailbox-acl-delete
2566 imap-current-message
2567 imap-list-to-message-set
2574 imap-message-flag-permanent-p
2575 imap-message-flags-set
2576 imap-message-flags-del
2577 imap-message-flags-add
2578 imap-message-copyuid-1
2579 imap-message-copyuid
2581 imap-message-appenduid-1
2582 imap-message-appenduid
2594 imap-parse-resp-text
2595 imap-parse-resp-text-code
2596 imap-parse-data-list
2600 imap-parse-flag-list
2602 imap-parse-body-extension
2608 ;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
2609 ;;; imap.el ends here