1 |
;;; imap.el --- imap library |
;;; imap.el --- imap library |
2 |
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Simon Josefsson <jas@pdc.kth.se> |
;; Author: Simon Josefsson <jas@pdc.kth.se> |
125 |
;; o Don't use `read' at all (important places already fixed) |
;; o Don't use `read' at all (important places already fixed) |
126 |
;; o Accept list of articles instead of message set string in most |
;; o Accept list of articles instead of message set string in most |
127 |
;; imap-message-* functions. |
;; imap-message-* functions. |
128 |
|
;; o Send strings as literal if they contain, e.g., ". |
129 |
;; |
;; |
130 |
;; Revision history: |
;; Revision history: |
131 |
;; |
;; |
153 |
(autoload 'utf7-decode "utf7") |
(autoload 'utf7-decode "utf7") |
154 |
(autoload 'format-spec "format-spec") |
(autoload 'format-spec "format-spec") |
155 |
(autoload 'format-spec-make "format-spec") |
(autoload 'format-spec-make "format-spec") |
156 |
|
(autoload 'open-tls-stream "tls") |
157 |
;; Avoid use gnus-point-at-eol so we're independent of Gnus. These |
;; Avoid use gnus-point-at-eol so we're independent of Gnus. These |
158 |
;; days we have point-at-eol anyhow. |
;; days we have point-at-eol anyhow. |
159 |
(if (fboundp 'point-at-eol) |
(if (fboundp 'point-at-eol) |
180 |
:group 'imap |
:group 'imap |
181 |
:type '(repeat string)) |
:type '(repeat string)) |
182 |
|
|
183 |
(defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s") |
(defcustom imap-gssapi-program (list |
184 |
|
(concat "gsasl --client --connect %s:%p " |
185 |
|
"--imap --application-data " |
186 |
|
"--mechanism GSSAPI " |
187 |
|
"--authentication-id %l") |
188 |
|
"imtest -m gssapi -u %l -p %p %s") |
189 |
"List of strings containing commands for GSSAPI (krb5) authentication. |
"List of strings containing commands for GSSAPI (krb5) authentication. |
190 |
%s is replaced with server hostname, %p with port to connect to, and |
%s is replaced with server hostname, %p with port to connect to, and |
191 |
%l with the value of `imap-default-user'. The program should accept |
%l with the value of `imap-default-user'. The program should accept |
220 |
:group 'imap |
:group 'imap |
221 |
:type '(repeat string)) |
:type '(repeat string)) |
222 |
|
|
223 |
(defvar imap-shell-host "gateway" |
(defcustom imap-process-connection-type nil |
224 |
"Hostname of rlogin proxy.") |
"*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. |
225 |
|
The `process-connection-type' variable control type of device |
226 |
|
used to communicate with subprocesses. Values are nil to use a |
227 |
|
pipe, or t or `pty' to use a pty. The value has no effect if the |
228 |
|
system has no ptys or if all ptys are busy: then a pipe is used |
229 |
|
in any case. The value takes effect when a IMAP server is |
230 |
|
opened, changing it after that has no effect.." |
231 |
|
:group 'imap |
232 |
|
:type 'boolean) |
233 |
|
|
234 |
(defvar imap-default-user (user-login-name) |
(defcustom imap-use-utf7 t |
235 |
"Default username to use.") |
"If non-nil, do utf7 encoding/decoding of mailbox names. |
236 |
|
Since the UTF7 decoding currently only decodes into ISO-8859-1 |
237 |
|
characters, you may disable this decoding if you need to access UTF7 |
238 |
|
encoded mailboxes which doesn't translate into ISO-8859-1." |
239 |
|
:group 'imap |
240 |
|
:type 'boolean) |
241 |
|
|
242 |
(defvar imap-error nil |
(defcustom imap-log nil |
243 |
"Error codes from the last command.") |
"If non-nil, a imap session trace is placed in *imap-log* buffer." |
244 |
|
:group 'imap |
245 |
|
:type 'boolean) |
246 |
|
|
247 |
|
(defcustom imap-debug nil |
248 |
|
"If non-nil, random debug spews are placed in *imap-debug* buffer." |
249 |
|
:group 'imap |
250 |
|
:type 'boolean) |
251 |
|
|
252 |
|
(defcustom imap-shell-host "gateway" |
253 |
|
"Hostname of rlogin proxy." |
254 |
|
:group 'imap |
255 |
|
:type 'string) |
256 |
|
|
257 |
|
(defcustom imap-default-user (user-login-name) |
258 |
|
"Default username to use." |
259 |
|
:group 'imap |
260 |
|
:type 'string) |
261 |
|
|
262 |
|
(defcustom imap-read-timeout (if (string-match |
263 |
|
"windows-nt\\|os/2\\|emx\\|cygwin" |
264 |
|
(symbol-name system-type)) |
265 |
|
1.0 |
266 |
|
0.1) |
267 |
|
"*How long to wait between checking for the end of output. |
268 |
|
Shorter values mean quicker response, but is more CPU intensive." |
269 |
|
:type 'number |
270 |
|
:group 'imap) |
271 |
|
|
272 |
;; Various variables. |
;; Various variables. |
273 |
|
|
274 |
(defvar imap-fetch-data-hook nil |
(defvar imap-fetch-data-hook nil |
275 |
"Hooks called after receiving each FETCH response.") |
"Hooks called after receiving each FETCH response.") |
276 |
|
|
277 |
(defvar imap-streams '(gssapi kerberos4 starttls ssl network shell) |
(defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell) |
278 |
"Priority of streams to consider when opening connection to server.") |
"Priority of streams to consider when opening connection to server.") |
279 |
|
|
280 |
(defvar imap-stream-alist |
(defvar imap-stream-alist |
281 |
'((gssapi imap-gssapi-stream-p imap-gssapi-open) |
'((gssapi imap-gssapi-stream-p imap-gssapi-open) |
282 |
(kerberos4 imap-kerberos4-stream-p imap-kerberos4-open) |
(kerberos4 imap-kerberos4-stream-p imap-kerberos4-open) |
283 |
|
(tls imap-tls-p imap-tls-open) |
284 |
(ssl imap-ssl-p imap-ssl-open) |
(ssl imap-ssl-p imap-ssl-open) |
285 |
(network imap-network-p imap-network-open) |
(network imap-network-p imap-network-open) |
286 |
(shell imap-shell-p imap-shell-open) |
(shell imap-shell-p imap-shell-open) |
290 |
\(NAME CHECK OPEN) |
\(NAME CHECK OPEN) |
291 |
|
|
292 |
NAME names the stream, CHECK is a function returning non-nil if the |
NAME names the stream, CHECK is a function returning non-nil if the |
293 |
server supports the stream and OPEN is a function for opening the |
server support the stream and OPEN is a function for opening the |
294 |
stream.") |
stream.") |
295 |
|
|
296 |
(defvar imap-authenticators '(gssapi |
(defvar imap-authenticators '(gssapi |
316 |
the server support the authenticator and AUTHENTICATE is a function |
the server support the authenticator and AUTHENTICATE is a function |
317 |
for doing the actual authentication.") |
for doing the actual authentication.") |
318 |
|
|
319 |
(defvar imap-use-utf7 t |
(defvar imap-error nil |
320 |
"If non-nil, do utf7 encoding/decoding of mailbox names. |
"Error codes from the last command.") |
|
Since the UTF7 decoding currently only decodes into ISO-8859-1 |
|
|
characters, you may disable this decoding if you need to access UTF7 |
|
|
encoded mailboxes which doesn't translate into ISO-8859-1.") |
|
321 |
|
|
322 |
;; Internal constants. Change theese and die. |
;; Internal constants. Change theese and die. |
323 |
|
|
324 |
(defconst imap-default-port 143) |
(defconst imap-default-port 143) |
325 |
(defconst imap-default-ssl-port 993) |
(defconst imap-default-ssl-port 993) |
326 |
|
(defconst imap-default-tls-port 993) |
327 |
(defconst imap-default-stream 'network) |
(defconst imap-default-stream 'network) |
328 |
(defconst imap-coding-system-for-read 'binary) |
(defconst imap-coding-system-for-read 'binary) |
329 |
(defconst imap-coding-system-for-write 'binary) |
(defconst imap-coding-system-for-write 'binary) |
347 |
imap-process |
imap-process |
348 |
imap-calculate-literal-size-first |
imap-calculate-literal-size-first |
349 |
imap-mailbox-data)) |
imap-mailbox-data)) |
350 |
|
(defconst imap-log-buffer "*imap-log*") |
351 |
|
(defconst imap-debug-buffer "*imap-debug*") |
352 |
|
|
353 |
;; Internal variables. |
;; Internal variables. |
354 |
|
|
416 |
"Non-nil indicates that the server emitted a continuation request. |
"Non-nil indicates that the server emitted a continuation request. |
417 |
The actual value is really the text on the continuation line.") |
The actual value is really the text on the continuation line.") |
418 |
|
|
419 |
(defvar imap-log nil |
(defvar imap-callbacks nil |
420 |
"Name of buffer for imap session trace. |
"List of response tags and callbacks, on the form `(number . function)'. |
421 |
For example: (setq imap-log \"*imap-log*\")") |
The function should take two arguments, the first the IMAP tag and the |
422 |
|
second the status (OK, NO, BAD etc) of the command.") |
|
(defvar imap-debug nil ;"*imap-debug*" |
|
|
"Name of buffer for random debug spew. |
|
|
For example: (setq imap-debug \"*imap-debug*\")") |
|
423 |
|
|
424 |
|
|
425 |
;; Utility functions: |
;; Utility functions: |
426 |
|
|
427 |
|
(defun imap-remassoc (key alist) |
428 |
|
"Delete by side effect any elements of LIST whose car is `equal' to KEY. |
429 |
|
The modified LIST is returned. If the first member |
430 |
|
of LIST has a car that is `equal' to KEY, there is no way to remove it |
431 |
|
by side effect; therefore, write `(setq foo (remassoc key foo))' to be |
432 |
|
sure of changing the value of `foo'." |
433 |
|
(when alist |
434 |
|
(if (equal key (caar alist)) |
435 |
|
(cdr alist) |
436 |
|
(setcdr alist (imap-remassoc key (cdr alist))) |
437 |
|
alist))) |
438 |
|
|
439 |
(defsubst imap-disable-multibyte () |
(defsubst imap-disable-multibyte () |
440 |
"Enable multibyte in the current buffer." |
"Enable multibyte in the current buffer." |
441 |
(when (fboundp 'set-buffer-multibyte) |
(when (fboundp 'set-buffer-multibyte) |
442 |
(set-buffer-multibyte nil))) |
(set-buffer-multibyte nil))) |
443 |
|
|
|
(defun imap-read-passwd (prompt &rest args) |
|
|
"Read a password using PROMPT. |
|
|
If ARGS, PROMPT is used as an argument to `format'." |
|
|
(let ((prompt (if args |
|
|
(apply 'format prompt args) |
|
|
prompt))) |
|
|
(funcall (if (or (fboundp 'read-passwd) |
|
|
(and (load "subr" t) |
|
|
(fboundp 'read-passwd)) |
|
|
(and (load "passwd" t) |
|
|
(fboundp 'read-passwd))) |
|
|
'read-passwd |
|
|
(autoload 'ange-ftp-read-passwd "ange-ftp") |
|
|
'ange-ftp-read-passwd) |
|
|
prompt))) |
|
|
|
|
444 |
(defsubst imap-utf7-encode (string) |
(defsubst imap-utf7-encode (string) |
445 |
(if imap-use-utf7 |
(if imap-use-utf7 |
446 |
(and string |
(and string |
488 |
(let* ((port (or port imap-default-port)) |
(let* ((port (or port imap-default-port)) |
489 |
(coding-system-for-read imap-coding-system-for-read) |
(coding-system-for-read imap-coding-system-for-read) |
490 |
(coding-system-for-write imap-coding-system-for-write) |
(coding-system-for-write imap-coding-system-for-write) |
491 |
|
(process-connection-type imap-process-connection-type) |
492 |
(process (start-process |
(process (start-process |
493 |
name buffer shell-file-name shell-command-switch |
name buffer shell-file-name shell-command-switch |
494 |
(format-spec |
(format-spec |
503 |
(setq imap-client-eol "\n" |
(setq imap-client-eol "\n" |
504 |
imap-calculate-literal-size-first t) |
imap-calculate-literal-size-first t) |
505 |
(while (and (memq (process-status process) '(open run)) |
(while (and (memq (process-status process) '(open run)) |
506 |
|
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
507 |
(goto-char (point-min)) |
(goto-char (point-min)) |
508 |
;; cyrus 1.6.x (13? < x <= 22) queries capabilities |
;; Athena IMTEST can output SSL verify errors |
509 |
(or (while (looking-at "^C:") |
(or (while (looking-at "^verify error:num=") |
510 |
|
(forward-line)) |
511 |
|
t) |
512 |
|
(or (while (looking-at "^TLS connection established") |
513 |
|
(forward-line)) |
514 |
|
t) |
515 |
|
;; cyrus 1.6.x (13? < x <= 22) queries capabilities |
516 |
|
(or (while (looking-at "^C:") |
517 |
(forward-line)) |
(forward-line)) |
518 |
t) |
t) |
519 |
;; cyrus 1.6 imtest print "S: " before server greeting |
;; cyrus 1.6 imtest print "S: " before server greeting |
531 |
(accept-process-output process 1) |
(accept-process-output process 1) |
532 |
(sit-for 1)) |
(sit-for 1)) |
533 |
(and imap-log |
(and imap-log |
534 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
535 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
536 |
(buffer-disable-undo) |
(buffer-disable-undo) |
537 |
(goto-char (point-max)) |
(goto-char (point-max)) |
543 |
(not (string-match "failed" response)))) |
(not (string-match "failed" response)))) |
544 |
(setq done process) |
(setq done process) |
545 |
(if (memq (process-status process) '(open run)) |
(if (memq (process-status process) '(open run)) |
546 |
(imap-send-command-wait "LOGOUT")) |
(imap-send-command "LOGOUT")) |
547 |
(delete-process process) |
(delete-process process) |
548 |
nil))))) |
nil))))) |
549 |
done)) |
done)) |
556 |
cmd done) |
cmd done) |
557 |
(while (and (not done) (setq cmd (pop cmds))) |
(while (and (not done) (setq cmd (pop cmds))) |
558 |
(message "Opening GSSAPI IMAP connection with `%s'..." cmd) |
(message "Opening GSSAPI IMAP connection with `%s'..." cmd) |
559 |
|
(erase-buffer) |
560 |
(let* ((port (or port imap-default-port)) |
(let* ((port (or port imap-default-port)) |
561 |
(coding-system-for-read imap-coding-system-for-read) |
(coding-system-for-read imap-coding-system-for-read) |
562 |
(coding-system-for-write imap-coding-system-for-write) |
(coding-system-for-write imap-coding-system-for-write) |
563 |
|
(process-connection-type imap-process-connection-type) |
564 |
(process (start-process |
(process (start-process |
565 |
name buffer shell-file-name shell-command-switch |
name buffer shell-file-name shell-command-switch |
566 |
(format-spec |
(format-spec |
572 |
response) |
response) |
573 |
(when process |
(when process |
574 |
(with-current-buffer buffer |
(with-current-buffer buffer |
575 |
(setq imap-client-eol "\n") |
(setq imap-client-eol "\n" |
576 |
|
imap-calculate-literal-size-first t) |
577 |
(while (and (memq (process-status process) '(open run)) |
(while (and (memq (process-status process) '(open run)) |
578 |
|
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
579 |
(goto-char (point-min)) |
(goto-char (point-min)) |
580 |
;; cyrus 1.6.x (13? < x <= 22) queries capabilities |
;; cyrus 1.6.x (13? < x <= 22) queries capabilities |
581 |
(or (while (looking-at "^C:") |
(or (while (looking-at "^C:") |
582 |
(forward-line)) |
(forward-line)) |
583 |
t) |
t) |
584 |
;; cyrus 1.6 imtest print "S: " before server greeting |
;; cyrus 1.6 imtest print "S: " before server greeting |
588 |
(not (and (imap-parse-greeting) |
(not (and (imap-parse-greeting) |
589 |
;; success in imtest 1.6: |
;; success in imtest 1.6: |
590 |
(re-search-forward |
(re-search-forward |
591 |
"^\\(Authenticat.*\\)" nil t) |
(concat "^\\(\\(Authenticat.*\\)\\|\\(" |
592 |
|
"Client authentication " |
593 |
|
"finished.*\\)\\)") |
594 |
|
nil t) |
595 |
(setq response (match-string 1))))) |
(setq response (match-string 1))))) |
596 |
(accept-process-output process 1) |
(accept-process-output process 1) |
597 |
(sit-for 1)) |
(sit-for 1)) |
598 |
(and imap-log |
(and imap-log |
599 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
600 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
601 |
(buffer-disable-undo) |
(buffer-disable-undo) |
602 |
(goto-char (point-max)) |
(goto-char (point-max)) |
607 |
(not (string-match "failed" response)))) |
(not (string-match "failed" response)))) |
608 |
(setq done process) |
(setq done process) |
609 |
(if (memq (process-status process) '(open run)) |
(if (memq (process-status process) '(open run)) |
610 |
(imap-send-command-wait "LOGOUT")) |
(imap-send-command "LOGOUT")) |
611 |
(delete-process process) |
(delete-process process) |
612 |
nil))))) |
nil))))) |
613 |
done)) |
done)) |
622 |
cmd done) |
cmd done) |
623 |
(while (and (not done) (setq cmd (pop cmds))) |
(while (and (not done) (setq cmd (pop cmds))) |
624 |
(message "imap: Opening SSL connection with `%s'..." cmd) |
(message "imap: Opening SSL connection with `%s'..." cmd) |
625 |
|
(erase-buffer) |
626 |
(let* ((port (or port imap-default-ssl-port)) |
(let* ((port (or port imap-default-ssl-port)) |
627 |
(coding-system-for-read imap-coding-system-for-read) |
(coding-system-for-read imap-coding-system-for-read) |
628 |
(coding-system-for-write imap-coding-system-for-write) |
(coding-system-for-write imap-coding-system-for-write) |
629 |
(process-connection-type nil) |
(process-connection-type nil) |
630 |
process) |
process) |
631 |
(when (progn |
(when (progn |
632 |
(setq process (start-process |
(setq process (start-process |
633 |
name buffer shell-file-name |
name buffer shell-file-name |
634 |
shell-command-switch |
shell-command-switch |
635 |
(format-spec cmd |
(format-spec cmd |
636 |
(format-spec-make |
(format-spec-make |
637 |
?s server |
?s server |
638 |
?p (number-to-string port))))) |
?p (number-to-string port))))) |
648 |
(accept-process-output process 1) |
(accept-process-output process 1) |
649 |
(sit-for 1)) |
(sit-for 1)) |
650 |
(and imap-log |
(and imap-log |
651 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
652 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
653 |
(buffer-disable-undo) |
(buffer-disable-undo) |
654 |
(goto-char (point-max)) |
(goto-char (point-max)) |
660 |
(progn |
(progn |
661 |
(message "imap: Opening SSL connection with `%s'...done" cmd) |
(message "imap: Opening SSL connection with `%s'...done" cmd) |
662 |
done) |
done) |
663 |
(message "imap: Opening SSL connection with `%s'...failed" cmd) |
(message "imap: Opening SSL connection with `%s'...failed" cmd) |
664 |
nil))) |
nil))) |
665 |
|
|
666 |
|
(defun imap-tls-p (buffer) |
667 |
|
nil) |
668 |
|
|
669 |
|
(defun imap-tls-open (name buffer server port) |
670 |
|
(let* ((port (or port imap-default-tls-port)) |
671 |
|
(coding-system-for-read imap-coding-system-for-read) |
672 |
|
(coding-system-for-write imap-coding-system-for-write) |
673 |
|
(process (open-tls-stream name buffer server port))) |
674 |
|
(when process |
675 |
|
(while (and (memq (process-status process) '(open run)) |
676 |
|
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
677 |
|
(goto-char (point-max)) |
678 |
|
(forward-line -1) |
679 |
|
(not (imap-parse-greeting))) |
680 |
|
(accept-process-output process 1) |
681 |
|
(sit-for 1)) |
682 |
|
(and imap-log |
683 |
|
(with-current-buffer (get-buffer-create imap-log-buffer) |
684 |
|
(imap-disable-multibyte) |
685 |
|
(buffer-disable-undo) |
686 |
|
(goto-char (point-max)) |
687 |
|
(insert-buffer-substring buffer))) |
688 |
|
(when (memq (process-status process) '(open run)) |
689 |
|
process)))) |
690 |
|
|
691 |
(defun imap-network-p (buffer) |
(defun imap-network-p (buffer) |
692 |
t) |
t) |
693 |
|
|
698 |
(process (open-network-stream name buffer server port))) |
(process (open-network-stream name buffer server port))) |
699 |
(when process |
(when process |
700 |
(while (and (memq (process-status process) '(open run)) |
(while (and (memq (process-status process) '(open run)) |
701 |
|
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
702 |
(goto-char (point-min)) |
(goto-char (point-min)) |
703 |
(not (imap-parse-greeting))) |
(not (imap-parse-greeting))) |
704 |
(accept-process-output process 1) |
(accept-process-output process 1) |
705 |
(sit-for 1)) |
(sit-for 1)) |
706 |
(and imap-log |
(and imap-log |
707 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
708 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
709 |
(buffer-disable-undo) |
(buffer-disable-undo) |
710 |
(goto-char (point-max)) |
(goto-char (point-max)) |
716 |
nil) |
nil) |
717 |
|
|
718 |
(defun imap-shell-open (name buffer server port) |
(defun imap-shell-open (name buffer server port) |
719 |
(let ((cmds imap-shell-program) |
(let ((cmds (if (listp imap-shell-program) imap-shell-program |
720 |
|
(list imap-shell-program))) |
721 |
cmd done) |
cmd done) |
722 |
(while (and (not done) (setq cmd (pop cmds))) |
(while (and (not done) (setq cmd (pop cmds))) |
723 |
(message "imap: Opening IMAP connection with `%s'..." cmd) |
(message "imap: Opening IMAP connection with `%s'..." cmd) |
736 |
?l imap-default-user))))) |
?l imap-default-user))))) |
737 |
(when process |
(when process |
738 |
(while (and (memq (process-status process) '(open run)) |
(while (and (memq (process-status process) '(open run)) |
739 |
(goto-char (point-min)) |
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
740 |
|
(goto-char (point-max)) |
741 |
|
(forward-line -1) |
742 |
(not (imap-parse-greeting))) |
(not (imap-parse-greeting))) |
743 |
(accept-process-output process 1) |
(accept-process-output process 1) |
744 |
(sit-for 1)) |
(sit-for 1)) |
|
(erase-buffer) |
|
745 |
(and imap-log |
(and imap-log |
746 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
747 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
748 |
(buffer-disable-undo) |
(buffer-disable-undo) |
749 |
(goto-char (point-max)) |
(goto-char (point-max)) |
750 |
(insert-buffer-substring buffer))) |
(insert-buffer-substring buffer))) |
751 |
|
(erase-buffer) |
752 |
(when (memq (process-status process) '(open run)) |
(when (memq (process-status process) '(open run)) |
753 |
(setq done process))))) |
(setq done process))))) |
754 |
(if done |
(if done |
755 |
(progn |
(progn |
756 |
(message "imap: Opening IMAP connection with `%s'...done" cmd) |
(message "imap: Opening IMAP connection with `%s'...done" cmd) |
757 |
done) |
done) |
758 |
(message "imap: Opening IMAP connection with `%s'...failed" cmd) |
(message "imap: Opening IMAP connection with `%s'...failed" cmd) |
759 |
nil))) |
nil))) |
760 |
|
|
761 |
(defun imap-starttls-p (buffer) |
(defun imap-starttls-p (buffer) |
762 |
(and (imap-capability 'STARTTLS buffer) |
(imap-capability 'STARTTLS buffer)) |
|
(condition-case () |
|
|
(progn |
|
|
(require 'starttls) |
|
|
(call-process "starttls")) |
|
|
(error nil)))) |
|
763 |
|
|
764 |
(defun imap-starttls-open (name buffer server port) |
(defun imap-starttls-open (name buffer server port) |
765 |
(let* ((port (or port imap-default-port)) |
(let* ((port (or port imap-default-port)) |
766 |
(coding-system-for-read imap-coding-system-for-read) |
(coding-system-for-read imap-coding-system-for-read) |
767 |
(coding-system-for-write imap-coding-system-for-write) |
(coding-system-for-write imap-coding-system-for-write) |
768 |
(process (starttls-open-stream name buffer server port)) |
(process (starttls-open-stream name buffer server port)) |
769 |
done) |
done tls-info) |
770 |
(message "imap: Connecting with STARTTLS...") |
(message "imap: Connecting with STARTTLS...") |
771 |
(when process |
(when process |
772 |
(while (and (memq (process-status process) '(open run)) |
(while (and (memq (process-status process) '(open run)) |
773 |
(goto-char (point-min)) |
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
774 |
|
(goto-char (point-max)) |
775 |
|
(forward-line -1) |
776 |
(not (imap-parse-greeting))) |
(not (imap-parse-greeting))) |
777 |
(accept-process-output process 1) |
(accept-process-output process 1) |
778 |
(sit-for 1)) |
(sit-for 1)) |
779 |
|
(imap-send-command "STARTTLS") |
780 |
|
(while (and (memq (process-status process) '(open run)) |
781 |
|
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
782 |
|
(goto-char (point-max)) |
783 |
|
(forward-line -1) |
784 |
|
(not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) |
785 |
|
(accept-process-output process 1) |
786 |
|
(sit-for 1)) |
787 |
(and imap-log |
(and imap-log |
788 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
789 |
(buffer-disable-undo) |
(buffer-disable-undo) |
790 |
(goto-char (point-max)) |
(goto-char (point-max)) |
791 |
(insert-buffer-substring buffer))) |
(insert-buffer-substring buffer))) |
792 |
(let ((imap-process process)) |
(when (and (setq tls-info (starttls-negotiate process)) |
793 |
(unwind-protect |
(memq (process-status process) '(open run))) |
|
(progn |
|
|
(set-process-filter imap-process 'imap-arrival-filter) |
|
|
(when (and (eq imap-stream 'starttls) |
|
|
(imap-ok-p (imap-send-command-wait "STARTTLS"))) |
|
|
(starttls-negotiate imap-process))) |
|
|
(set-process-filter imap-process nil))) |
|
|
(when (memq (process-status process) '(open run)) |
|
794 |
(setq done process))) |
(setq done process))) |
795 |
(if done |
(if (stringp tls-info) |
796 |
(progn |
(message "imap: STARTTLS info: %s" tls-info)) |
797 |
(message "imap: Connecting with STARTTLS...done") |
(message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) |
798 |
done) |
done)) |
|
(message "imap: Connecting with STARTTLS...failed") |
|
|
nil))) |
|
799 |
|
|
800 |
;; Server functions; authenticator stuff: |
;; Server functions; authenticator stuff: |
801 |
|
|
812 |
(while (or (not user) (not passwd)) |
(while (or (not user) (not passwd)) |
813 |
(setq user (or imap-username |
(setq user (or imap-username |
814 |
(read-from-minibuffer |
(read-from-minibuffer |
815 |
(concat "IMAP username for " imap-server ": ") |
(concat "IMAP username for " imap-server |
816 |
|
" (using stream `" (symbol-name imap-stream) |
817 |
|
"'): ") |
818 |
(or user imap-default-user)))) |
(or user imap-default-user)))) |
819 |
(setq passwd (or imap-password |
(setq passwd (or imap-password |
820 |
(imap-read-passwd |
(read-passwd |
821 |
(concat "IMAP password for " user "@" |
(concat "IMAP password for " user "@" |
822 |
imap-server ": ")))) |
imap-server " (using authenticator `" |
823 |
|
(symbol-name imap-auth) "'): ")))) |
824 |
(when (and user passwd) |
(when (and user passwd) |
825 |
(if (funcall loginfunc user passwd) |
(if (funcall loginfunc user passwd) |
826 |
(progn |
(progn |
831 |
(setq imap-password passwd))) |
(setq imap-password passwd))) |
832 |
(message "Login failed...") |
(message "Login failed...") |
833 |
(setq passwd nil) |
(setq passwd nil) |
834 |
|
(setq imap-password nil) |
835 |
(sit-for 1)))) |
(sit-for 1)))) |
836 |
;; (quit (with-current-buffer buffer |
;; (quit (with-current-buffer buffer |
837 |
;; (setq user nil |
;; (setq user nil |
842 |
ret))) |
ret))) |
843 |
|
|
844 |
(defun imap-gssapi-auth-p (buffer) |
(defun imap-gssapi-auth-p (buffer) |
845 |
(imap-capability 'AUTH=GSSAPI buffer)) |
(eq imap-stream 'gssapi)) |
846 |
|
|
847 |
(defun imap-gssapi-auth (buffer) |
(defun imap-gssapi-auth (buffer) |
848 |
(message "imap: Authenticating using GSSAPI...%s" |
(message "imap: Authenticating using GSSAPI...%s" |
850 |
(eq imap-stream 'gssapi)) |
(eq imap-stream 'gssapi)) |
851 |
|
|
852 |
(defun imap-kerberos4-auth-p (buffer) |
(defun imap-kerberos4-auth-p (buffer) |
853 |
(imap-capability 'AUTH=KERBEROS_V4 buffer)) |
(and (imap-capability 'AUTH=KERBEROS_V4 buffer) |
854 |
|
(eq imap-stream 'kerberos4))) |
855 |
|
|
856 |
(defun imap-kerberos4-auth (buffer) |
(defun imap-kerberos4-auth (buffer) |
857 |
(message "imap: Authenticating using Kerberos 4...%s" |
(message "imap: Authenticating using Kerberos 4...%s" |
881 |
(message "imap: Authenticating using CRAM-MD5...done") |
(message "imap: Authenticating using CRAM-MD5...done") |
882 |
(message "imap: Authenticating using CRAM-MD5...failed")))) |
(message "imap: Authenticating using CRAM-MD5...failed")))) |
883 |
|
|
|
|
|
|
|
|
884 |
(defun imap-login-p (buffer) |
(defun imap-login-p (buffer) |
885 |
(and (not (imap-capability 'LOGINDISABLED buffer)) |
(and (not (imap-capability 'LOGINDISABLED buffer)) |
886 |
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) |
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) |
984 |
(setq imap-auth (or auth imap-auth)) |
(setq imap-auth (or auth imap-auth)) |
985 |
(setq imap-stream (or stream imap-stream)) |
(setq imap-stream (or stream imap-stream)) |
986 |
(message "imap: Connecting to %s..." imap-server) |
(message "imap: Connecting to %s..." imap-server) |
987 |
(if (let ((imap-stream (or imap-stream imap-default-stream))) |
(if (null (let ((imap-stream (or imap-stream imap-default-stream))) |
988 |
(imap-open-1 buffer)) |
(imap-open-1 buffer))) |
989 |
;; Choose stream. |
(progn |
990 |
(let (stream-changed) |
(message "imap: Connecting to %s...failed" imap-server) |
991 |
(message "imap: Connecting to %s...done" imap-server) |
nil) |
992 |
(when (null imap-stream) |
(when (null imap-stream) |
993 |
(let ((streams imap-streams)) |
;; Need to choose stream. |
994 |
(while (setq stream (pop streams)) |
(let ((streams imap-streams)) |
995 |
(if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) |
(while (setq stream (pop streams)) |
996 |
(setq stream-changed (not (eq (or imap-stream |
;; OK to use this stream? |
997 |
imap-default-stream) |
(when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) |
998 |
stream)) |
;; Stream changed? |
999 |
imap-stream stream |
(if (not (eq imap-default-stream stream)) |
1000 |
streams nil))) |
(with-current-buffer (get-buffer-create |
1001 |
(unless imap-stream |
(generate-new-buffer-name " *temp*")) |
1002 |
(error "Couldn't figure out a stream for server")))) |
(mapcar 'make-local-variable imap-local-variables) |
1003 |
(when stream-changed |
(imap-disable-multibyte) |
1004 |
(message "imap: Reconnecting with stream `%s'..." imap-stream) |
(buffer-disable-undo) |
1005 |
(imap-close buffer) |
(setq imap-server (or server imap-server)) |
1006 |
(if (imap-open-1 buffer) |
(setq imap-port (or port imap-port)) |
1007 |
(message "imap: Reconnecting with stream `%s'...done" |
(setq imap-auth (or auth imap-auth)) |
1008 |
imap-stream) |
(message "imap: Reconnecting with stream `%s'..." stream) |
1009 |
(message "imap: Reconnecting with stream `%s'...failed" |
(if (null (let ((imap-stream stream)) |
1010 |
imap-stream)) |
(imap-open-1 (current-buffer)))) |
1011 |
(setq imap-capability nil)) |
(progn |
1012 |
(if (imap-opened buffer) |
(kill-buffer (current-buffer)) |
1013 |
;; Choose authenticator |
(message |
1014 |
(when (and (null imap-auth) (not (eq imap-state 'auth))) |
"imap: Reconnecting with stream `%s'...failed" |
1015 |
(let ((auths imap-authenticators)) |
stream)) |
1016 |
(while (setq auth (pop auths)) |
;; We're done, kill the first connection |
1017 |
(if (funcall (nth 1 (assq auth imap-authenticator-alist)) |
(imap-close buffer) |
1018 |
buffer) |
(kill-buffer buffer) |
1019 |
(setq imap-auth auth |
(rename-buffer buffer) |
1020 |
auths nil))) |
(message "imap: Reconnecting with stream `%s'...done" |
1021 |
(unless imap-auth |
stream) |
1022 |
(error "Couldn't figure out authenticator for server")))))) |
(setq imap-stream stream) |
1023 |
(message "imap: Connecting to %s...failed" imap-server)) |
(setq imap-capability nil) |
1024 |
(when (imap-opened buffer) |
(setq streams nil))) |
1025 |
(setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) |
;; We're done |
1026 |
buffer))) |
(message "imap: Connecting to %s...done" imap-server) |
1027 |
|
(setq imap-stream stream) |
1028 |
|
(setq imap-capability nil) |
1029 |
|
(setq streams nil)))))) |
1030 |
|
(when (imap-opened buffer) |
1031 |
|
(setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) |
1032 |
|
(when imap-stream |
1033 |
|
buffer)))) |
1034 |
|
|
1035 |
(defun imap-opened (&optional buffer) |
(defun imap-opened (&optional buffer) |
1036 |
"Return non-nil if connection to imap server in BUFFER is open. |
"Return non-nil if connection to imap server in BUFFER is open. |
1057 |
(make-local-variable 'imap-password) |
(make-local-variable 'imap-password) |
1058 |
(if user (setq imap-username user)) |
(if user (setq imap-username user)) |
1059 |
(if passwd (setq imap-password passwd)) |
(if passwd (setq imap-password passwd)) |
1060 |
(if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) |
(if imap-auth |
1061 |
(setq imap-state 'auth))))) |
(and (funcall (nth 2 (assq imap-auth |
1062 |
|
imap-authenticator-alist)) buffer) |
1063 |
|
(setq imap-state 'auth)) |
1064 |
|
;; Choose authenticator. |
1065 |
|
(let ((auths imap-authenticators) |
1066 |
|
auth) |
1067 |
|
(while (setq auth (pop auths)) |
1068 |
|
;; OK to use authenticator? |
1069 |
|
(when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) |
1070 |
|
(message "imap: Authenticating to `%s' using `%s'..." |
1071 |
|
imap-server auth) |
1072 |
|
(setq imap-auth auth) |
1073 |
|
(if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer) |
1074 |
|
(progn |
1075 |
|
(message "imap: Authenticating to `%s' using `%s'...done" |
1076 |
|
imap-server auth) |
1077 |
|
(setq auths nil)) |
1078 |
|
(message "imap: Authenticating to `%s' using `%s'...failed" |
1079 |
|
imap-server auth))))) |
1080 |
|
imap-state)))) |
1081 |
|
|
1082 |
(defun imap-close (&optional buffer) |
(defun imap-close (&optional buffer) |
1083 |
"Close connection to server in BUFFER. |
"Close connection to server in BUFFER. |
1084 |
If BUFFER is nil, the current buffer is used." |
If BUFFER is nil, the current buffer is used." |
1085 |
(with-current-buffer (or buffer (current-buffer)) |
(with-current-buffer (or buffer (current-buffer)) |
1086 |
(and (imap-opened) |
(when (imap-opened) |
1087 |
(not (imap-ok-p (imap-send-command-wait "LOGOUT"))) |
(condition-case nil |
1088 |
(message "Server %s didn't let me log out" imap-server)) |
(imap-send-command-wait "LOGOUT") |
1089 |
|
(quit nil))) |
1090 |
(when (and imap-process |
(when (and imap-process |
1091 |
(memq (process-status imap-process) '(open run))) |
(memq (process-status imap-process) '(open run))) |
1092 |
(delete-process imap-process)) |
(delete-process imap-process)) |
1218 |
imap-state 'auth) |
imap-state 'auth) |
1219 |
t))) |
t))) |
1220 |
|
|
1221 |
(defun imap-mailbox-expunge (&optional buffer) |
(defun imap-mailbox-expunge (&optional asynch buffer) |
1222 |
"Expunge articles in current folder in BUFFER. |
"Expunge articles in current folder in BUFFER. |
1223 |
|
If ASYNCH, do not wait for succesful completion of the command. |
1224 |
If BUFFER is nil the current buffer is assumed." |
If BUFFER is nil the current buffer is assumed." |
1225 |
(with-current-buffer (or buffer (current-buffer)) |
(with-current-buffer (or buffer (current-buffer)) |
1226 |
(when (and imap-current-mailbox (not (eq imap-state 'examine))) |
(when (and imap-current-mailbox (not (eq imap-state 'examine))) |
1227 |
(imap-ok-p (imap-send-command-wait "EXPUNGE"))))) |
(if asynch |
1228 |
|
(imap-send-command "EXPUNGE") |
1229 |
|
(imap-ok-p (imap-send-command-wait "EXPUNGE")))))) |
1230 |
|
|
1231 |
(defun imap-mailbox-close (&optional buffer) |
(defun imap-mailbox-close (&optional asynch buffer) |
1232 |
"Expunge articles and close current folder in BUFFER. |
"Expunge articles and close current folder in BUFFER. |
1233 |
|
If ASYNCH, do not wait for succesful completion of the command. |
1234 |
If BUFFER is nil the current buffer is assumed." |
If BUFFER is nil the current buffer is assumed." |
1235 |
(with-current-buffer (or buffer (current-buffer)) |
(with-current-buffer (or buffer (current-buffer)) |
1236 |
(when (and imap-current-mailbox |
(when imap-current-mailbox |
1237 |
(imap-ok-p (imap-send-command-wait "CLOSE"))) |
(if asynch |
1238 |
(setq imap-current-mailbox nil |
(imap-add-callback (imap-send-command "CLOSE") |
1239 |
imap-message-data nil |
`(lambda (tag status) |
1240 |
imap-state 'auth) |
(message "IMAP mailbox `%s' closed... %s" |
1241 |
|
imap-current-mailbox status) |
1242 |
|
(when (eq ,imap-current-mailbox |
1243 |
|
imap-current-mailbox) |
1244 |
|
;; Don't wipe out data if another mailbox |
1245 |
|
;; was selected... |
1246 |
|
(setq imap-current-mailbox nil |
1247 |
|
imap-message-data nil |
1248 |
|
imap-state 'auth)))) |
1249 |
|
(when (imap-ok-p (imap-send-command-wait "CLOSE")) |
1250 |
|
(setq imap-current-mailbox nil |
1251 |
|
imap-message-data nil |
1252 |
|
imap-state 'auth))) |
1253 |
t))) |
t))) |
1254 |
|
|
1255 |
(defun imap-mailbox-create-1 (mailbox) |
(defun imap-mailbox-create-1 (mailbox) |
1354 |
(imap-send-command-wait (list "STATUS \"" |
(imap-send-command-wait (list "STATUS \"" |
1355 |
(imap-utf7-encode mailbox) |
(imap-utf7-encode mailbox) |
1356 |
"\" " |
"\" " |
1357 |
(format "%s" |
(upcase |
1358 |
(if (listp items) |
(format "%s" |
1359 |
items |
(if (listp items) |
1360 |
(list items)))))) |
items |
1361 |
|
(list items))))))) |
1362 |
(if (listp items) |
(if (listp items) |
1363 |
(mapcar (lambda (item) |
(mapcar (lambda (item) |
1364 |
(imap-mailbox-get item mailbox)) |
(imap-mailbox-get item mailbox)) |
1365 |
items) |
items) |
1366 |
(imap-mailbox-get items mailbox))))) |
(imap-mailbox-get items mailbox))))) |
1367 |
|
|
1368 |
|
(defun imap-mailbox-status-asynch (mailbox items &optional buffer) |
1369 |
|
"Send status item request ITEM on MAILBOX to server in BUFFER. |
1370 |
|
ITEMS can be a symbol or a list of symbols, valid symbols are one of |
1371 |
|
the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity |
1372 |
|
or 'unseen. The IMAP command tag is returned." |
1373 |
|
(with-current-buffer (or buffer (current-buffer)) |
1374 |
|
(imap-send-command (list "STATUS \"" |
1375 |
|
(imap-utf7-encode mailbox) |
1376 |
|
"\" " |
1377 |
|
(format "%s" |
1378 |
|
(if (listp items) |
1379 |
|
items |
1380 |
|
(list items))))))) |
1381 |
|
|
1382 |
(defun imap-mailbox-acl-get (&optional mailbox buffer) |
(defun imap-mailbox-acl-get (&optional mailbox buffer) |
1383 |
"Get ACL on mailbox from server in BUFFER." |
"Get ACL on mailbox from server in BUFFER." |
1384 |
(let ((mailbox (imap-utf7-encode mailbox))) |
(let ((mailbox (imap-utf7-encode mailbox))) |
1430 |
(mapconcat |
(mapconcat |
1431 |
(lambda (item) |
(lambda (item) |
1432 |
(if (consp item) |
(if (consp item) |
1433 |
(format "%d:%d" |
(format "%d:%d" |
1434 |
(car item) (cdr item)) |
(car item) (cdr item)) |
1435 |
(format "%d" item))) |
(format "%d" item))) |
1436 |
(if (and (listp range) (not (listp (cdr range)))) |
(if (and (listp range) (not (listp (cdr range)))) |
1437 |
(list range) ;; make (1 . 2) into ((1 . 2)) |
(list range) ;; make (1 . 2) into ((1 . 2)) |
1542 |
(imap-mailbox-put 'search 'dummy) |
(imap-mailbox-put 'search 'dummy) |
1543 |
(when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) |
(when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) |
1544 |
(if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) |
(if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) |
1545 |
(error "Missing SEARCH response to a SEARCH command") |
(progn |
1546 |
|
(message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") |
1547 |
|
nil) |
1548 |
(imap-mailbox-get-1 'search imap-current-mailbox))))) |
(imap-mailbox-get-1 'search imap-current-mailbox))))) |
1549 |
|
|
1550 |
(defun imap-message-flag-permanent-p (flag &optional mailbox buffer) |
(defun imap-message-flag-permanent-p (flag &optional mailbox buffer) |
1610 |
(if (imap-ok-p (imap-send-command-wait cmd)) |
(if (imap-ok-p (imap-send-command-wait cmd)) |
1611 |
t |
t |
1612 |
(when (and (not dont-create) |
(when (and (not dont-create) |
1613 |
(imap-mailbox-get-1 'trycreate mailbox)) |
;; removed because of buggy Oracle server |
1614 |
(imap-mailbox-create-1 mailbox) |
;; that doesn't send TRYCREATE tags (which |
1615 |
|
;; is a MUST according to specifications): |
1616 |
|
;;(imap-mailbox-get-1 'trycreate mailbox) |
1617 |
|
(imap-mailbox-create-1 mailbox)) |
1618 |
(imap-ok-p (imap-send-command-wait cmd))))) |
(imap-ok-p (imap-send-command-wait cmd))))) |
1619 |
(or no-copyuid |
(or no-copyuid |
1620 |
(imap-message-copyuid-1 mailbox))))))) |
(imap-message-copyuid-1 mailbox))))))) |
1679 |
|
|
1680 |
;; Internal functions. |
;; Internal functions. |
1681 |
|
|
1682 |
|
(defun imap-add-callback (tag func) |
1683 |
|
(setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) |
1684 |
|
|
1685 |
(defun imap-send-command-1 (cmdstr) |
(defun imap-send-command-1 (cmdstr) |
1686 |
(setq cmdstr (concat cmdstr imap-client-eol)) |
(setq cmdstr (concat cmdstr imap-client-eol)) |
1687 |
(and imap-log |
(and imap-log |
1688 |
(with-current-buffer (get-buffer-create imap-log) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
1689 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
1690 |
(buffer-disable-undo) |
(buffer-disable-undo) |
1691 |
(goto-char (point-max)) |
(goto-char (point-max)) |
1722 |
(imap-send-command-1 cmdstr) |
(imap-send-command-1 cmdstr) |
1723 |
(setq cmdstr nil) |
(setq cmdstr nil) |
1724 |
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) |
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) |
1725 |
(setq command nil);; abort command if no cont-req |
(setq command nil) ;; abort command if no cont-req |
1726 |
(let ((process imap-process) |
(let ((process imap-process) |
1727 |
(stream imap-stream) |
(stream imap-stream) |
1728 |
(eol imap-client-eol)) |
(eol imap-client-eol)) |
1729 |
(with-current-buffer cmd |
(with-current-buffer cmd |
1730 |
(and imap-log |
(and imap-log |
1731 |
(with-current-buffer (get-buffer-create |
(with-current-buffer (get-buffer-create |
1732 |
imap-log) |
imap-log-buffer) |
1733 |
(imap-disable-multibyte) |
(imap-disable-multibyte) |
1734 |
(buffer-disable-undo) |
(buffer-disable-undo) |
1735 |
(goto-char (point-max)) |
(goto-char (point-max)) |
1743 |
(setq cmdstr nil) |
(setq cmdstr nil) |
1744 |
(unwind-protect |
(unwind-protect |
1745 |
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) |
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) |
1746 |
(setq command nil);; abort command if no cont-req |
(setq command nil) ;; abort command if no cont-req |
1747 |
(setq command (cons (funcall cmd imap-continuation) |
(setq command (cons (funcall cmd imap-continuation) |
1748 |
command))) |
command))) |
1749 |
(setq imap-continuation nil))) |
(setq imap-continuation nil))) |
1755 |
|
|
1756 |
(defun imap-wait-for-tag (tag &optional buffer) |
(defun imap-wait-for-tag (tag &optional buffer) |
1757 |
(with-current-buffer (or buffer (current-buffer)) |
(with-current-buffer (or buffer (current-buffer)) |
1758 |
(while (and (null imap-continuation) |
(let (imap-have-messaged) |
1759 |
(< imap-reached-tag tag)) |
(while (and (null imap-continuation) |
1760 |
(or (and (not (memq (process-status imap-process) '(open run))) |
(memq (process-status imap-process) '(open run)) |
1761 |
(sit-for 1)) |
(< imap-reached-tag tag)) |
1762 |
(accept-process-output imap-process 1))) |
(let ((len (/ (point-max) 1024)) |
1763 |
(or (assq tag imap-failed-tags) |
message-log-max) |
1764 |
(if imap-continuation |
(unless (< len 10) |
1765 |
'INCOMPLETE |
(setq imap-have-messaged t) |
1766 |
'OK)))) |
(message "imap read: %dk" len)) |
1767 |
|
(accept-process-output imap-process |
1768 |
|
(truncate imap-read-timeout) |
1769 |
|
(truncate (* (- imap-read-timeout |
1770 |
|
(truncate imap-read-timeout)) |
1771 |
|
1000))))) |
1772 |
|
;; A process can die _before_ we have processed everything it |
1773 |
|
;; has to say. Moreover, this can happen in between the call to |
1774 |
|
;; accept-process-output and the call to process-status in an |
1775 |
|
;; iteration of the loop above. |
1776 |
|
(when (and (null imap-continuation) |
1777 |
|
(< imap-reached-tag tag)) |
1778 |
|
(accept-process-output imap-process 0 0)) |
1779 |
|
(when imap-have-messaged |
1780 |
|
(message "")) |
1781 |
|
(and (memq (process-status imap-process) '(open run)) |
1782 |
|
(or (assq tag imap-failed-tags) |
1783 |
|
(if imap-continuation |
1784 |
|
'INCOMPLETE |
1785 |
|
'OK)))))) |
1786 |
|
|
1787 |
(defun imap-sentinel (process string) |
(defun imap-sentinel (process string) |
1788 |
(delete-process process)) |
(delete-process process)) |
1802 |
|
|
1803 |
(defun imap-arrival-filter (proc string) |
(defun imap-arrival-filter (proc string) |
1804 |
"IMAP process filter." |
"IMAP process filter." |
1805 |
(with-current-buffer (process-buffer proc) |
;; Sometimes, we are called even though the process has died. |
1806 |
(goto-char (point-max)) |
;; Better abstain from doing stuff in that case. |
1807 |
(insert string) |
(when (buffer-name (process-buffer proc)) |
1808 |
(and imap-log |
(with-current-buffer (process-buffer proc) |
1809 |
(with-current-buffer (get-buffer-create imap-log) |
(goto-char (point-max)) |
1810 |
(imap-disable-multibyte) |
(insert string) |
1811 |
(buffer-disable-undo) |
(and imap-log |
1812 |
(goto-char (point-max)) |
(with-current-buffer (get-buffer-create imap-log-buffer) |
1813 |
(insert string))) |
(imap-disable-multibyte) |
1814 |
(let (end) |
(buffer-disable-undo) |
1815 |
(goto-char (point-min)) |
(goto-char (point-max)) |
1816 |
(while (setq end (imap-find-next-line)) |
(insert string))) |
1817 |
(save-restriction |
(let (end) |
1818 |
(narrow-to-region (point-min) end) |
(goto-char (point-min)) |
1819 |
(delete-backward-char (length imap-server-eol)) |
(while (setq end (imap-find-next-line)) |
1820 |
(goto-char (point-min)) |
(save-restriction |
1821 |
(unwind-protect |
(narrow-to-region (point-min) end) |
1822 |
(cond ((eq imap-state 'initial) |
(delete-backward-char (length imap-server-eol)) |
1823 |
(imap-parse-greeting)) |
(goto-char (point-min)) |
1824 |
((or (eq imap-state 'auth) |
(unwind-protect |
1825 |
(eq imap-state 'nonauth) |
(cond ((eq imap-state 'initial) |
1826 |
(eq imap-state 'selected) |
(imap-parse-greeting)) |
1827 |
(eq imap-state 'examine)) |
((or (eq imap-state 'auth) |
1828 |
(imap-parse-response)) |
(eq imap-state 'nonauth) |
1829 |
(t |
(eq imap-state 'selected) |
1830 |
(message "Unknown state %s in arrival filter" |
(eq imap-state 'examine)) |
1831 |
imap-state))) |
(imap-parse-response)) |
1832 |
(delete-region (point-min) (point-max)))))))) |
(t |
1833 |
|
(message "Unknown state %s in arrival filter" |
1834 |
|
imap-state))) |
1835 |
|
(delete-region (point-min) (point-max))))))))) |
1836 |
|
|
1837 |
|
|
1838 |
;; Imap parser. |
;; Imap parser. |
1977 |
(when (eq (char-after) ?\)) |
(when (eq (char-after) ?\)) |
1978 |
(imap-forward) |
(imap-forward) |
1979 |
(nreverse addresses))) |
(nreverse addresses))) |
1980 |
;; (assert (imap-parse-nil)) ; With assert, the code might not be eval'd. |
;; With assert, the code might not be eval'd. |
1981 |
|
;; (assert (imap-parse-nil) t "In imap-parse-address-list") |
1982 |
(imap-parse-nil))) |
(imap-parse-nil))) |
1983 |
|
|
1984 |
;; mailbox = "INBOX" / astring |
;; mailbox = "INBOX" / astring |
2032 |
;; resp-cond-bye = "BYE" SP resp-text |
;; resp-cond-bye = "BYE" SP resp-text |
2033 |
;; |
;; |
2034 |
;; mailbox-data = "FLAGS" SP flag-list / |
;; mailbox-data = "FLAGS" SP flag-list / |
2035 |
;; "LIST" SP mailbox-list / |
;; "LIST" SP mailbox-list / |
2036 |
;; "LSUB" SP mailbox-list / |
;; "LSUB" SP mailbox-list / |
2037 |
;; "SEARCH" *(SP nz-number) / |
;; "SEARCH" *(SP nz-number) / |
2038 |
;; "STATUS" SP mailbox SP "(" |
;; "STATUS" SP mailbox SP "(" |
2070 |
(read (concat "(" (buffer-substring (point) (point-max)) ")")))) |
(read (concat "(" (buffer-substring (point) (point-max)) ")")))) |
2071 |
(STATUS (imap-parse-status)) |
(STATUS (imap-parse-status)) |
2072 |
(CAPABILITY (setq imap-capability |
(CAPABILITY (setq imap-capability |
2073 |
(read (concat "(" (upcase (buffer-substring |
(read (concat "(" (upcase (buffer-substring |
2074 |
(point) (point-max))) |
(point) (point-max))) |
2075 |
")")))) |
")")))) |
2076 |
(ACL (imap-parse-acl)) |
(ACL (imap-parse-acl)) |
2077 |
(t (case (prog1 (read (current-buffer)) |
(t (case (prog1 (read (current-buffer)) |
2078 |
(imap-forward)) |
(imap-forward)) |
2114 |
(push (list token status code text) imap-failed-tags) |
(push (list token status code text) imap-failed-tags) |
2115 |
(error "Internal error, tag %s status %s code %s text %s" |
(error "Internal error, tag %s status %s code %s text %s" |
2116 |
token status code text)))) |
token status code text)))) |
2117 |
(t (message "Garbage: %s" (buffer-string)))))))))) |
(t (message "Garbage: %s" (buffer-string)))) |
2118 |
|
(when (assq token imap-callbacks) |
2119 |
|
(funcall (cdr (assq token imap-callbacks)) token status) |
2120 |
|
(setq imap-callbacks |
2121 |
|
(imap-remassoc token imap-callbacks))))))))) |
2122 |
|
|
2123 |
;; resp-text = ["[" resp-text-code "]" SP] text |
;; resp-text = ["[" resp-text-code "]" SP] text |
2124 |
;; |
;; |
2137 |
;; [flag-perm *(SP flag-perm)] ")" / |
;; [flag-perm *(SP flag-perm)] ")" / |
2138 |
;; "READ-ONLY" / |
;; "READ-ONLY" / |
2139 |
;; "READ-WRITE" / |
;; "READ-WRITE" / |
2140 |
;; "TRYCREATE" / |
;; "TRYCREATE" / |
2141 |
;; "UIDNEXT" SP nz-number / |
;; "UIDNEXT" SP nz-number / |
2142 |
;; "UIDVALIDITY" SP nz-number / |
;; "UIDVALIDITY" SP nz-number / |
2143 |
;; "UNSEEN" SP nz-number / |
;; "UNSEEN" SP nz-number / |
2184 |
;; resp-text-atom = 1*<any ATOM-CHAR except "]"> |
;; resp-text-atom = 1*<any ATOM-CHAR except "]"> |
2185 |
|
|
2186 |
(defun imap-parse-resp-text-code () |
(defun imap-parse-resp-text-code () |
2187 |
|
;; xxx next line for stalker communigate pro 3.3.1 bug |
2188 |
|
(when (looking-at " \\[") |
2189 |
|
(imap-forward)) |
2190 |
(when (eq (char-after) ?\[) |
(when (eq (char-after) ?\[) |
2191 |
(imap-forward) |
(imap-forward) |
2192 |
(cond ((search-forward "PERMANENTFLAGS " nil t) |
(cond ((search-forward "PERMANENTFLAGS " nil t) |
2193 |
(imap-mailbox-put 'permanentflags (imap-parse-flag-list))) |
(imap-mailbox-put 'permanentflags (imap-parse-flag-list))) |
2194 |
((search-forward "UIDNEXT " nil t) |
((search-forward "UIDNEXT \\([0-9]+\\)" nil t) |
2195 |
(imap-mailbox-put 'uidnext (read (current-buffer)))) |
(imap-mailbox-put 'uidnext (match-string 1))) |
2196 |
((search-forward "UNSEEN " nil t) |
((search-forward "UNSEEN " nil t) |
2197 |
(imap-mailbox-put 'unseen (read (current-buffer)))) |
(imap-mailbox-put 'first-unseen (read (current-buffer)))) |
2198 |
((looking-at "UIDVALIDITY \\([0-9]+\\)") |
((looking-at "UIDVALIDITY \\([0-9]+\\)") |
2199 |
(imap-mailbox-put 'uidvalidity (match-string 1))) |
(imap-mailbox-put 'uidvalidity (match-string 1))) |
2200 |
((search-forward "READ-ONLY" nil t) |
((search-forward "READ-ONLY" nil t) |
2293 |
(defun imap-parse-fetch (response) |
(defun imap-parse-fetch (response) |
2294 |
(when (eq (char-after) ?\() |
(when (eq (char-after) ?\() |
2295 |
(let (uid flags envelope internaldate rfc822 rfc822header rfc822text |
(let (uid flags envelope internaldate rfc822 rfc822header rfc822text |
2296 |
rfc822size body bodydetail bodystructure) |
rfc822size body bodydetail bodystructure flags-empty) |
2297 |
(while (not (eq (char-after) ?\))) |
(while (not (eq (char-after) ?\))) |
2298 |
(imap-forward) |
(imap-forward) |
2299 |
(let ((token (read (current-buffer)))) |
(let ((token (read (current-buffer)))) |
2300 |
(imap-forward) |
(imap-forward) |
2301 |
(cond ((eq token 'UID) |
(cond ((eq token 'UID) |
2302 |
(setq uid (ignore-errors (read (current-buffer))))) |
(setq uid (condition-case () |
2303 |
|
(read (current-buffer)) |
2304 |
|
(error)))) |
2305 |
((eq token 'FLAGS) |
((eq token 'FLAGS) |
2306 |
(setq flags (imap-parse-flag-list))) |
(setq flags (imap-parse-flag-list)) |
2307 |
|
(if (not flags) |
2308 |
|
(setq flags-empty 't))) |
2309 |
((eq token 'ENVELOPE) |
((eq token 'ENVELOPE) |
2310 |
(setq envelope (imap-parse-envelope))) |
(setq envelope (imap-parse-envelope))) |
2311 |
((eq token 'INTERNALDATE) |
((eq token 'INTERNALDATE) |
2334 |
(when uid |
(when uid |
2335 |
(setq imap-current-message uid) |
(setq imap-current-message uid) |
2336 |
(imap-message-put uid 'UID uid) |
(imap-message-put uid 'UID uid) |
2337 |
(and flags (imap-message-put uid 'FLAGS flags)) |
(and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) |
2338 |
(and envelope (imap-message-put uid 'ENVELOPE envelope)) |
(and envelope (imap-message-put uid 'ENVELOPE envelope)) |
2339 |
(and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) |
(and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) |
2340 |
(and rfc822 (imap-message-put uid 'RFC822 rfc822)) |
(and rfc822 (imap-message-put uid 'RFC822 rfc822)) |
2357 |
|
|
2358 |
(defun imap-parse-status () |
(defun imap-parse-status () |
2359 |
(let ((mailbox (imap-parse-mailbox))) |
(let ((mailbox (imap-parse-mailbox))) |
2360 |
(when (and mailbox (search-forward "(" nil t)) |
(if (eq (char-after) ? ) |
2361 |
(while (not (eq (char-after) ?\))) |
(forward-char)) |
2362 |
(let ((token (read (current-buffer)))) |
(when (and mailbox (eq (char-after) ?\()) |
2363 |
(cond ((eq token 'MESSAGES) |
(while (and (not (eq (char-after) ?\))) |
2364 |
|
(or (forward-char) t) |
2365 |
|
(looking-at "\\([A-Za-z]+\\) ")) |
2366 |
|
(let ((token (match-string 1))) |
2367 |
|
(goto-char (match-end 0)) |
2368 |
|
(cond ((string= token "MESSAGES") |
2369 |
(imap-mailbox-put 'messages (read (current-buffer)) mailbox)) |
(imap-mailbox-put 'messages (read (current-buffer)) mailbox)) |
2370 |
((eq token 'RECENT) |
((string= token "RECENT") |
2371 |
(imap-mailbox-put 'recent (read (current-buffer)) mailbox)) |
(imap-mailbox-put 'recent (read (current-buffer)) mailbox)) |
2372 |
((eq token 'UIDNEXT) |
((string= token "UIDNEXT") |
2373 |
(imap-mailbox-put 'uidnext (read (current-buffer)) mailbox)) |
(and (looking-at "[0-9]+") |
2374 |
((eq token 'UIDVALIDITY) |
(imap-mailbox-put 'uidnext (match-string 0) mailbox) |
2375 |
(and (looking-at " \\([0-9]+\\)") |
(goto-char (match-end 0)))) |
2376 |
(imap-mailbox-put 'uidvalidity (match-string 1) mailbox) |
((string= token "UIDVALIDITY") |
2377 |
(goto-char (match-end 1)))) |
(and (looking-at "[0-9]+") |
2378 |
((eq token 'UNSEEN) |
(imap-mailbox-put 'uidvalidity (match-string 0) mailbox) |
2379 |
|
(goto-char (match-end 0)))) |
2380 |
|
((string= token "UNSEEN") |
2381 |
(imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) |
(imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) |
2382 |
(t |
(t |
2383 |
(message "Unknown status data %s in mailbox %s ignored" |
(message "Unknown status data %s in mailbox %s ignored" |
2384 |
token mailbox)))))))) |
token mailbox) |
2385 |
|
(read (current-buffer))))))))) |
2386 |
|
|
2387 |
;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE |
;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE |
2388 |
;; rights) |
;; rights) |
2420 |
|
|
2421 |
(defun imap-parse-flag-list () |
(defun imap-parse-flag-list () |
2422 |
(let (flag-list start) |
(let (flag-list start) |
2423 |
(assert (eq (char-after) ?\()) |
(assert (eq (char-after) ?\() t "In imap-parse-flag-list") |
2424 |
(while (and (not (eq (char-after) ?\))) |
(while (and (not (eq (char-after) ?\))) |
2425 |
(setq start (progn (imap-forward) (point))) |
(setq start (progn |
2426 |
|
(imap-forward) |
2427 |
|
;; next line for Courier IMAP bug. |
2428 |
|
(skip-chars-forward " ") |
2429 |
|
(point))) |
2430 |
(> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) |
(> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) |
2431 |
(push (buffer-substring start (point)) flag-list)) |
(push (buffer-substring start (point)) flag-list)) |
2432 |
(assert (eq (char-after) ?\))) |
(assert (eq (char-after) ?\)) t "In imap-parse-flag-list") |
2433 |
(imap-forward) |
(imap-forward) |
2434 |
(nreverse flag-list))) |
(nreverse flag-list))) |
2435 |
|
|
2460 |
(defun imap-parse-envelope () |
(defun imap-parse-envelope () |
2461 |
(when (eq (char-after) ?\() |
(when (eq (char-after) ?\() |
2462 |
(imap-forward) |
(imap-forward) |
2463 |
(vector (prog1 (imap-parse-nstring);; date |
(vector (prog1 (imap-parse-nstring) ;; date |
2464 |
(imap-forward)) |
(imap-forward)) |
2465 |
(prog1 (imap-parse-nstring);; subject |
(prog1 (imap-parse-nstring) ;; subject |
2466 |
(imap-forward)) |
(imap-forward)) |
2467 |
(prog1 (imap-parse-address-list);; from |
(prog1 (imap-parse-address-list) ;; from |
2468 |
(imap-forward)) |
(imap-forward)) |
2469 |
(prog1 (imap-parse-address-list);; sender |
(prog1 (imap-parse-address-list) ;; sender |
2470 |
(imap-forward)) |
(imap-forward)) |
2471 |
(prog1 (imap-parse-address-list);; reply-to |
(prog1 (imap-parse-address-list) ;; reply-to |
2472 |
(imap-forward)) |
(imap-forward)) |
2473 |
(prog1 (imap-parse-address-list);; to |
(prog1 (imap-parse-address-list) ;; to |
2474 |
(imap-forward)) |
(imap-forward)) |
2475 |
(prog1 (imap-parse-address-list);; cc |
(prog1 (imap-parse-address-list) ;; cc |
2476 |
(imap-forward)) |
(imap-forward)) |
2477 |
(prog1 (imap-parse-address-list);; bcc |
(prog1 (imap-parse-address-list) ;; bcc |
2478 |
(imap-forward)) |
(imap-forward)) |
2479 |
(prog1 (imap-parse-nstring);; in-reply-to |
(prog1 (imap-parse-nstring) ;; in-reply-to |
2480 |
(imap-forward)) |
(imap-forward)) |
2481 |
(prog1 (imap-parse-nstring);; message-id |
(prog1 (imap-parse-nstring) ;; message-id |
2482 |
(imap-forward))))) |
(imap-forward))))) |
2483 |
|
|
2484 |
;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil |
;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil |
2485 |
|
|
2486 |
(defsubst imap-parse-string-list () |
(defsubst imap-parse-string-list () |
2487 |
(cond ((eq (char-after) ?\();; body-fld-param |
(cond ((eq (char-after) ?\() ;; body-fld-param |
2488 |
(let (strlist str) |
(let (strlist str) |
2489 |
(imap-forward) |
(imap-forward) |
2490 |
(while (setq str (imap-parse-string)) |
(while (setq str (imap-parse-string)) |
2514 |
(while (eq (char-after) ?\ ) |
(while (eq (char-after) ?\ ) |
2515 |
(imap-forward) |
(imap-forward) |
2516 |
(push (imap-parse-body-extension) b-e)) |
(push (imap-parse-body-extension) b-e)) |
2517 |
(assert (eq (char-after) ?\))) |
(assert (eq (char-after) ?\)) t "In imap-parse-body-extension") |
2518 |
(imap-forward) |
(imap-forward) |
2519 |
(nreverse b-e)) |
(nreverse b-e)) |
2520 |
(or (imap-parse-number) |
(or (imap-parse-number) |
2532 |
|
|
2533 |
(defsubst imap-parse-body-ext () |
(defsubst imap-parse-body-ext () |
2534 |
(let (ext) |
(let (ext) |
2535 |
(when (eq (char-after) ?\ );; body-fld-dsp |
(when (eq (char-after) ?\ ) ;; body-fld-dsp |
2536 |
(imap-forward) |
(imap-forward) |
2537 |
(let (dsp) |
(let (dsp) |
2538 |
(if (eq (char-after) ?\() |
(if (eq (char-after) ?\() |
2542 |
(imap-forward) |
(imap-forward) |
2543 |
(push (imap-parse-string-list) dsp) |
(push (imap-parse-string-list) dsp) |
2544 |
(imap-forward)) |
(imap-forward)) |
2545 |
;; (assert (imap-parse-nil)) ; Code in assert might not be eval'd. |
;; With assert, the code might not be eval'd. |
2546 |
|
;; (assert (imap-parse-nil) t "In imap-parse-body-ext") |
2547 |
(imap-parse-nil)) |
(imap-parse-nil)) |
2548 |
(push (nreverse dsp) ext)) |
(push (nreverse dsp) ext)) |
2549 |
(when (eq (char-after) ?\ );; body-fld-lang |
(when (eq (char-after) ?\ ) ;; body-fld-lang |
2550 |
(imap-forward) |
(imap-forward) |
2551 |
(if (eq (char-after) ?\() |
(if (eq (char-after) ?\() |
2552 |
(push (imap-parse-string-list) ext) |
(push (imap-parse-string-list) ext) |
2553 |
(push (imap-parse-nstring) ext)) |
(push (imap-parse-nstring) ext)) |
2554 |
(while (eq (char-after) ?\ );; body-extension |
(while (eq (char-after) ?\ ) ;; body-extension |
2555 |
(imap-forward) |
(imap-forward) |
2556 |
(setq ext (append (imap-parse-body-extension) ext))))) |
(setq ext (append (imap-parse-body-extension) ext))))) |
2557 |
ext)) |
ext)) |
2625 |
(let (subbody) |
(let (subbody) |
2626 |
(while (and (eq (char-after) ?\() |
(while (and (eq (char-after) ?\() |
2627 |
(setq subbody (imap-parse-body))) |
(setq subbody (imap-parse-body))) |
2628 |
;; buggy stalker communigate pro 3.0 insert a SPC between |
;; buggy stalker communigate pro 3.0 insert a SPC between |
2629 |
;; parts in multiparts |
;; parts in multiparts |
2630 |
(when (and (eq (char-after) ?\ ) |
(when (and (eq (char-after) ?\ ) |
2631 |
(eq (char-after (1+ (point))) ?\()) |
(eq (char-after (1+ (point))) ?\()) |
2632 |
(imap-forward)) |
(imap-forward)) |
2633 |
(push subbody body)) |
(push subbody body)) |
2634 |
(imap-forward) |
(imap-forward) |
2635 |
(push (imap-parse-string) body);; media-subtype |
(push (imap-parse-string) body) ;; media-subtype |
2636 |
(when (eq (char-after) ?\ );; body-ext-mpart: |
(when (eq (char-after) ?\ ) ;; body-ext-mpart: |
2637 |
(imap-forward) |
(imap-forward) |
2638 |
(if (eq (char-after) ?\();; body-fld-param |
(if (eq (char-after) ?\() ;; body-fld-param |
2639 |
(push (imap-parse-string-list) body) |
(push (imap-parse-string-list) body) |
2640 |
(push (and (imap-parse-nil) nil) body)) |
(push (and (imap-parse-nil) nil) body)) |
2641 |
(setq body |
(setq body |
2642 |
(append (imap-parse-body-ext) body)));; body-ext-... |
(append (imap-parse-body-ext) body))) ;; body-ext-... |
2643 |
(assert (eq (char-after) ?\))) |
(assert (eq (char-after) ?\)) t "In imap-parse-body") |
2644 |
(imap-forward) |
(imap-forward) |
2645 |
(nreverse body)) |
(nreverse body)) |
2646 |
|
|
2647 |
(push (imap-parse-string) body);; media-type |
(push (imap-parse-string) body) ;; media-type |
2648 |
(imap-forward) |
(imap-forward) |
2649 |
(push (imap-parse-string) body);; media-subtype |
(push (imap-parse-string) body) ;; media-subtype |
2650 |
(imap-forward) |
(imap-forward) |
2651 |
;; next line for Sun SIMS bug |
;; next line for Sun SIMS bug |
2652 |
(and (eq (char-after) ? ) (imap-forward)) |
(and (eq (char-after) ? ) (imap-forward)) |
2653 |
(if (eq (char-after) ?\();; body-fld-param |
(if (eq (char-after) ?\() ;; body-fld-param |
2654 |
(push (imap-parse-string-list) body) |
(push (imap-parse-string-list) body) |
2655 |
(push (and (imap-parse-nil) nil) body)) |
(push (and (imap-parse-nil) nil) body)) |
2656 |
(imap-forward) |
(imap-forward) |
2657 |
(push (imap-parse-nstring) body);; body-fld-id |
(push (imap-parse-nstring) body) ;; body-fld-id |
2658 |
(imap-forward) |
(imap-forward) |
2659 |
(push (imap-parse-nstring) body);; body-fld-desc |
(push (imap-parse-nstring) body) ;; body-fld-desc |
2660 |
(imap-forward) |
(imap-forward) |
2661 |
;; next `or' for Sun SIMS bug, it regard body-fld-enc as a |
;; next `or' for Sun SIMS bug, it regard body-fld-enc as a |
2662 |
;; nstring and return nil instead of defaulting back to 7BIT |
;; nstring and return nil instead of defaulting back to 7BIT |
2663 |
;; as the standard says. |
;; as the standard says. |
2664 |
(push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc |
(push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc |
2665 |
(imap-forward) |
(imap-forward) |
2666 |
(push (imap-parse-number) body);; body-fld-octets |
(push (imap-parse-number) body) ;; body-fld-octets |
2667 |
|
|
2668 |
;; ok, we're done parsing the required parts, what comes now is one |
;; ok, we're done parsing the required parts, what comes now is one |
2669 |
;; of three things: |
;; of three things: |
2670 |
;; |
;; |
2671 |
;; envelope (then we're parsing body-type-msg) |
;; envelope (then we're parsing body-type-msg) |
2672 |
;; body-fld-lines (then we're parsing body-type-text) |
;; body-fld-lines (then we're parsing body-type-text) |
2673 |
;; body-ext-1part (then we're parsing body-type-basic) |
;; body-ext-1part (then we're parsing body-type-basic) |
2674 |
;; |
;; |
2675 |
;; the problem is that the two first are in turn optionally followed |
;; the problem is that the two first are in turn optionally followed |
2676 |
;; by the third. So we parse the first two here (if there are any)... |
;; by the third. So we parse the first two here (if there are any)... |
2677 |
|
|
2678 |
(when (eq (char-after) ?\ ) |
(when (eq (char-after) ?\ ) |
2679 |
(imap-forward) |
(imap-forward) |
2680 |
(let (lines) |
(let (lines) |
2681 |
(cond ((eq (char-after) ?\();; body-type-msg: |
(cond ((eq (char-after) ?\() ;; body-type-msg: |
2682 |
(push (imap-parse-envelope) body);; envelope |
(push (imap-parse-envelope) body) ;; envelope |
2683 |
(imap-forward) |
(imap-forward) |
2684 |
(push (imap-parse-body) body);; body |
(push (imap-parse-body) body) ;; body |
2685 |
;; buggy stalker communigate pro 3.0 doesn't print |
;; buggy stalker communigate pro 3.0 doesn't print |
2686 |
;; number of lines in message/rfc822 attachment |
;; number of lines in message/rfc822 attachment |
2687 |
(if (eq (char-after) ?\)) |
(if (eq (char-after) ?\)) |
2688 |
(push 0 body) |
(push 0 body) |
2689 |
(imap-forward) |
(imap-forward) |
2690 |
(push (imap-parse-number) body))) ;; body-fld-lines |
(push (imap-parse-number) body))) ;; body-fld-lines |
2691 |
((setq lines (imap-parse-number)) ;; body-type-text: |
((setq lines (imap-parse-number)) ;; body-type-text: |
2692 |
(push lines body)) ;; body-fld-lines |
(push lines body)) ;; body-fld-lines |
2693 |
(t |
(t |
2694 |
(backward-char))))) ;; no match... |
(backward-char))))) ;; no match... |
2695 |
|
|
2696 |
;; ...and then parse the third one here... |
;; ...and then parse the third one here... |
2697 |
|
|
2698 |
(when (eq (char-after) ?\ );; body-ext-1part: |
(when (eq (char-after) ?\ ) ;; body-ext-1part: |
2699 |
(imap-forward) |
(imap-forward) |
2700 |
(push (imap-parse-nstring) body);; body-fld-md5 |
(push (imap-parse-nstring) body) ;; body-fld-md5 |
2701 |
(setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. |
(setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. |
2702 |
|
|
2703 |
(assert (eq (char-after) ?\))) |
(assert (eq (char-after) ?\)) t "In imap-parse-body 2") |
2704 |
(imap-forward) |
(imap-forward) |
2705 |
(nreverse body))))) |
(nreverse body))))) |
2706 |
|
|
2707 |
(when imap-debug ; (untrace-all) |
(when imap-debug ; (untrace-all) |
2708 |
(require 'trace) |
(require 'trace) |
2709 |
(buffer-disable-undo (get-buffer-create imap-debug)) |
(buffer-disable-undo (get-buffer-create imap-debug-buffer)) |
2710 |
(mapcar (lambda (f) (trace-function-background f imap-debug)) |
(mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) |
2711 |
'( |
'( |
|
imap-read-passwd |
|
2712 |
imap-utf7-encode |
imap-utf7-encode |
2713 |
imap-utf7-decode |
imap-utf7-decode |
2714 |
imap-error-text |
imap-error-text |