cgit.sxemacs.org Git - gnus/blob - lisp/imap.el

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