cgit.sxemacs.org Git - gnus/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-and-compile
 142   (autoload 'base64-decode-string "base64")
 143   (autoload 'base64-encode-string "base64")
 144   (autoload 'starttls-open-stream "starttls")
 145   (autoload 'starttls-negotiate "starttls")
 146   (autoload 'digest-md5-parse-digest-challenge "digest-md5")
 147   (autoload 'digest-md5-digest-response "digest-md5")
 148   (autoload 'digest-md5-digest-uri "digest-md5")
 149   (autoload 'digest-md5-challenge "digest-md5")
 150   (autoload 'rfc2104-hash "rfc2104")
 151   (autoload 'md5 "md5")
 152   (autoload 'utf7-encode "utf7")
 153   (autoload 'utf7-decode "utf7")
 154   (autoload 'format-spec "format-spec")
 155   (autoload 'format-spec-make "format-spec")
 156   (autoload 'open-tls-stream "tls")
 157   ;; Avoid use gnus-point-at-eol so we're independent of Gnus.  These
 158   ;; days we have point-at-eol anyhow.
 159   (if (fboundp 'point-at-eol)
 160       (defalias 'imap-point-at-eol 'point-at-eol)
 161     (defun imap-point-at-eol ()
 162       (save-excursion
 163         (end-of-line)
 164         (point)))))
 165
 166 ;; User variables.
 167
 168 (defgroup imap nil
 169   "Low-level IMAP issues."
 170   :version "21.1"
 171   :group 'mail)
 172
 173 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 174                                     "imtest -kp %s %p")
 175   "List of strings containing commands for Kerberos 4 authentication.
 176 %s is replaced with server hostname, %p with port to connect to, and
 177 %l with the value of `imap-default-user'.  The program should accept
 178 IMAP commands on stdin and return responses to stdout.  Each entry in
 179 the list is tried until a successful connection is made."
 180   :group 'imap
 181   :type '(repeat string))
 182
 183 (defcustom imap-gssapi-program (list
 184                                 (concat "gsasl --client --connect %s:%p "
 185                                         "--imap --application-data "
 186                                         "--mechanism GSSAPI "
 187                                         "--authentication-id %l")
 188                                 "imtest -m gssapi -u %l -p %p %s")
 189   "List of strings containing commands for GSSAPI (krb5) authentication.
 190 %s is replaced with server hostname, %p with port to connect to, and
 191 %l with the value of `imap-default-user'.  The program should accept
 192 IMAP commands on stdin and return responses to stdout.  Each entry in
 193 the list is tried until a successful connection is made."
 194   :group 'imap
 195   :type '(repeat string))
 196
 197 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 198                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 199                               "s_client -quiet -ssl3 -connect %s:%p"
 200                               "s_client -quiet -ssl2 -connect %s:%p")
 201   "A string, or list of strings, containing commands for SSL connections.
 202 Within a string, %s is replaced with the server address and %p with
 203 port number on server.  The program should accept IMAP commands on
 204 stdin and return responses to stdout.  Each entry in the list is tried
 205 until a successful connection is made."
 206   :group 'imap
 207   :type '(choice string
 208                  (repeat string)))
 209
 210 (defcustom imap-shell-program '("ssh %s imapd"
 211                                 "rsh %s imapd"
 212                                 "ssh %g ssh %s imapd"
 213                                 "rsh %g rsh %s imapd")
 214   "A list of strings, containing commands for IMAP connection.
 215 Within a string, %s is replaced with the server address, %p with port
 216 number on server, %g with `imap-shell-host', and %l with
 217 `imap-default-user'.  The program should read IMAP commands from stdin
 218 and write IMAP response to stdout. Each entry in the list is tried
 219 until a successful connection is made."
 220   :group 'imap
 221   :type '(repeat string))
 222
 223 (defcustom imap-process-connection-type nil
 224   "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
 225 The `process-connection-type' variable control type of device
 226 used to communicate with subprocesses.  Values are nil to use a
 227 pipe, or t or `pty' to use a pty.  The value has no effect if the
 228 system has no ptys or if all ptys are busy: then a pipe is used
 229 in any case.  The value takes effect when a IMAP server is
 230 opened, changing it after that has no effect.."
 231   :group 'imap
 232   :type 'boolean)
 233
 234 (defcustom imap-use-utf7 t
 235   "If non-nil, do utf7 encoding/decoding of mailbox names.
 236 Since the UTF7 decoding currently only decodes into ISO-8859-1
 237 characters, you may disable this decoding if you need to access UTF7
 238 encoded mailboxes which doesn't translate into ISO-8859-1."
 239   :group 'imap
 240   :type 'boolean)
 241
 242 (defcustom imap-log nil
 243   "If non-nil, a imap session trace is placed in *imap-log* buffer."
 244   :group 'imap
 245   :type 'boolean)
 246
 247 (defcustom imap-debug nil
 248   "If non-nil, random debug spews are placed in *imap-debug* buffer."
 249   :group 'imap
 250   :type 'boolean)
 251
 252 (defcustom imap-shell-host "gateway"
 253   "Hostname of rlogin proxy."
 254   :group 'imap
 255   :type 'string)
 256
 257 (defcustom imap-default-user (user-login-name)
 258   "Default username to use."
 259   :group 'imap
 260   :type 'string)
 261
 262 (defcustom imap-read-timeout (if (string-match
 263                                   "windows-nt\\|os/2\\|emx\\|cygwin"
 264                                   (symbol-name system-type))
 265                                  1.0
 266                                0.1)
 267   "*How long to wait between checking for the end of output.
 268 Shorter values mean quicker response, but is more CPU intensive."
 269   :type 'number
 270   :group 'imap)
 271
 272 ;; Various variables.
 273
 274 (defvar imap-fetch-data-hook nil
 275   "Hooks called after receiving each FETCH response.")
 276
 277 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 278   "Priority of streams to consider when opening connection to server.")
 279
 280 (defvar imap-stream-alist
 281   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 282     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 283     (tls       imap-tls-p              imap-tls-open)
 284     (ssl       imap-ssl-p              imap-ssl-open)
 285     (network   imap-network-p          imap-network-open)
 286     (shell     imap-shell-p            imap-shell-open)
 287     (starttls  imap-starttls-p         imap-starttls-open))
 288   "Definition of network streams.
 289
 290 \(NAME CHECK OPEN)
 291
 292 NAME names the stream, CHECK is a function returning non-nil if the
 293 server support the stream and OPEN is a function for opening the
 294 stream.")
 295
 296 (defvar imap-authenticators '(gssapi
 297                               kerberos4
 298                               digest-md5
 299                               cram-md5
 300                               login
 301                               anonymous)
 302   "Priority of authenticators to consider when authenticating to server.")
 303
 304 (defvar imap-authenticator-alist
 305   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 306     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 307     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 308     (login      imap-login-p          imap-login-auth)
 309     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 310     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 311   "Definition of authenticators.
 312
 313 \(NAME CHECK AUTHENTICATE)
 314
 315 NAME names the authenticator.  CHECK is a function returning non-nil if
 316 the server support the authenticator and AUTHENTICATE is a function
 317 for doing the actual authentication.")
 318
 319 (defvar imap-error nil
 320   "Error codes from the last command.")
 321
 322 ;; Internal constants.  Change theese and die.
 323
 324 (defconst imap-default-port 143)
 325 (defconst imap-default-ssl-port 993)
 326 (defconst imap-default-tls-port 993)
 327 (defconst imap-default-stream 'network)
 328 (defconst imap-coding-system-for-read 'binary)
 329 (defconst imap-coding-system-for-write 'binary)
 330 (defconst imap-local-variables '(imap-server
 331                                  imap-port
 332                                  imap-client-eol
 333                                  imap-server-eol
 334                                  imap-auth
 335                                  imap-stream
 336                                  imap-username
 337                                  imap-password
 338                                  imap-current-mailbox
 339                                  imap-current-target-mailbox
 340                                  imap-message-data
 341                                  imap-capability
 342                                  imap-namespace
 343                                  imap-state
 344                                  imap-reached-tag
 345                                  imap-failed-tags
 346                                  imap-tag
 347                                  imap-process
 348                                  imap-calculate-literal-size-first
 349                                  imap-mailbox-data))
 350 (defconst imap-log-buffer "*imap-log*")
 351 (defconst imap-debug-buffer "*imap-debug*")
 352
 353 ;; Internal variables.
 354
 355 (defvar imap-stream nil)
 356 (defvar imap-auth nil)
 357 (defvar imap-server nil)
 358 (defvar imap-port nil)
 359 (defvar imap-username nil)
 360 (defvar imap-password nil)
 361 (defvar imap-calculate-literal-size-first nil)
 362 (defvar imap-state 'closed
 363   "IMAP state.
 364 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 365 and `examine'.")
 366
 367 (defvar imap-server-eol "\r\n"
 368   "The EOL string sent from the server.")
 369
 370 (defvar imap-client-eol "\r\n"
 371   "The EOL string we send to the server.")
 372
 373 (defvar imap-current-mailbox nil
 374   "Current mailbox name.")
 375
 376 (defvar imap-current-target-mailbox nil
 377   "Current target mailbox for COPY and APPEND commands.")
 378
 379 (defvar imap-mailbox-data nil
 380   "Obarray with mailbox data.")
 381
 382 (defvar imap-mailbox-prime 997
 383   "Length of imap-mailbox-data.")
 384
 385 (defvar imap-current-message nil
 386   "Current message number.")
 387
 388 (defvar imap-message-data nil
 389   "Obarray with message data.")
 390
 391 (defvar imap-message-prime 997
 392   "Length of imap-message-data.")
 393
 394 (defvar imap-capability nil
 395   "Capability for server.")
 396
 397 (defvar imap-namespace nil
 398   "Namespace for current server.")
 399
 400 (defvar imap-reached-tag 0
 401   "Lower limit on command tags that have been parsed.")
 402
 403 (defvar imap-failed-tags nil
 404   "Alist of tags that failed.
 405 Each element is a list with four elements; tag (a integer), response
 406 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 407 human readable response text (a string).")
 408
 409 (defvar imap-tag 0
 410   "Command tag number.")
 411
 412 (defvar imap-process nil
 413   "Process.")
 414
 415 (defvar imap-continuation nil
 416   "Non-nil indicates that the server emitted a continuation request.
 417 The actual value is really the text on the continuation line.")
 418
 419 (defvar imap-callbacks nil
 420   "List of response tags and callbacks, on the form `(number . function)'.
 421 The function should take two arguments, the first the IMAP tag and the
 422 second the status (OK, NO, BAD etc) of the command.")
 423
 424 \f
 425 ;; Utility functions:
 426
 427 (defun imap-remassoc (key alist)
 428   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
 429 The modified LIST is returned.  If the first member
 430 of LIST has a car that is `equal' to KEY, there is no way to remove it
 431 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 432 sure of changing the value of `foo'."
 433   (when alist
 434     (if (equal key (caar alist))
 435         (cdr alist)
 436       (setcdr alist (imap-remassoc key (cdr alist)))
 437       alist)))
 438
 439 (defsubst imap-disable-multibyte ()
 440   "Enable multibyte in the current buffer."
 441   (when (fboundp 'set-buffer-multibyte)
 442     (set-buffer-multibyte nil)))
 443
 444 (defsubst imap-utf7-encode (string)
 445   (if imap-use-utf7
 446       (and string
 447            (condition-case ()
 448                (utf7-encode string t)
 449              (error (message
 450                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 451                      string)
 452                     string)))
 453     string))
 454
 455 (defsubst imap-utf7-decode (string)
 456   (if imap-use-utf7
 457       (and string
 458            (condition-case ()
 459                (utf7-decode string t)
 460              (error (message
 461                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 462                      string)
 463                     string)))
 464     string))
 465
 466 (defsubst imap-ok-p (status)
 467   (if (eq status 'OK)
 468       t
 469     (setq imap-error status)
 470     nil))
 471
 472 (defun imap-error-text (&optional buffer)
 473   (with-current-buffer (or buffer (current-buffer))
 474     (nth 3 (car imap-failed-tags))))
 475
 476 \f
 477 ;; Server functions; stream stuff:
 478
 479 (defun imap-kerberos4-stream-p (buffer)
 480   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 481
 482 (defun imap-kerberos4-open (name buffer server port)
 483   (let ((cmds imap-kerberos4-program)
 484         cmd done)
 485     (while (and (not done) (setq cmd (pop cmds)))
 486       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 487       (erase-buffer)
 488       (let* ((port (or port imap-default-port))
 489              (coding-system-for-read imap-coding-system-for-read)
 490              (coding-system-for-write imap-coding-system-for-write)
 491              (process-connection-type imap-process-connection-type)
 492              (process (start-process
 493                        name buffer shell-file-name shell-command-switch
 494                        (format-spec
 495                         cmd
 496                         (format-spec-make
 497                          ?s server
 498                          ?p (number-to-string port)
 499                          ?l imap-default-user))))
 500              response)
 501         (when process
 502           (with-current-buffer buffer
 503             (setq imap-client-eol "\n"
 504                   imap-calculate-literal-size-first t)
 505             (while (and (memq (process-status process) '(open run))
 506                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 507                         (goto-char (point-min))
 508                         ;; Athena IMTEST can output SSL verify errors
 509                         (or (while (looking-at "^verify error:num=")
 510                               (forward-line))
 511                             t)
 512                         (or (while (looking-at "^TLS connection established")
 513                               (forward-line))
 514                             t)
 515                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 516                         (or (while (looking-at "^C:")
 517                               (forward-line))
 518                             t)
 519                         ;; cyrus 1.6 imtest print "S: " before server greeting
 520                         (or (not (looking-at "S: "))
 521                             (forward-char 3)
 522                             t)
 523                         (not (and (imap-parse-greeting)
 524                                   ;; success in imtest < 1.6:
 525                                   (or (re-search-forward
 526                                        "^__\\(.*\\)__\n" nil t)
 527                                       ;; success in imtest 1.6:
 528                                       (re-search-forward
 529                                        "^\\(Authenticat.*\\)" nil t))
 530                                   (setq response (match-string 1)))))
 531               (accept-process-output process 1)
 532               (sit-for 1))
 533             (and imap-log
 534                  (with-current-buffer (get-buffer-create imap-log-buffer)
 535                    (imap-disable-multibyte)
 536                    (buffer-disable-undo)
 537                    (goto-char (point-max))
 538                    (insert-buffer-substring buffer)))
 539             (erase-buffer)
 540             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 541                      (if response (concat "done, " response) "failed"))
 542             (if (and response (let ((case-fold-search nil))
 543                                 (not (string-match "failed" response))))
 544                 (setq done process)
 545               (if (memq (process-status process) '(open run))
 546                   (imap-send-command "LOGOUT"))
 547               (delete-process process)
 548               nil)))))
 549     done))
 550
 551 (defun imap-gssapi-stream-p (buffer)
 552   (imap-capability 'AUTH=GSSAPI buffer))
 553
 554 (defun imap-gssapi-open (name buffer server port)
 555   (let ((cmds imap-gssapi-program)
 556         cmd done)
 557     (while (and (not done) (setq cmd (pop cmds)))
 558       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 559       (erase-buffer)
 560       (let* ((port (or port imap-default-port))
 561              (coding-system-for-read imap-coding-system-for-read)
 562              (coding-system-for-write imap-coding-system-for-write)
 563              (process-connection-type imap-process-connection-type)
 564              (process (start-process
 565                        name buffer shell-file-name shell-command-switch
 566                        (format-spec
 567                         cmd
 568                         (format-spec-make
 569                          ?s server
 570                          ?p (number-to-string port)
 571                          ?l imap-default-user))))
 572              response)
 573         (when process
 574           (with-current-buffer buffer
 575             (setq imap-client-eol "\n"
 576                   imap-calculate-literal-size-first t)
 577             (while (and (memq (process-status process) '(open run))
 578                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 579                         (goto-char (point-min))
 580                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 581                         (or (while (looking-at "^C:")
 582                               (forward-line))
 583                             t)
 584                         ;; cyrus 1.6 imtest print "S: " before server greeting
 585                         (or (not (looking-at "S: "))
 586                             (forward-char 3)
 587                             t)
 588                         (not (and (imap-parse-greeting)
 589                                   ;; success in imtest 1.6:
 590                                   (re-search-forward
 591                                    (concat "^\\(\\(Authenticat.*\\)\\|\\("
 592                                            "Client authentication "
 593                                            "finished.*\\)\\)")
 594                                    nil t)
 595                                   (setq response (match-string 1)))))
 596               (accept-process-output process 1)
 597               (sit-for 1))
 598             (and imap-log
 599                  (with-current-buffer (get-buffer-create imap-log-buffer)
 600                    (imap-disable-multibyte)
 601                    (buffer-disable-undo)
 602                    (goto-char (point-max))
 603                    (insert-buffer-substring buffer)))
 604             (erase-buffer)
 605             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 606             (if (and response (let ((case-fold-search nil))
 607                                 (not (string-match "failed" response))))
 608                 (setq done process)
 609               (if (memq (process-status process) '(open run))
 610                   (imap-send-command "LOGOUT"))
 611               (delete-process process)
 612               nil)))))
 613     done))
 614
 615 (defun imap-ssl-p (buffer)
 616   nil)
 617
 618 (defun imap-ssl-open (name buffer server port)
 619   "Open a SSL connection to server."
 620   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 621                 (list imap-ssl-program)))
 622         cmd done)
 623     (while (and (not done) (setq cmd (pop cmds)))
 624       (message "imap: Opening SSL connection with `%s'..." cmd)
 625       (erase-buffer)
 626       (let* ((port (or port imap-default-ssl-port))
 627              (coding-system-for-read imap-coding-system-for-read)
 628              (coding-system-for-write imap-coding-system-for-write)
 629              (process-connection-type nil)
 630              process)
 631         (when (progn
 632                 (setq process (start-process
 633                                name buffer shell-file-name
 634                                shell-command-switch
 635                                (format-spec cmd
 636                                             (format-spec-make
 637                                              ?s server
 638                                              ?p (number-to-string port)))))
 639                 (process-kill-without-query process)
 640                 process)
 641           (with-current-buffer buffer
 642             (goto-char (point-min))
 643             (while (and (memq (process-status process) '(open run))
 644                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 645                         (goto-char (point-max))
 646                         (forward-line -1)
 647                         (not (imap-parse-greeting)))
 648               (accept-process-output process 1)
 649               (sit-for 1))
 650             (and imap-log
 651                  (with-current-buffer (get-buffer-create imap-log-buffer)
 652                    (imap-disable-multibyte)
 653                    (buffer-disable-undo)
 654                    (goto-char (point-max))
 655                    (insert-buffer-substring buffer)))
 656             (erase-buffer)
 657             (when (memq (process-status process) '(open run))
 658               (setq done process))))))
 659     (if done
 660         (progn
 661           (message "imap: Opening SSL connection with `%s'...done" cmd)
 662           done)
 663       (message "imap: Opening SSL connection with `%s'...failed" cmd)
 664       nil)))
 665
 666 (defun imap-tls-p (buffer)
 667   nil)
 668
 669 (defun imap-tls-open (name buffer server port)
 670   (let* ((port (or port imap-default-tls-port))
 671          (coding-system-for-read imap-coding-system-for-read)
 672          (coding-system-for-write imap-coding-system-for-write)
 673          (process (open-tls-stream name buffer server port)))
 674     (when process
 675       (while (and (memq (process-status process) '(open run))
 676                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 677                   (goto-char (point-max))
 678                   (forward-line -1)
 679                   (not (imap-parse-greeting)))
 680         (accept-process-output process 1)
 681         (sit-for 1))
 682       (and imap-log
 683            (with-current-buffer (get-buffer-create imap-log-buffer)
 684              (imap-disable-multibyte)
 685              (buffer-disable-undo)
 686              (goto-char (point-max))
 687              (insert-buffer-substring buffer)))
 688       (when (memq (process-status process) '(open run))
 689         process))))
 690
 691 (defun imap-network-p (buffer)
 692   t)
 693
 694 (defun imap-network-open (name buffer server port)
 695   (let* ((port (or port imap-default-port))
 696          (coding-system-for-read imap-coding-system-for-read)
 697          (coding-system-for-write imap-coding-system-for-write)
 698          (process (open-network-stream name buffer server port)))
 699     (when process
 700       (while (and (memq (process-status process) '(open run))
 701                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 702                   (goto-char (point-min))
 703                   (not (imap-parse-greeting)))
 704         (accept-process-output process 1)
 705         (sit-for 1))
 706       (and imap-log
 707            (with-current-buffer (get-buffer-create imap-log-buffer)
 708              (imap-disable-multibyte)
 709              (buffer-disable-undo)
 710              (goto-char (point-max))
 711              (insert-buffer-substring buffer)))
 712       (when (memq (process-status process) '(open run))
 713         process))))
 714
 715 (defun imap-shell-p (buffer)
 716   nil)
 717
 718 (defun imap-shell-open (name buffer server port)
 719   (let ((cmds (if (listp imap-shell-program) imap-shell-program
 720                 (list imap-shell-program)))
 721         cmd done)
 722     (while (and (not done) (setq cmd (pop cmds)))
 723       (message "imap: Opening IMAP connection with `%s'..." cmd)
 724       (setq imap-client-eol "\n")
 725       (let* ((port (or port imap-default-port))
 726              (coding-system-for-read imap-coding-system-for-read)
 727              (coding-system-for-write imap-coding-system-for-write)
 728              (process (start-process
 729                        name buffer shell-file-name shell-command-switch
 730                        (format-spec
 731                         cmd
 732                         (format-spec-make
 733                          ?s server
 734                          ?g imap-shell-host
 735                          ?p (number-to-string port)
 736                          ?l imap-default-user)))))
 737         (when process
 738           (while (and (memq (process-status process) '(open run))
 739                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 740                       (goto-char (point-max))
 741                       (forward-line -1)
 742                       (not (imap-parse-greeting)))
 743             (accept-process-output process 1)
 744             (sit-for 1))
 745           (and imap-log
 746                (with-current-buffer (get-buffer-create imap-log-buffer)
 747                  (imap-disable-multibyte)
 748                  (buffer-disable-undo)
 749                  (goto-char (point-max))
 750                  (insert-buffer-substring buffer)))
 751           (erase-buffer)
 752           (when (memq (process-status process) '(open run))
 753             (setq done process)))))
 754     (if done
 755         (progn
 756           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 757           done)
 758       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 759       nil)))
 760
 761 (defun imap-starttls-p (buffer)
 762   (imap-capability 'STARTTLS buffer))
 763
 764 (defun imap-starttls-open (name buffer server port)
 765   (let* ((port (or port imap-default-port))
 766          (coding-system-for-read imap-coding-system-for-read)
 767          (coding-system-for-write imap-coding-system-for-write)
 768          (process (starttls-open-stream name buffer server port))
 769          done tls-info)
 770     (message "imap: Connecting with STARTTLS...")
 771     (when process
 772       (while (and (memq (process-status process) '(open run))
 773                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 774                   (goto-char (point-max))
 775                   (forward-line -1)
 776                   (not (imap-parse-greeting)))
 777         (accept-process-output process 1)
 778         (sit-for 1))
 779       (imap-send-command "STARTTLS")
 780       (while (and (memq (process-status process) '(open run))
 781                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 782                   (goto-char (point-max))
 783                   (forward-line -1)
 784                   (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
 785         (accept-process-output process 1)
 786         (sit-for 1))
 787       (and imap-log
 788            (with-current-buffer (get-buffer-create imap-log-buffer)
 789              (buffer-disable-undo)
 790              (goto-char (point-max))
 791              (insert-buffer-substring buffer)))
 792       (when (and (setq tls-info (starttls-negotiate process))
 793                  (memq (process-status process) '(open run)))
 794         (setq done process)))
 795     (if (stringp tls-info)
 796         (message "imap: STARTTLS info: %s" tls-info))
 797     (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
 798     done))
 799
 800 ;; Server functions; authenticator stuff:
 801
 802 (defun imap-interactive-login (buffer loginfunc)
 803   "Login to server in BUFFER.
 804 LOGINFUNC is passed a username and a password, it should return t if
 805 it where successful authenticating itself to the server, nil otherwise.
 806 Returns t if login was successful, nil otherwise."
 807   (with-current-buffer buffer
 808     (make-local-variable 'imap-username)
 809     (make-local-variable 'imap-password)
 810     (let (user passwd ret)
 811       ;;      (condition-case ()
 812       (while (or (not user) (not passwd))
 813         (setq user (or imap-username
 814                        (read-from-minibuffer
 815                         (concat "IMAP username for " imap-server
 816                                 " (using stream `" (symbol-name imap-stream)
 817                                 "'): ")
 818                         (or user imap-default-user))))
 819         (setq passwd (or imap-password
 820                          (read-passwd
 821                           (concat "IMAP password for " user "@"
 822                                   imap-server " (using authenticator `"
 823                                   (symbol-name imap-auth) "'): "))))
 824         (when (and user passwd)
 825           (if (funcall loginfunc user passwd)
 826               (progn
 827                 (setq ret t
 828                       imap-username user)
 829                 (if (and (not imap-password)
 830                          (y-or-n-p "Store password for this session? "))
 831                     (setq imap-password passwd)))
 832             (message "Login failed...")
 833             (setq passwd nil)
 834             (setq imap-password nil)
 835             (sit-for 1))))
 836       ;;        (quit (with-current-buffer buffer
 837       ;;                (setq user nil
 838       ;;                      passwd nil)))
 839       ;;        (error (with-current-buffer buffer
 840       ;;                 (setq user nil
 841       ;;                       passwd nil))))
 842       ret)))
 843
 844 (defun imap-gssapi-auth-p (buffer)
 845   (eq imap-stream 'gssapi))
 846
 847 (defun imap-gssapi-auth (buffer)
 848   (message "imap: Authenticating using GSSAPI...%s"
 849            (if (eq imap-stream 'gssapi) "done" "failed"))
 850   (eq imap-stream 'gssapi))
 851
 852 (defun imap-kerberos4-auth-p (buffer)
 853   (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
 854        (eq imap-stream 'kerberos4)))
 855
 856 (defun imap-kerberos4-auth (buffer)
 857   (message "imap: Authenticating using Kerberos 4...%s"
 858            (if (eq imap-stream 'kerberos4) "done" "failed"))
 859   (eq imap-stream 'kerberos4))
 860
 861 (defun imap-cram-md5-p (buffer)
 862   (imap-capability 'AUTH=CRAM-MD5 buffer))
 863
 864 (defun imap-cram-md5-auth (buffer)
 865   "Login to server using the AUTH CRAM-MD5 method."
 866   (message "imap: Authenticating using CRAM-MD5...")
 867   (let ((done (imap-interactive-login
 868                buffer
 869                (lambda (user passwd)
 870                  (imap-ok-p
 871                   (imap-send-command-wait
 872                    (list
 873                     "AUTHENTICATE CRAM-MD5"
 874                     (lambda (challenge)
 875                       (let* ((decoded (base64-decode-string challenge))
 876                              (hash (rfc2104-hash 'md5 64 16 passwd decoded))
 877                              (response (concat user " " hash))
 878                              (encoded (base64-encode-string response)))
 879                         encoded)))))))))
 880     (if done
 881         (message "imap: Authenticating using CRAM-MD5...done")
 882       (message "imap: Authenticating using CRAM-MD5...failed"))))
 883
 884 (defun imap-login-p (buffer)
 885   (and (not (imap-capability 'LOGINDISABLED buffer))
 886        (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
 887
 888 (defun imap-login-auth (buffer)
 889   "Login to server using the LOGIN command."
 890   (message "imap: Plaintext authentication...")
 891   (imap-interactive-login buffer
 892                           (lambda (user passwd)
 893                             (imap-ok-p (imap-send-command-wait
 894                                         (concat "LOGIN \"" user "\" \""
 895                                                 passwd "\""))))))
 896
 897 (defun imap-anonymous-p (buffer)
 898   t)
 899
 900 (defun imap-anonymous-auth (buffer)
 901   (message "imap: Logging in anonymously...")
 902   (with-current-buffer buffer
 903     (imap-ok-p (imap-send-command-wait
 904                 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
 905                                                      (system-name)) "\"")))))
 906
 907 (defun imap-digest-md5-p (buffer)
 908   (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
 909        (condition-case ()
 910            (require 'digest-md5)
 911          (error nil))))
 912
 913 (defun imap-digest-md5-auth (buffer)
 914   "Login to server using the AUTH DIGEST-MD5 method."
 915   (message "imap: Authenticating using DIGEST-MD5...")
 916   (imap-interactive-login
 917    buffer
 918    (lambda (user passwd)
 919      (let ((tag
 920             (imap-send-command
 921              (list
 922               "AUTHENTICATE DIGEST-MD5"
 923               (lambda (challenge)
 924                 (digest-md5-parse-digest-challenge
 925                  (base64-decode-string challenge))
 926                 (let* ((digest-uri
 927                         (digest-md5-digest-uri
 928                          "imap" (digest-md5-challenge 'realm)))
 929                        (response
 930                         (digest-md5-digest-response
 931                          user passwd digest-uri)))
 932                   (base64-encode-string response 'no-line-break))))
 933              )))
 934        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
 935            nil
 936          (setq imap-continuation nil)
 937          (imap-send-command-1 "")
 938          (imap-ok-p (imap-wait-for-tag tag)))))))
 939
 940 ;; Server functions:
 941
 942 (defun imap-open-1 (buffer)
 943   (with-current-buffer buffer
 944     (erase-buffer)
 945     (setq imap-current-mailbox nil
 946           imap-current-message nil
 947           imap-state 'initial
 948           imap-process (condition-case ()
 949                            (funcall (nth 2 (assq imap-stream
 950                                                  imap-stream-alist))
 951                                     "imap" buffer imap-server imap-port)
 952                          ((error quit) nil)))
 953     (when imap-process
 954       (set-process-filter imap-process 'imap-arrival-filter)
 955       (set-process-sentinel imap-process 'imap-sentinel)
 956       (while (and (eq imap-state 'initial)
 957                   (memq (process-status imap-process) '(open run)))
 958         (message "Waiting for response from %s..." imap-server)
 959         (accept-process-output imap-process 1))
 960       (message "Waiting for response from %s...done" imap-server)
 961       (and (memq (process-status imap-process) '(open run))
 962            imap-process))))
 963
 964 (defun imap-open (server &optional port stream auth buffer)
 965   "Open a IMAP connection to host SERVER at PORT returning a buffer.
 966 If PORT is unspecified, a default value is used (143 except
 967 for SSL which use 993).
 968 STREAM indicates the stream to use, see `imap-streams' for available
 969 streams.  If nil, it choices the best stream the server is capable of.
 970 AUTH indicates authenticator to use, see `imap-authenticators' for
 971 available authenticators.  If nil, it choices the best stream the
 972 server is capable of.
 973 BUFFER can be a buffer or a name of a buffer, which is created if
 974 necessary.  If nil, the buffer name is generated."
 975   (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
 976   (with-current-buffer (get-buffer-create buffer)
 977     (if (imap-opened buffer)
 978         (imap-close buffer))
 979     (mapcar 'make-local-variable imap-local-variables)
 980     (imap-disable-multibyte)
 981     (buffer-disable-undo)
 982     (setq imap-server (or server imap-server))
 983     (setq imap-port (or port imap-port))
 984     (setq imap-auth (or auth imap-auth))
 985     (setq imap-stream (or stream imap-stream))
 986     (message "imap: Connecting to %s..." imap-server)
 987     (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
 988                 (imap-open-1 buffer)))
 989         (progn
 990           (message "imap: Connecting to %s...failed" imap-server)
 991           nil)
 992       (when (null imap-stream)
 993         ;; Need to choose stream.
 994         (let ((streams imap-streams))
 995           (while (setq stream (pop streams))
 996             ;; OK to use this stream?
 997             (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
 998               ;; Stream changed?
 999               (if (not (eq imap-default-stream stream))
1000                   (with-current-buffer (get-buffer-create
1001                                         (generate-new-buffer-name " *temp*"))
1002                     (mapcar 'make-local-variable imap-local-variables)
1003                     (imap-disable-multibyte)
1004                     (buffer-disable-undo)
1005                     (setq imap-server (or server imap-server))
1006                     (setq imap-port (or port imap-port))
1007                     (setq imap-auth (or auth imap-auth))
1008                     (message "imap: Reconnecting with stream `%s'..." stream)
1009                     (if (null (let ((imap-stream stream))
1010                                 (imap-open-1 (current-buffer))))
1011                         (progn
1012                           (kill-buffer (current-buffer))
1013                           (message
1014                            "imap: Reconnecting with stream `%s'...failed"
1015                            stream))
1016                       ;; We're done, kill the first connection
1017                       (imap-close buffer)
1018                       (kill-buffer buffer)
1019                       (rename-buffer buffer)
1020                       (message "imap: Reconnecting with stream `%s'...done"
1021                                stream)
1022                       (setq imap-stream stream)
1023                       (setq imap-capability nil)
1024                       (setq streams nil)))
1025                 ;; We're done
1026                 (message "imap: Connecting to %s...done" imap-server)
1027                 (setq imap-stream stream)
1028                 (setq imap-capability nil)
1029                 (setq streams nil))))))
1030       (when (imap-opened buffer)
1031         (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1032       (when imap-stream
1033         buffer))))
1034
1035 (defun imap-opened (&optional buffer)
1036   "Return non-nil if connection to imap server in BUFFER is open.
1037 If BUFFER is nil then the current buffer is used."
1038   (and (setq buffer (get-buffer (or buffer (current-buffer))))
1039        (buffer-live-p buffer)
1040        (with-current-buffer buffer
1041          (and imap-process
1042               (memq (process-status imap-process) '(open run))))))
1043
1044 (defun imap-authenticate (&optional user passwd buffer)
1045   "Authenticate to server in BUFFER, using current buffer if nil.
1046 It uses the authenticator specified when opening the server.  If the
1047 authenticator requires username/passwords, they are queried from the
1048 user and optionally stored in the buffer.  If USER and/or PASSWD is
1049 specified, the user will not be questioned and the username and/or
1050 password is remembered in the buffer."
1051   (with-current-buffer (or buffer (current-buffer))
1052     (if (not (eq imap-state 'nonauth))
1053         (or (eq imap-state 'auth)
1054             (eq imap-state 'select)
1055             (eq imap-state 'examine))
1056       (make-local-variable 'imap-username)
1057       (make-local-variable 'imap-password)
1058       (if user (setq imap-username user))
1059       (if passwd (setq imap-password passwd))
1060       (if imap-auth
1061           (and (funcall (nth 2 (assq imap-auth
1062                                      imap-authenticator-alist)) buffer)
1063                (setq imap-state 'auth))
1064         ;; Choose authenticator.
1065         (let ((auths imap-authenticators)
1066               auth)
1067           (while (setq auth (pop auths))
1068             ;; OK to use authenticator?
1069             (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1070               (message "imap: Authenticating to `%s' using `%s'..."
1071                        imap-server auth)
1072               (setq imap-auth auth)
1073               (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1074                   (progn
1075                     (message "imap: Authenticating to `%s' using `%s'...done"
1076                              imap-server auth)
1077                     (setq auths nil))
1078                 (message "imap: Authenticating to `%s' using `%s'...failed"
1079                          imap-server auth)))))
1080         imap-state))))
1081
1082 (defun imap-close (&optional buffer)
1083   "Close connection to server in BUFFER.
1084 If BUFFER is nil, the current buffer is used."
1085   (with-current-buffer (or buffer (current-buffer))
1086     (when (imap-opened)
1087       (condition-case nil
1088           (imap-send-command-wait "LOGOUT")
1089         (quit nil)))
1090     (when (and imap-process
1091                (memq (process-status imap-process) '(open run)))
1092       (delete-process imap-process))
1093     (setq imap-current-mailbox nil
1094           imap-current-message nil
1095           imap-process nil)
1096     (erase-buffer)
1097     t))
1098
1099 (defun imap-capability (&optional identifier buffer)
1100   "Return a list of identifiers which server in BUFFER support.
1101 If IDENTIFIER, return non-nil if it's among the servers capabilities.
1102 If BUFFER is nil, the current buffer is assumed."
1103   (with-current-buffer (or buffer (current-buffer))
1104     (unless imap-capability
1105       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1106         (setq imap-capability '(IMAP2))))
1107     (if identifier
1108         (memq (intern (upcase (symbol-name identifier))) imap-capability)
1109       imap-capability)))
1110
1111 (defun imap-namespace (&optional buffer)
1112   "Return a namespace hierarchy at server in BUFFER.
1113 If BUFFER is nil, the current buffer is assumed."
1114   (with-current-buffer (or buffer (current-buffer))
1115     (unless imap-namespace
1116       (when (imap-capability 'NAMESPACE)
1117         (imap-send-command-wait "NAMESPACE")))
1118     imap-namespace))
1119
1120 (defun imap-send-command-wait (command &optional buffer)
1121   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1122
1123 \f
1124 ;; Mailbox functions:
1125
1126 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1127   (with-current-buffer (or buffer (current-buffer))
1128     (if imap-mailbox-data
1129         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1130              propname value)
1131       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1132              propname value mailbox (current-buffer)))
1133     t))
1134
1135 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1136   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1137        propname))
1138
1139 (defun imap-mailbox-get (propname &optional mailbox buffer)
1140   (let ((mailbox (imap-utf7-encode mailbox)))
1141     (with-current-buffer (or buffer (current-buffer))
1142       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1143
1144 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1145   (with-current-buffer (or buffer (current-buffer))
1146     (let (result)
1147       (mapatoms
1148        (lambda (s)
1149          (push (funcall func (if mailbox-decoder
1150                                  (funcall mailbox-decoder (symbol-name s))
1151                                (symbol-name s))) result))
1152        imap-mailbox-data)
1153       result)))
1154
1155 (defun imap-mailbox-map (func &optional buffer)
1156   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1157 Function should take a mailbox name (a string) as
1158 the only argument."
1159   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1160
1161 (defun imap-current-mailbox (&optional buffer)
1162   (with-current-buffer (or buffer (current-buffer))
1163     (imap-utf7-decode imap-current-mailbox)))
1164
1165 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1166   (and (string= mailbox imap-current-mailbox)
1167        (or (and examine
1168                 (eq imap-state 'examine))
1169            (and (not examine)
1170                 (eq imap-state 'selected)))))
1171
1172 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1173   (with-current-buffer (or buffer (current-buffer))
1174     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1175
1176 (defun imap-mailbox-select-1 (mailbox &optional examine)
1177   "Select MAILBOX on server in BUFFER.
1178 If EXAMINE is non-nil, do a read-only select."
1179   (if (imap-current-mailbox-p-1 mailbox examine)
1180       imap-current-mailbox
1181     (setq imap-current-mailbox mailbox)
1182     (if (imap-ok-p (imap-send-command-wait
1183                     (concat (if examine "EXAMINE" "SELECT") " \""
1184                             mailbox "\"")))
1185         (progn
1186           (setq imap-message-data (make-vector imap-message-prime 0)
1187                 imap-state (if examine 'examine 'selected))
1188           imap-current-mailbox)
1189       ;; Failed SELECT/EXAMINE unselects current mailbox
1190       (setq imap-current-mailbox nil))))
1191
1192 (defun imap-mailbox-select (mailbox &optional examine buffer)
1193   (with-current-buffer (or buffer (current-buffer))
1194     (imap-utf7-decode
1195      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1196
1197 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1198   (with-current-buffer (or buffer (current-buffer))
1199     (imap-mailbox-select-1 mailbox 'examine)))
1200
1201 (defun imap-mailbox-examine (mailbox &optional buffer)
1202   "Examine MAILBOX on server in BUFFER."
1203   (imap-mailbox-select mailbox 'examine buffer))
1204
1205 (defun imap-mailbox-unselect (&optional buffer)
1206   "Close current folder in BUFFER, without expunging articles."
1207   (with-current-buffer (or buffer (current-buffer))
1208     (when (or (eq imap-state 'auth)
1209               (and (imap-capability 'UNSELECT)
1210                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1211               (and (imap-ok-p
1212                     (imap-send-command-wait (concat "EXAMINE \""
1213                                                     imap-current-mailbox
1214                                                     "\"")))
1215                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1216       (setq imap-current-mailbox nil
1217             imap-message-data nil
1218             imap-state 'auth)
1219       t)))
1220
1221 (defun imap-mailbox-expunge (&optional asynch buffer)
1222   "Expunge articles in current folder in BUFFER.
1223 If ASYNCH, do not wait for succesful completion of the command.
1224 If BUFFER is nil the current buffer is assumed."
1225   (with-current-buffer (or buffer (current-buffer))
1226     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1227       (if asynch
1228           (imap-send-command "EXPUNGE")
1229       (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1230
1231 (defun imap-mailbox-close (&optional asynch buffer)
1232   "Expunge articles and close current folder in BUFFER.
1233 If ASYNCH, do not wait for succesful completion of the command.
1234 If BUFFER is nil the current buffer is assumed."
1235   (with-current-buffer (or buffer (current-buffer))
1236     (when imap-current-mailbox
1237       (if asynch
1238           (imap-add-callback (imap-send-command "CLOSE")
1239                              `(lambda (tag status)
1240                                 (message "IMAP mailbox `%s' closed... %s"
1241                                          imap-current-mailbox status)
1242                                 (when (eq ,imap-current-mailbox
1243                                           imap-current-mailbox)
1244                                   ;; Don't wipe out data if another mailbox
1245                                   ;; was selected...
1246                                   (setq imap-current-mailbox nil
1247                                         imap-message-data nil
1248                                         imap-state 'auth))))
1249         (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1250           (setq imap-current-mailbox nil
1251                 imap-message-data nil
1252                 imap-state 'auth)))
1253       t)))
1254
1255 (defun imap-mailbox-create-1 (mailbox)
1256   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1257
1258 (defun imap-mailbox-create (mailbox &optional buffer)
1259   "Create MAILBOX on server in BUFFER.
1260 If BUFFER is nil the current buffer is assumed."
1261   (with-current-buffer (or buffer (current-buffer))
1262     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1263
1264 (defun imap-mailbox-delete (mailbox &optional buffer)
1265   "Delete MAILBOX on server in BUFFER.
1266 If BUFFER is nil the current buffer is assumed."
1267   (let ((mailbox (imap-utf7-encode mailbox)))
1268     (with-current-buffer (or buffer (current-buffer))
1269       (imap-ok-p
1270        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1271
1272 (defun imap-mailbox-rename (oldname newname &optional buffer)
1273   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1274 If BUFFER is nil the current buffer is assumed."
1275   (let ((oldname (imap-utf7-encode oldname))
1276         (newname (imap-utf7-encode newname)))
1277     (with-current-buffer (or buffer (current-buffer))
1278       (imap-ok-p
1279        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1280                                      "\"" newname "\""))))))
1281
1282 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1283   "Return a list of subscribed mailboxes on server in BUFFER.
1284 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1285 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1286 implementation-specific string that has to be passed to lsub command."
1287   (with-current-buffer (or buffer (current-buffer))
1288     ;; Make sure we know the hierarchy separator for root's hierarchy
1289     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1290       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1291                                       (imap-utf7-encode root) "\"")))
1292     ;; clear list data (NB not delimiter and other stuff)
1293     (imap-mailbox-map-1 (lambda (mailbox)
1294                           (imap-mailbox-put 'lsub nil mailbox)))
1295     (when (imap-ok-p
1296            (imap-send-command-wait
1297             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1298                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1299                     "%\"")))
1300       (let (out)
1301         (imap-mailbox-map-1 (lambda (mailbox)
1302                               (when (imap-mailbox-get-1 'lsub mailbox)
1303                                 (push (imap-utf7-decode mailbox) out))))
1304         (nreverse out)))))
1305
1306 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1307   "Return a list of mailboxes matching ROOT on server in BUFFER.
1308 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1309 root.  REFERENCE is a implementation-specific string that has to be
1310 passed to list command."
1311   (with-current-buffer (or buffer (current-buffer))
1312     ;; Make sure we know the hierarchy separator for root's hierarchy
1313     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1314       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1315                                       (imap-utf7-encode root) "\"")))
1316     ;; clear list data (NB not delimiter and other stuff)
1317     (imap-mailbox-map-1 (lambda (mailbox)
1318                           (imap-mailbox-put 'list nil mailbox)))
1319     (when (imap-ok-p
1320            (imap-send-command-wait
1321             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1322                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1323                     "%\"")))
1324       (let (out)
1325         (imap-mailbox-map-1 (lambda (mailbox)
1326                               (when (imap-mailbox-get-1 'list mailbox)
1327                                 (push (imap-utf7-decode mailbox) out))))
1328         (nreverse out)))))
1329
1330 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1331   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1332 Returns non-nil if successful."
1333   (with-current-buffer (or buffer (current-buffer))
1334     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1335                                                (imap-utf7-encode mailbox)
1336                                                "\"")))))
1337
1338 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1339   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1340 Returns non-nil if successful."
1341   (with-current-buffer (or buffer (current-buffer))
1342     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1343                                                (imap-utf7-encode mailbox)
1344                                                "\"")))))
1345
1346 (defun imap-mailbox-status (mailbox items &optional buffer)
1347   "Get status items ITEM in MAILBOX from server in BUFFER.
1348 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1349 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1350 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1351 returned, if ITEMS is a symbol only its value is returned."
1352   (with-current-buffer (or buffer (current-buffer))
1353     (when (imap-ok-p
1354            (imap-send-command-wait (list "STATUS \""
1355                                          (imap-utf7-encode mailbox)
1356                                          "\" "
1357                                          (upcase
1358                                           (format "%s"
1359                                                   (if (listp items)
1360                                                       items
1361                                                     (list items)))))))
1362       (if (listp items)
1363           (mapcar (lambda (item)
1364                     (imap-mailbox-get item mailbox))
1365                   items)
1366         (imap-mailbox-get items mailbox)))))
1367
1368 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1369   "Send status item request ITEM on MAILBOX to server in BUFFER.
1370 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1371 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1372 or 'unseen.  The IMAP command tag is returned."
1373   (with-current-buffer (or buffer (current-buffer))
1374     (imap-send-command (list "STATUS \""
1375                              (imap-utf7-encode mailbox)
1376                              "\" "
1377                              (format "%s"
1378                                      (if (listp items)
1379                                          items
1380                                        (list items)))))))
1381
1382 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1383   "Get ACL on mailbox from server in BUFFER."
1384   (let ((mailbox (imap-utf7-encode mailbox)))
1385     (with-current-buffer (or buffer (current-buffer))
1386       (when (imap-ok-p
1387              (imap-send-command-wait (list "GETACL \""
1388                                            (or mailbox imap-current-mailbox)
1389                                            "\"")))
1390         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1391
1392 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1393   "Change/set ACL for IDENTIFIER to RIGHTS 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 "SETACL \""
1398                                      (or mailbox imap-current-mailbox)
1399                                      "\" "
1400                                      identifier
1401                                      " "
1402                                      rights))))))
1403
1404 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1405   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1406   (let ((mailbox (imap-utf7-encode mailbox)))
1407     (with-current-buffer (or buffer (current-buffer))
1408       (imap-ok-p
1409        (imap-send-command-wait (list "DELETEACL \""
1410                                      (or mailbox imap-current-mailbox)
1411                                      "\" "
1412                                      identifier))))))
1413
1414 \f
1415 ;; Message functions:
1416
1417 (defun imap-current-message (&optional buffer)
1418   (with-current-buffer (or buffer (current-buffer))
1419     imap-current-message))
1420
1421 (defun imap-list-to-message-set (list)
1422   (mapconcat (lambda (item)
1423                (number-to-string item))
1424              (if (listp list)
1425                  list
1426                (list list))
1427              ","))
1428
1429 (defun imap-range-to-message-set (range)
1430   (mapconcat
1431    (lambda (item)
1432      (if (consp item)
1433          (format "%d:%d"
1434                  (car item) (cdr item))
1435        (format "%d" item)))
1436    (if (and (listp range) (not (listp (cdr range))))
1437        (list range) ;; make (1 . 2) into ((1 . 2))
1438      range)
1439    ","))
1440
1441 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1442   (with-current-buffer (or buffer (current-buffer))
1443     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1444                                (if (listp uids)
1445                                    (imap-list-to-message-set uids)
1446                                  uids)
1447                                props))))
1448
1449 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1450   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1451 UIDS can be a string, number or a list of numbers.  If RECEIVE
1452 is non-nil return theese properties."
1453   (with-current-buffer (or buffer (current-buffer))
1454     (when (imap-ok-p (imap-send-command-wait
1455                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1456                               (if (listp uids)
1457                                   (imap-list-to-message-set uids)
1458                                 uids)
1459                               props)))
1460       (if (or (null receive) (stringp uids))
1461           t
1462         (if (listp uids)
1463             (mapcar (lambda (uid)
1464                       (if (listp receive)
1465                           (mapcar (lambda (prop)
1466                                     (imap-message-get uid prop))
1467                                   receive)
1468                         (imap-message-get uid receive)))
1469                     uids)
1470           (imap-message-get uids receive))))))
1471
1472 (defun imap-message-put (uid propname value &optional buffer)
1473   (with-current-buffer (or buffer (current-buffer))
1474     (if imap-message-data
1475         (put (intern (number-to-string uid) imap-message-data)
1476              propname value)
1477       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1478              uid propname value (current-buffer)))
1479     t))
1480
1481 (defun imap-message-get (uid propname &optional buffer)
1482   (with-current-buffer (or buffer (current-buffer))
1483     (get (intern-soft (number-to-string uid) imap-message-data)
1484          propname)))
1485
1486 (defun imap-message-map (func propname &optional buffer)
1487   "Map a function across each mailbox in `imap-message-data', returning a list."
1488   (with-current-buffer (or buffer (current-buffer))
1489     (let (result)
1490       (mapatoms
1491        (lambda (s)
1492          (push (funcall func (get s 'UID) (get s propname)) result))
1493        imap-message-data)
1494       result)))
1495
1496 (defmacro imap-message-envelope-date (uid &optional buffer)
1497   `(with-current-buffer (or ,buffer (current-buffer))
1498      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1499
1500 (defmacro imap-message-envelope-subject (uid &optional buffer)
1501   `(with-current-buffer (or ,buffer (current-buffer))
1502      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1503
1504 (defmacro imap-message-envelope-from (uid &optional buffer)
1505   `(with-current-buffer (or ,buffer (current-buffer))
1506      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1507
1508 (defmacro imap-message-envelope-sender (uid &optional buffer)
1509   `(with-current-buffer (or ,buffer (current-buffer))
1510      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1511
1512 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1513   `(with-current-buffer (or ,buffer (current-buffer))
1514      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1515
1516 (defmacro imap-message-envelope-to (uid &optional buffer)
1517   `(with-current-buffer (or ,buffer (current-buffer))
1518      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1519
1520 (defmacro imap-message-envelope-cc (uid &optional buffer)
1521   `(with-current-buffer (or ,buffer (current-buffer))
1522      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1523
1524 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1525   `(with-current-buffer (or ,buffer (current-buffer))
1526      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1527
1528 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1529   `(with-current-buffer (or ,buffer (current-buffer))
1530      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1531
1532 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1533   `(with-current-buffer (or ,buffer (current-buffer))
1534      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1535
1536 (defmacro imap-message-body (uid &optional buffer)
1537   `(with-current-buffer (or ,buffer (current-buffer))
1538      (imap-message-get ,uid 'BODY)))
1539
1540 (defun imap-search (predicate &optional buffer)
1541   (with-current-buffer (or buffer (current-buffer))
1542     (imap-mailbox-put 'search 'dummy)
1543     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1544       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1545           (progn
1546             (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1547             nil)
1548         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1549
1550 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1551   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1552   (with-current-buffer (or buffer (current-buffer))
1553     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1554         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1555
1556 (defun imap-message-flags-set (articles flags &optional silent buffer)
1557   (when (and articles flags)
1558     (with-current-buffer (or buffer (current-buffer))
1559       (imap-ok-p (imap-send-command-wait
1560                   (concat "UID STORE " articles
1561                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1562
1563 (defun imap-message-flags-del (articles flags &optional silent buffer)
1564   (when (and articles flags)
1565     (with-current-buffer (or buffer (current-buffer))
1566       (imap-ok-p (imap-send-command-wait
1567                   (concat "UID STORE " articles
1568                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1569
1570 (defun imap-message-flags-add (articles flags &optional silent buffer)
1571   (when (and articles flags)
1572     (with-current-buffer (or buffer (current-buffer))
1573       (imap-ok-p (imap-send-command-wait
1574                   (concat "UID STORE " articles
1575                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1576
1577 (defun imap-message-copyuid-1 (mailbox)
1578   (if (imap-capability 'UIDPLUS)
1579       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1580             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1581     (let ((old-mailbox imap-current-mailbox)
1582           (state imap-state)
1583           (imap-message-data (make-vector 2 0)))
1584       (when (imap-mailbox-examine-1 mailbox)
1585         (prog1
1586             (and (imap-fetch "*" "UID")
1587               &