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