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, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <simon@josefsson.org>
   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 3 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; imap.el is an elisp library providing an interface for talking to
  27 ;; IMAP servers.
  28 ;;
  29 ;; imap.el is roughly divided in two parts, one that parses IMAP
  30 ;; responses from the server and storing data into buffer-local
  31 ;; variables, and one for utility functions which send commands to
  32 ;; server, waits for an answer, and return information.  The latter
  33 ;; part is layered on top of the previous.
  34 ;;
  35 ;; The imap.el API consist of the following functions, other functions
  36 ;; in this file should not be called directly and the result of doing
  37 ;; so are at best undefined.
  38 ;;
  39 ;; Global commands:
  40 ;;
  41 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  42 ;; imap-capability, imap-namespace, imap-error-text
  43 ;;
  44 ;; Mailbox commands:
  45 ;;
  46 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  47 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  48 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  49 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  50 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  51 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  52 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  53 ;;
  54 ;; Message commands:
  55 ;;
  56 ;; imap-fetch-asynch,                 imap-fetch,
  57 ;; imap-current-message,              imap-list-to-message-set,
  58 ;; imap-message-get,                  imap-message-map
  59 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  60 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  61 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  62 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  63 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  64 ;; imap-message-body,                 imap-message-flag-permanent-p
  65 ;; imap-message-flags-set,            imap-message-flags-del
  66 ;; imap-message-flags-add,            imap-message-copyuid
  67 ;; imap-message-copy,                 imap-message-appenduid
  68 ;; imap-message-append,               imap-envelope-from
  69 ;; imap-body-lines
  70 ;;
  71 ;; It is my hope that these commands should be pretty self
  72 ;; explanatory for someone that know IMAP.  All functions have
  73 ;; additional documentation on how to invoke them.
  74 ;;
  75 ;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1).  The implemented
  76 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  77 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  78 ;; LOGINDISABLED) (with use of external library starttls.el and
  79 ;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731
  80 ;; (with use of external program `imtest'), and RFC2971 (ID).  It also
  81 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
  82 ;;
  83 ;; Without the work of John McClary Prevost and Jim Radford this library
  84 ;; would not have seen the light of day.  Many thanks.
  85 ;;
  86 ;; This is a transcript of a short interactive session for demonstration
  87 ;; purposes.
  88 ;;
  89 ;; (imap-open "my.mail.server")
  90 ;; => " *imap* my.mail.server:0"
  91 ;;
  92 ;; The rest are invoked with current buffer as the buffer returned by
  93 ;; `imap-open'.  It is possible to do it all without this, but it would
  94 ;; look ugly here since `buffer' is always the last argument for all
  95 ;; imap.el API functions.
  96 ;;
  97 ;; (imap-authenticate "myusername" "mypassword")
  98 ;; => auth
  99 ;;
 100 ;; (imap-mailbox-lsub "*")
 101 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
 102 ;;
 103 ;; (imap-mailbox-list "INBOX.n%")
 104 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
 105 ;;
 106 ;; (imap-mailbox-select "INBOX.nnimap")
 107 ;; => "INBOX.nnimap"
 108 ;;
 109 ;; (imap-mailbox-get 'exists)
 110 ;; => 166
 111 ;;
 112 ;; (imap-mailbox-get 'uidvalidity)
 113 ;; => "908992622"
 114 ;;
 115 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
 116 ;; => (235 236)
 117 ;;
 118 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
 119 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
 120 ;;
 121 ;; Todo:
 122 ;;
 123 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
 124 ;;   Use IEEE floats (which are effectively exact)?  -- fx
 125 ;; o Don't use `read' at all (important places already fixed)
 126 ;; o Accept list of articles instead of message set string in most
 127 ;;   imap-message-* functions.
 128 ;; o Send strings as literal if they contain, e.g., ".
 129 ;;
 130 ;; Revision history:
 131 ;;
 132 ;;  - 19991218 added starttls/digest-md5 patch,
 133 ;;             by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
 134 ;;             NB! you need SLIM for starttls.el and digest-md5.el
 135 ;;  - 19991023 committed to pgnus
 136 ;;
 137
 138 ;;; Code:
 139
 140 (eval-when-compile (require 'cl))
 141 (eval-and-compile
 142   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
 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 controls the 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 an 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, an 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 buffer.
 237 It is not written to disk, however.  Do not enable this
 238 variable unless you are comfortable with that.
 239
 240 See also `imap-debug'."
 241   :group 'imap
 242   :type 'boolean)
 243
 244 (defcustom imap-debug nil
 245   "If non-nil, trace imap- functions into `imap-debug-buffer'.
 246 Uses `trace-function-background', so you can turn it off with,
 247 say, `untrace-all'.
 248
 249 Note that username, passwords and other privacy sensitive
 250 information (such as e-mail) may be stored in the buffer.
 251 It is not written to disk, however.  Do not enable this
 252 variable unless you are comfortable with that.
 253
 254 This variable only takes effect when loading the `imap' library.
 255 See also `imap-log'."
 256   :group 'imap
 257   :type 'boolean)
 258
 259 (defcustom imap-shell-host "gateway"
 260   "Hostname of rlogin proxy."
 261   :group 'imap
 262   :type 'string)
 263
 264 (defcustom imap-default-user (user-login-name)
 265   "Default username to use."
 266   :group 'imap
 267   :type 'string)
 268
 269 (defcustom imap-read-timeout (if (string-match
 270                                   "windows-nt\\|os/2\\|cygwin"
 271                                   (symbol-name system-type))
 272                                  1.0
 273                                0.1)
 274   "*How long to wait between checking for the end of output.
 275 Shorter values mean quicker response, but is more CPU intensive."
 276   :type 'number
 277   :group 'imap)
 278
 279 (defcustom imap-store-password nil
 280   "If non-nil, store session password without prompting."
 281   :group 'imap
 282   :type 'boolean)
 283
 284 ;; Various variables.
 285
 286 (defvar imap-fetch-data-hook nil
 287   "Hooks called after receiving each FETCH response.")
 288
 289 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 290   "Priority of streams to consider when opening connection to server.")
 291
 292 (defvar imap-stream-alist
 293   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 294     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 295     (tls       imap-tls-p              imap-tls-open)
 296     (ssl       imap-ssl-p              imap-ssl-open)
 297     (network   imap-network-p          imap-network-open)
 298     (shell     imap-shell-p            imap-shell-open)
 299     (starttls  imap-starttls-p         imap-starttls-open))
 300   "Definition of network streams.
 301
 302 \(NAME CHECK OPEN)
 303
 304 NAME names the stream, CHECK is a function returning non-nil if the
 305 server support the stream and OPEN is a function for opening the
 306 stream.")
 307
 308 (defvar imap-authenticators '(gssapi
 309                               kerberos4
 310                               digest-md5
 311                               cram-md5
 312                               ;;sasl
 313                               login
 314                               anonymous)
 315   "Priority of authenticators to consider when authenticating to server.")
 316
 317 (defvar imap-authenticator-alist
 318   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 319     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 320     (sasl       imap-sasl-auth-p      imap-sasl-auth)
 321     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 322     (login      imap-login-p          imap-login-auth)
 323     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 324     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 325   "Definition of authenticators.
 326
 327 \(NAME CHECK AUTHENTICATE)
 328
 329 NAME names the authenticator.  CHECK is a function returning non-nil if
 330 the server support the authenticator and AUTHENTICATE is a function
 331 for doing the actual authentication.")
 332
 333 (defvar imap-error nil
 334   "Error codes from the last command.")
 335
 336 (defvar imap-logout-timeout nil
 337   "Close server immediately if it can't logout in this number of seconds.
 338 If it is nil, never close server until logout completes.  Normally,
 339 the value of this variable will be bound to a certain value to which
 340 an application program that uses this module specifies on a per-server
 341 basis.")
 342
 343 ;; Internal constants.  Change these and die.
 344
 345 (defconst imap-default-port 143)
 346 (defconst imap-default-ssl-port 993)
 347 (defconst imap-default-tls-port 993)
 348 (defconst imap-default-stream 'network)
 349 (defconst imap-coding-system-for-read 'binary)
 350 (defconst imap-coding-system-for-write 'binary)
 351 (defconst imap-local-variables '(imap-server
 352                                  imap-port
 353                                  imap-client-eol
 354                                  imap-server-eol
 355                                  imap-auth
 356                                  imap-stream
 357                                  imap-username
 358                                  imap-password
 359                                  imap-current-mailbox
 360                                  imap-current-target-mailbox
 361                                  imap-message-data
 362                                  imap-capability
 363                                  imap-id
 364                                  imap-namespace
 365                                  imap-state
 366                                  imap-reached-tag
 367                                  imap-failed-tags
 368                                  imap-tag
 369                                  imap-process
 370                                  imap-calculate-literal-size-first
 371                                  imap-mailbox-data))
 372 (defconst imap-log-buffer "*imap-log*")
 373 (defconst imap-debug-buffer "*imap-debug*")
 374
 375 ;; Internal variables.
 376
 377 (defvar imap-stream nil)
 378 (defvar imap-auth nil)
 379 (defvar imap-server nil)
 380 (defvar imap-port nil)
 381 (defvar imap-username nil)
 382 (defvar imap-password nil)
 383 (defvar imap-last-authenticator nil)
 384 (defvar imap-calculate-literal-size-first nil)
 385 (defvar imap-state 'closed
 386   "IMAP state.
 387 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 388 and `examine'.")
 389
 390 (defvar imap-server-eol "\r\n"
 391   "The EOL string sent from the server.")
 392
 393 (defvar imap-client-eol "\r\n"
 394   "The EOL string we send to the server.")
 395
 396 (defvar imap-current-mailbox nil
 397   "Current mailbox name.")
 398
 399 (defvar imap-current-target-mailbox nil
 400   "Current target mailbox for COPY and APPEND commands.")
 401
 402 (defvar imap-mailbox-data nil
 403   "Obarray with mailbox data.")
 404
 405 (defvar imap-mailbox-prime 997
 406   "Length of `imap-mailbox-data'.")
 407
 408 (defvar imap-current-message nil
 409   "Current message number.")
 410
 411 (defvar imap-message-data nil
 412   "Obarray with message data.")
 413
 414 (defvar imap-message-prime 997
 415   "Length of `imap-message-data'.")
 416
 417 (defvar imap-capability nil
 418   "Capability for server.")
 419
 420 (defvar imap-id nil
 421   "Identity of server.
 422 See RFC 2971.")
 423
 424 (defvar imap-namespace nil
 425   "Namespace for current server.")
 426
 427 (defvar imap-reached-tag 0
 428   "Lower limit on command tags that have been parsed.")
 429
 430 (defvar imap-failed-tags nil
 431   "Alist of tags that failed.
 432 Each element is a list with four elements; tag (a integer), response
 433 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 434 human readable response text (a string).")
 435
 436 (defvar imap-tag 0
 437   "Command tag number.")
 438
 439 (defvar imap-process nil
 440   "Process.")
 441
 442 (defvar imap-continuation nil
 443   "Non-nil indicates that the server emitted a continuation request.
 444 The actual value is really the text on the continuation line.")
 445
 446 (defvar imap-callbacks nil
 447   "List of response tags and callbacks, on the form `(number . function)'.
 448 The function should take two arguments, the first the IMAP tag and the
 449 second the status (OK, NO, BAD etc) of the command.")
 450
 451 (defvar imap-enable-exchange-bug-workaround nil
 452   "Send FETCH UID commands as *:* instead of *.
 453
 454 When non-nil, use an alternative UIDS form.  Enabling appears to
 455 be required for some servers (e.g., Microsoft Exchange 2007)
 456 which otherwise would trigger a response 'BAD The specified
 457 message set is invalid.'.  We don't unconditionally use this
 458 form, since this is said to be significantly inefficient.
 459
 460 This variable is set to t automatically per server if the
 461 canonical form fails.")
 462
 463 \f
 464 ;; Utility functions:
 465
 466 (defun imap-remassoc (key alist)
 467   "Delete by side effect any elements of ALIST whose car is `equal' to KEY.
 468 The modified ALIST is returned.  If the first member
 469 of ALIST has a car that is `equal' to KEY, there is no way to remove it
 470 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 471 sure of changing the value of `foo'."
 472   (when alist
 473     (if (equal key (caar alist))
 474         (cdr alist)
 475       (setcdr alist (imap-remassoc key (cdr alist)))
 476       alist)))
 477
 478 (defmacro imap-disable-multibyte ()
 479   "Enable multibyte in the current buffer."
 480   (unless (featurep 'xemacs)
 481     '(set-buffer-multibyte nil)))
 482
 483 (defsubst imap-utf7-encode (string)
 484   (if imap-use-utf7
 485       (and string
 486            (condition-case ()
 487                (utf7-encode string t)
 488              (error (message
 489                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 490                      string)
 491                     string)))
 492     string))
 493
 494 (defsubst imap-utf7-decode (string)
 495   (if imap-use-utf7
 496       (and string
 497            (condition-case ()
 498                (utf7-decode string t)
 499              (error (message
 500                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 501                      string)
 502                     string)))
 503     string))
 504
 505 (defsubst imap-ok-p (status)
 506   (if (eq status 'OK)
 507       t
 508     (setq imap-error status)
 509     nil))
 510
 511 (defun imap-error-text (&optional buffer)
 512   (with-current-buffer (or buffer (current-buffer))
 513     (nth 3 (car imap-failed-tags))))
 514
 515 \f
 516 ;; Server functions; stream stuff:
 517
 518 (defun imap-log (string-or-buffer)
 519   (when imap-log
 520     (with-current-buffer (get-buffer-create imap-log-buffer)
 521       (imap-disable-multibyte)
 522       (buffer-disable-undo)
 523       (goto-char (point-max))
 524       (if (bufferp string-or-buffer)
 525           (insert-buffer-substring string-or-buffer)
 526         (insert string-or-buffer)))))
 527
 528 (defun imap-kerberos4-stream-p (buffer)
 529   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 530
 531 (defun imap-kerberos4-open (name buffer server port)
 532   (let ((cmds imap-kerberos4-program)
 533         cmd done)
 534     (while (and (not done) (setq cmd (pop cmds)))
 535       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 536       (erase-buffer)
 537       (let* ((port (or port imap-default-port))
 538              (coding-system-for-read imap-coding-system-for-read)
 539              (coding-system-for-write imap-coding-system-for-write)
 540              (process-connection-type imap-process-connection-type)
 541              (process (start-process
 542                        name buffer shell-file-name shell-command-switch
 543                        (format-spec
 544                         cmd
 545                         (format-spec-make
 546                          ?s server
 547                          ?p (number-to-string port)
 548                          ?l imap-default-user))))
 549              response)
 550         (when process
 551           (with-current-buffer buffer
 552             (setq imap-client-eol "\n"
 553                   imap-calculate-literal-size-first t)
 554             (while (and (memq (process-status process) '(open run))
 555                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 556                         (goto-char (point-min))
 557                         ;; Athena IMTEST can output SSL verify errors
 558                         (or (while (looking-at "^verify error:num=")
 559                               (forward-line))
 560                             t)
 561                         (or (while (looking-at "^TLS connection established")
 562                               (forward-line))
 563                             t)
 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                                   (or (re-search-forward
 575                                        "^__\\(.*\\)__\n" nil t)
 576                                       ;; success in imtest 1.6:
 577                                       (re-search-forward
 578                                        "^\\(Authenticat.*\\)" nil t))
 579                                   (setq response (match-string 1)))))
 580               (accept-process-output process 1)
 581               (sit-for 1))
 582             (erase-buffer)
 583             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 584                      (if response (concat "done, " response) "failed"))
 585             (if (and response (let ((case-fold-search nil))
 586                                 (not (string-match "failed" response))))
 587                 (setq done process)
 588               (if (memq (process-status process) '(open run))
 589                   (imap-logout))
 590               (delete-process process)
 591               nil)))))
 592     done))
 593
 594 (defun imap-gssapi-stream-p (buffer)
 595   (imap-capability 'AUTH=GSSAPI buffer))
 596
 597 (defun imap-gssapi-open (name buffer server port)
 598   (let ((cmds imap-gssapi-program)
 599         cmd done)
 600     (while (and (not done) (setq cmd (pop cmds)))
 601       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 602       (erase-buffer)
 603       (let* ((port (or port imap-default-port))
 604              (coding-system-for-read imap-coding-system-for-read)
 605              (coding-system-for-write imap-coding-system-for-write)
 606              (process-connection-type imap-process-connection-type)
 607              (process (start-process
 608                        name buffer shell-file-name shell-command-switch
 609                        (format-spec
 610                         cmd
 611                         (format-spec-make
 612                          ?s server
 613                          ?p (number-to-string port)
 614                          ?l imap-default-user))))
 615              response)
 616         (when process
 617           (with-current-buffer buffer
 618             (setq imap-client-eol "\n"
 619                   imap-calculate-literal-size-first t)
 620             (while (and (memq (process-status process) '(open run))
 621                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 622                         (goto-char (point-min))
 623                         ;; Athena IMTEST can output SSL verify errors
 624                         (or (while (looking-at "^verify error:num=")
 625                               (forward-line))
 626                             t)
 627                         (or (while (looking-at "^TLS connection established")
 628                               (forward-line))
 629                             t)
 630                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 631                         (or (while (looking-at "^C:")
 632                               (forward-line))
 633                             t)
 634                         ;; cyrus 1.6 imtest print "S: " before server greeting
 635                         (or (not (looking-at "S: "))
 636                             (forward-char 3)
 637                             t)
 638                         ;; GNU SASL may print 'Trying ...' first.
 639                         (or (not (looking-at "Trying "))
 640                             (forward-line)
 641                             t)
 642                         (not (and (imap-parse-greeting)
 643                                   ;; success in imtest 1.6:
 644                                   (re-search-forward
 645                                    (concat "^\\(\\(Authenticat.*\\)\\|\\("
 646                                            "Client authentication "
 647                                            "finished.*\\)\\)")
 648                                    nil t)
 649                                   (setq response (match-string 1)))))
 650               (accept-process-output process 1)
 651               (sit-for 1))
 652             (imap-log buffer)
 653             (erase-buffer)
 654             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 655             (if (and response (let ((case-fold-search nil))
 656                                 (not (string-match "failed" response))))
 657                 (setq done process)
 658               (if (memq (process-status process) '(open run))