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

   1 ;;; imap.el --- imap library
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; imap.el is a elisp library providing an interface for talking to
  29 ;; IMAP servers.
  30 ;;
  31 ;; imap.el is roughly divided in two parts, one that parses IMAP
  32 ;; responses from the server and storing data into buffer-local
  33 ;; variables, and one for utility functions which send commands to
  34 ;; server, waits for an answer, and return information.  The latter
  35 ;; part is layered on top of the previous.
  36 ;;
  37 ;; The imap.el API consist of the following functions, other functions
  38 ;; in this file should not be called directly and the result of doing
  39 ;; so are at best undefined.
  40 ;;
  41 ;; Global commands:
  42 ;;
  43 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  44 ;; imap-capability, imap-namespace, imap-error-text
  45 ;;
  46 ;; Mailbox commands:
  47 ;;
  48 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  49 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  50 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  51 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  52 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  53 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  54 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  55 ;;
  56 ;; Message commands:
  57 ;;
  58 ;; imap-fetch-asynch,                 imap-fetch,
  59 ;; imap-current-message,              imap-list-to-message-set,
  60 ;; imap-message-get,                  imap-message-map
  61 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  62 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  63 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  64 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  65 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  66 ;; imap-message-body,                 imap-message-flag-permanent-p
  67 ;; imap-message-flags-set,            imap-message-flags-del
  68 ;; imap-message-flags-add,            imap-message-copyuid
  69 ;; imap-message-copy,                 imap-message-appenduid
  70 ;; imap-message-append,               imap-envelope-from
  71 ;; imap-body-lines
  72 ;;
  73 ;; It is my hope that these commands should be pretty self
  74 ;; explanatory for someone that know IMAP.  All functions have
  75 ;; additional documentation on how to invoke them.
  76 ;;
  77 ;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented
  78 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  79 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  80 ;; LOGINDISABLED) (with use of external library starttls.el and
  81 ;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731
  82 ;; (with use of external program `imtest'), RFC2971 (ID).  It also
  83 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
  84 ;;
  85 ;; Without the work of John McClary Prevost and Jim Radford this library
  86 ;; would not have seen the light of day.  Many thanks.
  87 ;;
  88 ;; This is a transcript of short interactive session for demonstration
  89 ;; purposes.
  90 ;;
  91 ;; (imap-open "my.mail.server")
  92 ;; => " *imap* my.mail.server:0"
  93 ;;
  94 ;; The rest are invoked with current buffer as the buffer returned by
  95 ;; `imap-open'.  It is possible to do all without this, but it would
  96 ;; look ugly here since `buffer' is always the last argument for all
  97 ;; imap.el API functions.
  98 ;;
  99 ;; (imap-authenticate "myusername" "mypassword")
 100 ;; => auth
 101 ;;
 102 ;; (imap-mailbox-lsub "*")
 103 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
 104 ;;
 105 ;; (imap-mailbox-list "INBOX.n%")
 106 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
 107 ;;
 108 ;; (imap-mailbox-select "INBOX.nnimap")
 109 ;; => "INBOX.nnimap"
 110 ;;
 111 ;; (imap-mailbox-get 'exists)
 112 ;; => 166
 113 ;;
 114 ;; (imap-mailbox-get 'uidvalidity)
 115 ;; => "908992622"
 116 ;;
 117 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
 118 ;; => (235 236)
 119 ;;
 120 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
 121 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
 122 ;;
 123 ;; Todo:
 124 ;;
 125 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
 126 ;; o Don't use `read' at all (important places already fixed)
 127 ;; o Accept list of articles instead of message set string in most
 128 ;;   imap-message-* functions.
 129 ;; o Send strings as literal if they contain, e.g., ".
 130 ;;
 131 ;; Revision history:
 132 ;;
 133 ;;  - 19991218 added starttls/digest-md5 patch,
 134 ;;             by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
 135 ;;             NB! you need SLIM for starttls.el and digest-md5.el
 136 ;;  - 19991023 commited to pgnus
 137 ;;
 138
 139 ;;; Code:
 140
 141 (eval-when-compile (require 'cl))
 142 (eval-and-compile
 143   (autoload 'starttls-open-stream "starttls")
 144   (autoload 'starttls-negotiate "starttls")
 145   (autoload 'sasl-find-mechanism "sasl")
 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 'utf7-encode "utf7")
 152   (autoload 'utf7-decode "utf7")
 153   (autoload 'format-spec "format-spec")
 154   (autoload 'format-spec-make "format-spec")
 155   (autoload 'open-tls-stream "tls"))
 156
 157 ;; User variables.
 158
 159 (defgroup imap nil
 160   "Low-level IMAP issues."
 161   :version "21.1"
 162   :group 'mail)
 163
 164 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 165                                     "imtest -kp %s %p")
 166   "List of strings containing commands for Kerberos 4 authentication.
 167 %s is replaced with server hostname, %p with port to connect to, and
 168 %l with the value of `imap-default-user'.  The program should accept
 169 IMAP commands on stdin and return responses to stdout.  Each entry in
 170 the list is tried until a successful connection is made."
 171   :group 'imap
 172   :type '(repeat string))
 173
 174 (defcustom imap-gssapi-program (list
 175                                 (concat "gsasl %s %p "
 176                                         "--mechanism GSSAPI "
 177                                         "--authentication-id %l")
 178                                 "imtest -m gssapi -u %l -p %p %s")
 179   "List of strings containing commands for GSSAPI (krb5) authentication.
 180 %s is replaced with server hostname, %p with port to connect to, and
 181 %l with the value of `imap-default-user'.  The program should accept
 182 IMAP commands on stdin and return responses to stdout.  Each entry in
 183 the list is tried until a successful connection is made."
 184   :group 'imap
 185   :type '(repeat string))
 186
 187 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 188                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 189                               "s_client -quiet -ssl3 -connect %s:%p"
 190                               "s_client -quiet -ssl2 -connect %s:%p")
 191   "A string, or list of strings, containing commands for SSL connections.
 192 Within a string, %s is replaced with the server address and %p with
 193 port number on server.  The program should accept IMAP commands on
 194 stdin and return responses to stdout.  Each entry in the list is tried
 195 until a successful connection is made."
 196   :group 'imap
 197   :type '(choice string
 198                  (repeat string)))
 199
 200 (defcustom imap-shell-program '("ssh %s imapd"
 201                                 "rsh %s imapd"
 202                                 "ssh %g ssh %s imapd"
 203                                 "rsh %g rsh %s imapd")
 204   "A list of strings, containing commands for IMAP connection.
 205 Within a string, %s is replaced with the server address, %p with port
 206 number on server, %g with `imap-shell-host', and %l with
 207 `imap-default-user'.  The program should read IMAP commands from stdin
 208 and write IMAP response to stdout. Each entry in the list is tried
 209 until a successful connection is made."
 210   :group 'imap
 211   :type '(repeat string))
 212
 213 (defcustom imap-process-connection-type nil
 214   "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
 215 The `process-connection-type' variable control type of device
 216 used to communicate with subprocesses.  Values are nil to use a
 217 pipe, or t or `pty' to use a pty.  The value has no effect if the
 218 system has no ptys or if all ptys are busy: then a pipe is used
 219 in any case.  The value takes effect when a IMAP server is
 220 opened, changing it after that has no effect."
 221   :version "22.1"
 222   :group 'imap
 223   :type 'boolean)
 224
 225 (defcustom imap-use-utf7 t
 226   "If non-nil, do utf7 encoding/decoding of mailbox names.
 227 Since the UTF7 decoding currently only decodes into ISO-8859-1
 228 characters, you may disable this decoding if you need to access UTF7
 229 encoded mailboxes which doesn't translate into ISO-8859-1."
 230   :group 'imap
 231   :type 'boolean)
 232
 233 (defcustom imap-log nil
 234   "If non-nil, a imap session trace is placed in *imap-log* buffer.
 235 Note that username, passwords and other privacy sensitive
 236 information (such as e-mail) may be stored in the *imap-log*
 237 buffer.  It is not written to disk, however.  Do not enable this
 238 variable unless you are comfortable with that."
 239   :group 'imap
 240   :type 'boolean)
 241
 242 (defcustom imap-debug nil
 243   "If non-nil, random debug spews are placed in *imap-debug* buffer.
 244 Note that username, passwords and other privacy sensitive
 245 information (such as e-mail) may be stored in the *imap-debug*
 246 buffer.  It is not written to disk, however.  Do not enable this
 247 variable unless you are comfortable with that."
 248   :group 'imap
 249   :type 'boolean)
 250
 251 (defcustom imap-shell-host "gateway"
 252   "Hostname of rlogin proxy."
 253   :group 'imap
 254   :type 'string)
 255
 256 (defcustom imap-default-user (user-login-name)
 257   "Default username to use."
 258   :group 'imap
 259   :type 'string)
 260
 261 (defcustom imap-read-timeout (if (string-match
 262                                   "windows-nt\\|os/2\\|emx\\|cygwin"
 263                                   (symbol-name system-type))
 264                                  1.0
 265                                0.1)
 266   "*How long to wait between checking for the end of output.
 267 Shorter values mean quicker response, but is more CPU intensive."
 268   :type 'number
 269   :group 'imap)
 270
 271 (defcustom imap-store-password nil
 272   "If non-nil, store session password without promting."
 273   :group 'imap
 274   :type 'boolean)
 275
 276 ;; Various variables.
 277
 278 (defvar imap-fetch-data-hook nil
 279   "Hooks called after receiving each FETCH response.")
 280
 281 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 282   "Priority of streams to consider when opening connection to server.")
 283
 284 (defvar imap-stream-alist
 285   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 286     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 287     (tls       imap-tls-p              imap-tls-open)
 288     (ssl       imap-ssl-p              imap-ssl-open)
 289     (network   imap-network-p          imap-network-open)
 290     (shell     imap-shell-p            imap-shell-open)
 291     (starttls  imap-starttls-p         imap-starttls-open))
 292   "Definition of network streams.
 293
 294 \(NAME CHECK OPEN)
 295
 296 NAME names the stream, CHECK is a function returning non-nil if the
 297 server support the stream and OPEN is a function for opening the
 298 stream.")
 299
 300 (defvar imap-authenticators '(gssapi
 301                               kerberos4
 302                               digest-md5
 303                               cram-md5
 304                               ;;sasl
 305                               login
 306                               anonymous)
 307   "Priority of authenticators to consider when authenticating to server.")
 308
 309 (defvar imap-authenticator-alist
 310   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 311     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 312     (sasl       imap-sasl-auth-p      imap-sasl-auth)
 313     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 314     (login      imap-login-p          imap-login-auth)
 315     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 316     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 317   "Definition of authenticators.
 318
 319 \(NAME CHECK AUTHENTICATE)
 320
 321 NAME names the authenticator.  CHECK is a function returning non-nil if
 322 the server support the authenticator and AUTHENTICATE is a function
 323 for doing the actual authentication.")
 324
 325 (defvar imap-error nil
 326   "Error codes from the last command.")
 327
 328 ;; Internal constants.  Change these and die.
 329
 330 (defconst imap-default-port 143)
 331 (defconst imap-default-ssl-port 993)
 332 (defconst imap-default-tls-port 993)
 333 (defconst imap-default-stream 'network)
 334 (defconst imap-coding-system-for-read 'binary)
 335 (defconst imap-coding-system-for-write 'binary)
 336 (defconst imap-local-variables '(imap-server
 337                                  imap-port
 338                                  imap-client-eol
 339                                  imap-server-eol
 340                                  imap-auth
 341                                  imap-stream
 342                                  imap-username
 343                                  imap-password
 344                                  imap-current-mailbox
 345                                  imap-current-target-mailbox
 346                                  imap-message-data
 347                                  imap-capability
 348                                  imap-id
 349                                  imap-namespace
 350                                  imap-state
 351                                  imap-reached-tag
 352                                  imap-failed-tags
 353                                  imap-tag
 354                                  imap-process
 355                                  imap-calculate-literal-size-first
 356                                  imap-mailbox-data))
 357 (defconst imap-log-buffer "*imap-log*")
 358 (defconst imap-debug-buffer "*imap-debug*")
 359
 360 ;; Internal variables.
 361
 362 (defvar imap-stream nil)
 363 (defvar imap-auth nil)
 364 (defvar imap-server nil)
 365 (defvar imap-port nil)
 366 (defvar imap-username nil)
 367 (defvar imap-password nil)
 368 (defvar imap-calculate-literal-size-first nil)
 369 (defvar imap-state 'closed
 370   "IMAP state.
 371 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 372 and `examine'.")
 373
 374 (defvar imap-server-eol "\r\n"
 375   "The EOL string sent from the server.")
 376
 377 (defvar imap-client-eol "\r\n"
 378   "The EOL string we send to the server.")
 379
 380 (defvar imap-current-mailbox nil
 381   "Current mailbox name.")
 382
 383 (defvar imap-current-target-mailbox nil
 384   "Current target mailbox for COPY and APPEND commands.")
 385
 386 (defvar imap-mailbox-data nil
 387   "Obarray with mailbox data.")
 388
 389 (defvar imap-mailbox-prime 997
 390   "Length of imap-mailbox-data.")
 391
 392 (defvar imap-current-message nil
 393   "Current message number.")
 394
 395 (defvar imap-message-data nil
 396   "Obarray with message data.")
 397
 398 (defvar imap-message-prime 997
 399   "Length of imap-message-data.")
 400
 401 (defvar imap-capability nil
 402   "Capability for server.")
 403
 404 (defvar imap-id nil
 405   "Identity of server.
 406 See RFC 2971.")
 407
 408 (defvar imap-namespace nil
 409   "Namespace for current server.")
 410
 411 (defvar imap-reached-tag 0
 412   "Lower limit on command tags that have been parsed.")
 413
 414 (defvar imap-failed-tags nil
 415   "Alist of tags that failed.
 416 Each element is a list with four elements; tag (a integer), response
 417 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 418 human readable response text (a string).")
 419
 420 (defvar imap-tag 0
 421   "Command tag number.")
 422
 423 (defvar imap-process nil
 424   "Process.")
 425
 426 (defvar imap-continuation nil
 427   "Non-nil indicates that the server emitted a continuation request.
 428 The actual value is really the text on the continuation line.")
 429
 430 (defvar imap-callbacks nil
 431   "List of response tags and callbacks, on the form `(number . function)'.
 432 The function should take two arguments, the first the IMAP tag and the
 433 second the status (OK, NO, BAD etc) of the command.")
 434
 435 \f
 436 ;; Utility functions:
 437
 438 (defun imap-remassoc (key alist)
 439   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
 440 The modified LIST is returned.  If the first member
 441 of LIST has a car that is `equal' to KEY, there is no way to remove it
 442 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 443 sure of changing the value of `foo'."
 444   (when alist
 445     (if (equal key (caar alist))
 446         (cdr alist)
 447       (setcdr alist (imap-remassoc key (cdr alist)))
 448       alist)))
 449
 450 (defsubst imap-disable-multibyte ()
 451   "Enable multibyte in the current buffer."
 452   (when (fboundp 'set-buffer-multibyte)
 453     (set-buffer-multibyte nil)))
 454
 455 (defsubst imap-utf7-encode (string)
 456   (if imap-use-utf7
 457       (and string
 458            (condition-case ()
 459                (utf7-encode string t)
 460              (error (message
 461                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 462                      string)
 463                     string)))
 464     string))
 465
 466 (defsubst imap-utf7-decode (string)
 467   (if imap-use-utf7
 468       (and string
 469            (condition-case ()
 470                (utf7-decode string t)
 471              (error (message
 472                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 473                      string)
 474                     string)))
 475     string))
 476
 477 (defsubst imap-ok-p (status)
 478   (if (eq status 'OK)
 479       t
 480     (setq imap-error status)
 481     nil))
 482
 483 (defun imap-error-text (&optional buffer)
 484   (with-current-buffer (or buffer (current-buffer))
 485     (nth 3 (car imap-failed-tags))))
 486
 487 \f
 488 ;; Server functions; stream stuff:
 489
 490 (defun imap-kerberos4-stream-p (buffer)
 491   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 492
 493 (defun imap-kerberos4-open (name buffer server port)
 494   (let ((cmds imap-kerberos4-program)
 495         cmd done)
 496     (while (and (not done) (setq cmd (pop cmds)))
 497       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 498       (erase-buffer)
 499       (let* ((port (or port imap-default-port))
 500              (coding-system-for-read imap-coding-system-for-read)
 501              (coding-system-for-write imap-coding-system-for-write)
 502              (process-connection-type imap-process-connection-type)
 503              (process (start-process
 504                        name buffer shell-file-name shell-command-switch
 505                        (format-spec
 506                         cmd
 507                         (format-spec-make
 508                          ?s server
 509                          ?p (number-to-string port)
 510                          ?l imap-default-user))))
 511              response)
 512         (when process
 513           (with-current-buffer buffer
 514             (setq imap-client-eol "\n"
 515                   imap-calculate-literal-size-first t)
 516             (while (and (memq (process-status process) '(open run))
 517                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 518                         (goto-char (point-min))
 519                         ;; Athena IMTEST can output SSL verify errors
 520                         (or (while (looking-at "^verify error:num=")
 521                               (forward-line))
 522                             t)
 523                         (or (while (looking-at "^TLS connection established")
 524                               (forward-line))
 525                             t)
 526                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 527                         (or (while (looking-at "^C:")
 528                               (forward-line))
 529                             t)
 530                         ;; cyrus 1.6 imtest print "S: " before server greeting
 531                         (or (not (looking-at "S: "))
 532                             (forward-char 3)
 533                             t)
 534                         (not (and (imap-parse-greeting)
 535                                   ;; success in imtest < 1.6:
 536                                   (or (re-search-forward
 537                                        "^__\\(.*\\)__\n" nil t)
 538                                       ;; success in imtest 1.6:
 539                                       (re-search-forward
 540                                        "^\\(Authenticat.*\\)" nil t))
 541                                   (setq response (match-string 1)))))
 542               (accept-process-output process 1)
 543               (sit-for 1))
 544             (and imap-log
 545                  (with-current-buffer (get-buffer-create imap-log-buffer)
 546                    (imap-disable-multibyte)
 547                    (buffer-disable-undo)
 548                    (goto-char (point-max))
 549                    (insert-buffer-substring buffer)))
 550             (erase-buffer)
 551             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 552                      (if response (concat "done, " response) "failed"))
 553             (if (and response (let ((case-fold-search nil))
 554                                 (not (string-match "failed" response))))
 555                 (setq done process)
 556               (if (memq (process-status process) '(open run))
 557                   (imap-send-command "LOGOUT"))
 558               (delete-process process)
 559               nil)))))
 560     done))
 561
 562 (defun imap-gssapi-stream-p (buffer)
 563   (imap-capability 'AUTH=GSSAPI buffer))
 564
 565 (defun imap-gssapi-open (name buffer server port)
 566   (let ((cmds imap-gssapi-program)
 567         cmd done)
 568     (while (and (not done) (setq cmd (pop cmds)))
 569       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 570       (erase-buffer)
 571       (let* ((port (or port imap-default-port))
 572              (coding-system-for-read imap-coding-system-for-read)
 573              (coding-system-for-write imap-coding-system-for-write)
 574              (process-connection-type imap-process-connection-type)
 575              (process (start-process
 576                        name buffer shell-file-name shell-command-switch
 577                        (format-spec
 578                         cmd
 579                         (format-spec-make
 580                          ?s server
 581                          ?p (number-to-string port)
 582                          ?l imap-default-user))))
 583              response)
 584         (when process
 585           (with-current-buffer buffer
 586             (setq imap-client-eol "\n"
 587                   imap-calculate-literal-size-first t)
 588             (while (and (memq (process-status process) '(open run))
 589                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 590                         (goto-char (point-min))
 591                         ;; Athena IMTEST can output SSL verify errors
 592                         (or (while (looking-at "^verify error:num=")
 593                               (forward-line))
 594                             t)
 595                         (or (while (looking-at "^TLS connection established")
 596                               (forward-line))
 597                             t)
 598                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 599                         (or (while (looking-at "^C:")
 600                               (forward-line))
 601                             t)
 602                         ;; cyrus 1.6 imtest print "S: " before server greeting
 603                         (or (not (looking-at "S: "))
 604                             (forward-char 3)
 605                             t)
 606                         ;; GNU SASL may print 'Trying ...' first.
 607                         (or (not (looking-at "Trying "))
 608                             (forward-line)
 609                             t)
 610                         (not (and (imap-parse-greeting)
 611                                   ;; success in imtest 1.6:
 612                                   (re-search-forward
 613                                    (concat "^\\(\\(Authenticat.*\\)\\|\\("
 614                                            "Client authentication "
 615                                            "finished.*\\)\\)")
 616                                    nil t)
 617                                   (setq response (match-string 1)))))
 618               (accept-process-output process 1)
 619               (sit-for 1))
 620             (and imap-log
 621                  (with-current-buffer (get-buffer-create imap-log-buffer)
 622                    (imap-disable-multibyte)
 623                    (buffer-disable-undo)
 624                    (goto-char (point-max))
 625                    (insert-buffer-substring buffer)))
 626             (erase-buffer)
 627             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 628             (if (and response (let ((case-fold-search nil))
 629                                 (not (string-match "failed" response))))
 630                 (setq done process)
 631               (if (memq (process-status process) '(open run))
 632                   (imap-send-command "LOGOUT"))
 633               (delete-process process)
 634               nil)))))
 635     done))
 636
 637 (defun imap-ssl-p (buffer)
 638   nil)
 639
 640 (defun imap-ssl-open (name buffer server port)
 641   "Open a SSL connection to server."
 642   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 643                 (list imap-ssl-program)))
 644         cmd done)
 645     (while (and (not done) (setq cmd (pop cmds)))
 646       (message "imap: Opening SSL connection with `%s'..." cmd)
 647       (erase-buffer)
 648       (let* ((port (or port imap-default-ssl-port))
 649              (coding-system-for-read imap-coding-system-for-read)
 650              (coding-system-for-write imap-coding-system-for-write)
 651              (process-connection-type imap-process-connection-type)
 652              (set-process-query-on-exit-flag
 653               (if (fboundp 'set-process-query-on-exit-flag)
 654                   'set-process-query-on-exit-flag
 655                 'process-kill-without-query))
 656              process)
 657         (when (progn
 658                 (setq process (start-process
 659                                name buffer shell-file-name
 660                                shell-command-switch
 661                                (format-spec cmd
 662                                             (format-spec-make
 663                                              ?s server
 664                                              ?p (number-to-string port)))))
 665                 (funcall set-process-query-on-exit-flag process nil)
 666                 process)
 667           (with-current-buffer buffer
 668             (goto-char (point-min))
 669             (while (and (memq (process-status process) '(open run))
 670                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 671                         (goto-char (point-max))
 672                         (forward-line -1)
 673                         (not (imap-parse-greeting)))
 674               (accept-process-output process 1)
 675               (sit-for 1))
 676             (and imap-log
 677                  (with-current-buffer (get-buffer-create imap-log-buffer)
 678                    (imap-disable-multibyte)
 679                    (buffer-disable-undo)
 680                    (goto-char (point-max))
 681                    (insert-buffer-substring buffer)))
 682             (erase-buffer)
 683             (when (memq (process-status process) '(open run))
 684               (setq done process))))))
 685     (if done
 686         (progn
 687           (message "imap: Opening SSL connection with `%s'...done" cmd)
 688           done)
 689       (message "imap: Opening SSL connection with `%s'...failed" cmd)
 690       nil)))
 691
 692 (defun imap-tls-p (buffer)
 693   nil)
 694
 695 (defun imap-tls-open (name buffer server port)
 696   (let* ((port (or port imap-default-tls-port))
 697          (coding-system-for-read imap-coding-system-for-read)
 698          (coding-system-for-write imap-coding-system-for-write)
 699          (process (open-tls-stream name buffer server port)))
 700     (when process
 701       (while (and (memq (process-status process) '(open run))
 702                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 703                   (goto-char (point-max))
 704                   (forward-line -1)
 705                   (not (imap-parse-greeting)))
 706         (accept-process-output process 1)
 707         (sit-for 1))
 708       (and imap-log
 709            (with-current-buffer (get-buffer-create imap-log-buffer)
 710              (imap-disable-multibyte)
 711              (buffer-disable-undo)
 712              (goto-char (point-max))
 713              (insert-buffer-substring buffer)))
 714       (when (memq (process-status process) '(open run))
 715         process))))
 716
 717 (defun imap-network-p (buffer)
 718   t)
 719
 720 (defun imap-network-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 (open-network-stream name buffer server port)))
 725     (when process
 726       (while (and (memq (process-status process) '(open run))
 727                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 728                   (goto-char (point-min))
 729                   (not (imap-parse-greeting)))
 730         (accept-process-output process 1)
 731         (sit-for 1))
 732       (and imap-log
 733            (with-current-buffer (get-buffer-create imap-log-buffer)
 734              (imap-disable-multibyte)
 735              (buffer-disable-undo)
 736              (goto-char (point-max))
 737              (insert-buffer-substring buffer)))
 738       (when (memq (process-status process) '(open run))
 739         process))))
 740
 741 (defun imap-shell-p (buffer)
 742   nil)
 743
 744 (defun imap-shell-open (name buffer server port)
 745   (let ((cmds (if (listp imap-shell-program) imap-shell-program
 746                 (list imap-shell-program)))
 747         cmd done)
 748     (while (and (not done) (setq cmd (pop cmds)))
 749       (message "imap: Opening IMAP connection with `%s'..." cmd)
 750       (setq imap-client-eol "\n")
 751       (let* ((port (or port imap-default-port))
 752              (coding-system-for-read imap-coding-system-for-read)
 753              (coding-system-for-write imap-coding-system-for-write)
 754              (process (start-process
 755                        name buffer shell-file-name shell-command-switch
 756                        (format-spec
 757                         cmd
 758                         (format-spec-make
 759                          ?s server
 760                          ?g imap-shell-host
 761                          ?p (number-to-string port)
 762                          ?l imap-default-user)))))
 763         (when process
 764           (while (and (memq (process-status process) '(open run))
 765                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 766                       (goto-char (point-max))
 767                       (forward-line -1)
 768                       (not (imap-parse-greeting)))
 769             (accept-process-output process 1)
 770             (sit-for 1))
 771           (and imap-log
 772                (with-current-buffer (get-buffer-create imap-log-buffer)
 773                  (imap-disable-multibyte)
 774                  (buffer-disable-undo)
 775                  (goto-char (point-max))
 776                  (insert-buffer-substring buffer)))
 777           (erase-buffer)
 778           (when (memq (process-status process) '(open run))
 779             (setq done process)))))
 780     (if done
 781         (progn
 782           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 783           done)
 784       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 785       nil)))
 786
 787 (defun imap-starttls-p (buffer)
 788   (imap-capability 'STARTTLS buffer))
 789
 790 (defun imap-starttls-open (name buffer server port)
 791   (let* ((port (or port imap-default-port))
 792          (coding-system-for-read imap-coding-system-for-read)
 793          (coding-system-for-write imap-coding-system-for-write)
 794          (process (starttls-open-stream name buffer server port))
 795          done tls-info)
 796     (message "imap: Connecting with STARTTLS...")
 797     (when process
 798       (while (and (memq (process-status process) '(open run))
 799                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 800                   (goto-char (point-max))
 801                   (forward-line -1)
 802                   (not (imap-parse-greeting)))
 803         (accept-process-output process 1)
 804         (sit-for 1))
 805       (imap-send-command "STARTTLS")
 806       (while (and (memq (process-status process) '(open run))
 807                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 808                   (goto-char (point-max))
 809                   (forward-line -1)
 810                   (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
 811         (accept-process-output process 1)
 812         (sit-for 1))
 813       (and imap-log
 814            (with-current-buffer (get-buffer-create imap-log-buffer)
 815              (buffer-disable-undo)
 816              (goto-char (point-max))
 817              (insert-buffer-substring buffer)))
 818       (when (and (setq tls-info (starttls-negotiate process))
 819                  (memq (process-status process) '(open run)))
 820         (setq done process)))
 821     (if (stringp tls-info)
 822         (message "imap: STARTTLS info: %s" tls-info))
 823     (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
 824     done))
 825
 826 ;; Server functions; authenticator stuff:
 827
 828 (defun imap-interactive-login (buffer loginfunc)
 829   "Login to server in BUFFER.
 830 LOGINFUNC is passed a username and a password, it should return t if
 831 it where successful authenticating itself to the server, nil otherwise.
 832 Returns t if login was successful, nil otherwise."
 833   (with-current-buffer buffer
 834     (make-local-variable 'imap-username)
 835     (make-local-variable 'imap-password)
 836     (let (user passwd ret)
 837       ;;      (condition-case ()
 838       (while (or (not user) (not passwd))
 839         (setq user (or imap-username
 840                        (read-from-minibuffer
 841                         (concat "IMAP username for " imap-server
 842                                 " (using stream `" (symbol-name imap-stream)
 843                                 "'): ")
 844                         (or user imap-default-user))))
 845         (setq passwd (or imap-password
 846                          (read-passwd
 847                           (concat "IMAP password for " user "@"
 848                                   imap-server " (using authenticator `"
 849                                   (symbol-name imap-auth) "'): "))))
 850         (when (and user passwd)
 851           (if (funcall loginfunc user passwd)
 852               (progn
 853                 (setq ret t
 854                       imap-username user)
 855                 (when (and (not imap-password)
 856                            (or imap-store-password
 857                                (y-or-n-p "Store password for this session? ")))
 858                   (setq imap-password passwd)))
 859             (message "Login failed...")
 860             (setq passwd nil)
 861             (setq imap-password nil)
 862             (sit-for 1))))
 863       ;;        (quit (with-current-buffer buffer
 864       ;;                (setq user nil
 865       ;;                      passwd nil)))
 866       ;;        (error (with-current-buffer buffer
 867       ;;                 (setq user nil
 868       ;;                       passwd nil))))
 869       ret)))
 870
 871 (defun imap-gssapi-auth-p (buffer)
 872   (eq imap-stream 'gssapi))
 873
 874 (defun imap-gssapi-auth (buffer)
 875   (message "imap: Authenticating using GSSAPI...%s"
 876            (if (eq imap-stream 'gssapi) "done" "failed"))
 877   (eq imap-stream 'gssapi))
 878
 879 (defun imap-kerberos4-auth-p (buffer)
 880   (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
 881        (eq imap-stream 'kerberos4)))
 882
 883 (defun imap-kerberos4-auth (buffer)
 884   (message "imap: Authenticating using Kerberos 4...%s"
 885            (if (eq imap-stream 'kerberos4) "done" "failed"))
 886   (eq imap-stream 'kerberos4))
 887
 888 (defun imap-cram-md5-p (buffer)
 889   (imap-capability 'AUTH=CRAM-MD5 buffer))
 890
 891 (defun imap-cram-md5-auth (buffer)
 892   "Login to server using the AUTH CRAM-MD5 method."
 893   (message "imap: Authenticating using CRAM-MD5...")
 894   (let ((done (imap-interactive-login
 895                buffer
 896                (lambda (user passwd)
 897                  (imap-ok-p
 898                   (imap-send-command-wait
 899                    (list
 900                     "AUTHENTICATE CRAM-MD5"
 901                     (lambda (challenge)
 902                       (let* ((decoded (base64-decode-string challenge))
 903                              (hash (rfc2104-hash 'md5 64 16 passwd decoded))
 904                              (response (concat user " " hash))
 905                              (encoded (base64-encode-string response)))
 906                         encoded)))))))))
 907     (if done
 908         (message "imap: Authenticating using CRAM-MD5...done")
 909       (message "imap: Authenticating using CRAM-MD5...failed"))))
 910
 911 (defun imap-login-p (buffer)
 912   (and (not (imap-capability 'LOGINDISABLED buffer))
 913        (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
 914
 915 (defun imap-quote-specials (string)
 916   (with-temp-buffer
 917     (insert string)
 918     (goto-char (point-min))
 919     (while (re-search-forward "[\\\"]" nil t)
 920       (forward-char -1)
 921       (insert "\\")
 922       (forward-char 1))
 923     (buffer-string)))
 924
 925 (defun imap-login-auth (buffer)
 926   "Login to server using the LOGIN command."
 927   (message "imap: Plaintext authentication...")
 928   (imap-interactive-login buffer
 929                           (lambda (user passwd)
 930                             (imap-ok-p (imap-send-command-wait
 931                                         (concat "LOGIN \""
 932                                                 (imap-quote-specials user)
 933                                                 "\" \""
 934                                                 (imap-quote-specials passwd)
 935                                                 "\""))))))
 936
 937 (defun imap-anonymous-p (buffer)
 938   t)
 939
 940 (defun imap-anonymous-auth (buffer)
 941   (message "imap: Logging in anonymously...")
 942   (with-current-buffer buffer
 943     (imap-ok-p (imap-send-command-wait
 944                 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
 945                                                      (system-name)) "\"")))))
 946
 947 ;;; Compiler directives.
 948
 949 (defvar imap-sasl-client)
 950 (defvar imap-sasl-step)
 951
 952 (defun imap-sasl-make-mechanisms (buffer)
 953   (let ((mecs '()))
 954     (mapc (lambda (sym)
 955             (let ((name (symbol-name sym)))
 956               (if (and (> (length name) 5)
 957                        (string-equal "AUTH=" (substring name 0 5 )))
 958                   (setq mecs (cons (substring name 5) mecs)))))
 959           (imap-capability nil buffer))
 960     mecs))
 961
 962 (defun imap-sasl-auth-p (buffer)
 963   (and (condition-case ()
 964            (require 'sasl)
 965          (error nil))
 966        (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
 967
 968 (defun imap-sasl-auth (buffer)
 969   "Login to server using the SASL method."
 970   (message "imap: Authenticating using SASL...")
 971   (with-current-buffer buffer
 972     (make-local-variable 'imap-username)
 973     (make-local-variable 'imap-sasl-client)
 974     (make-local-variable 'imap-sasl-step)
 975     (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
 976           logged user)
 977       (while (not logged)
 978         (setq user (or imap-username
 979                        (read-from-minibuffer
 980                         (concat "IMAP username for " imap-server " using SASL "
 981                                 (sasl-mechanism-name mechanism) ": ")
 982                         (or user imap-default-user))))
 983         (when user
 984           (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
 985                 imap-sasl-step (sasl-next-step imap-sasl-client nil))
 986           (let ((tag (imap-send-command
 987                       (if (sasl-step-data imap-sasl-step)
 988                           (format "AUTHENTICATE %s %s"
 989                                   (sasl-mechanism-name mechanism)
 990                                   (sasl-step-data imap-sasl-step))
 991                         (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
 992                       buffer)))
 993             (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
 994               (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
 995               (setq imap-continuation nil
 996                     imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
 997               (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
 998                                        (base64-encode-string (sasl-step-data imap-sasl-step) t)
 999                                      "")))
1000             (if (imap-ok-p (imap-wait-for-tag tag))
1001                 (setq imap-username user
1002                       logged t)
1003               (message "Login failed...")
1004               (sit-for 1)))))
1005       logged)))