git.chise.org Git - elisp/gnus.git-/blob - lisp/imap.el

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