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