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

   1 ;;; imap.el --- imap library
   2 ;; Copyright (C) 1998, 1999, 2000
   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 (defvar imap-shell-host "gateway"
 223   "Hostname of rlogin proxy.")
 224
 225 (defvar imap-default-user (user-login-name)
 226   "Default username to use.")
 227
 228 (defvar imap-error nil
 229   "Error codes from the last command.")
 230
 231 ;; Various variables.
 232
 233 (defvar imap-fetch-data-hook nil
 234   "Hooks called after receiving each FETCH response.")
 235
 236 (defvar imap-streams '(gssapi kerberos4 starttls ssl network shell)
 237   "Priority of streams to consider when opening connection to server.")
 238
 239 (defvar imap-stream-alist
 240   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 241     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 242     (ssl       imap-ssl-p              imap-ssl-open)
 243     (network   imap-network-p          imap-network-open)
 244     (shell     imap-shell-p            imap-shell-open)
 245     (starttls  imap-starttls-p         imap-starttls-open))
 246   "Definition of network streams.
 247
 248 (NAME CHECK OPEN)
 249
 250 NAME names the stream, CHECK is a function returning non-nil if the
 251 server support the stream and OPEN is a function for opening the
 252 stream.")
 253
 254 (defvar imap-authenticators '(gssapi
 255                               kerberos4
 256                               digest-md5
 257                               cram-md5
 258                               login
 259                               anonymous)
 260   "Priority of authenticators to consider when authenticating to server.")
 261
 262 (defvar imap-authenticator-alist
 263   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 264     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 265     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 266     (login      imap-login-p          imap-login-auth)
 267     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 268     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 269   "Definition of authenticators.
 270
 271 (NAME CHECK AUTHENTICATE)
 272
 273 NAME names the authenticator.  CHECK is a function returning non-nil if
 274 the server support the authenticator and AUTHENTICATE is a function
 275 for doing the actuall authentification.")
 276
 277 (defvar imap-use-utf7 t
 278   "If non-nil, do utf7 encoding/decoding of mailbox names.
 279 Since the UTF7 decoding currently only decodes into ISO-8859-1
 280 characters, you may disable this decoding if you need to access UTF7
 281 encoded mailboxes which doesn't translate into ISO-8859-1.")
 282
 283 ;; Internal constants.  Change theese and die.
 284
 285 (defconst imap-default-port 143)
 286 (defconst imap-default-ssl-port 993)
 287 (defconst imap-default-stream 'network)
 288 (defconst imap-coding-system-for-read 'binary)
 289 (defconst imap-coding-system-for-write 'binary)
 290 (defconst imap-local-variables '(imap-server
 291                                  imap-port
 292                                  imap-client-eol
 293                                  imap-server-eol
 294                                  imap-auth
 295                                  imap-stream
 296                                  imap-username
 297                                  imap-password
 298                                  imap-current-mailbox
 299                                  imap-current-target-mailbox
 300                                  imap-message-data
 301                                  imap-capability
 302                                  imap-namespace
 303                                  imap-state
 304                                  imap-reached-tag
 305                                  imap-failed-tags
 306                                  imap-tag
 307                                  imap-process
 308                                  imap-calculate-literal-size-first
 309                                  imap-mailbox-data))
 310
 311 ;; Internal variables.
 312
 313 (defvar imap-stream nil)
 314 (defvar imap-auth nil)
 315 (defvar imap-server nil)
 316 (defvar imap-port nil)
 317 (defvar imap-username nil)
 318 (defvar imap-password nil)
 319 (defvar imap-calculate-literal-size-first nil)
 320 (defvar imap-state 'closed
 321   "IMAP state.
 322 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 323 and `examine'.")
 324
 325 (defvar imap-server-eol "\r\n"
 326   "The EOL string sent from the server.")
 327
 328 (defvar imap-client-eol "\r\n"
 329   "The EOL string we send to the server.")
 330
 331 (defvar imap-current-mailbox nil
 332   "Current mailbox name.")
 333
 334 (defvar imap-current-target-mailbox nil
 335   "Current target mailbox for COPY and APPEND commands.")
 336
 337 (defvar imap-mailbox-data nil
 338   "Obarray with mailbox data.")
 339
 340 (defvar imap-mailbox-prime 997
 341   "Length of imap-mailbox-data.")
 342
 343 (defvar imap-current-message nil
 344   "Current message number.")
 345
 346 (defvar imap-message-data nil
 347   "Obarray with message data.")
 348
 349 (defvar imap-message-prime 997
 350   "Length of imap-message-data.")
 351
 352 (defvar imap-capability nil
 353   "Capability for server.")
 354
 355 (defvar imap-namespace nil
 356   "Namespace for current server.")
 357
 358 (defvar imap-reached-tag 0
 359   "Lower limit on command tags that have been parsed.")
 360
 361 (defvar imap-failed-tags nil
 362   "Alist of tags that failed.
 363 Each element is a list with four elements; tag (a integer), response
 364 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 365 human readable response text (a string).")
 366
 367 (defvar imap-tag 0
 368   "Command tag number.")
 369
 370 (defvar imap-process nil
 371   "Process.")
 372
 373 (defvar imap-continuation nil
 374   "Non-nil indicates that the server emitted a continuation request.
 375 The actually value is really the text on the continuation line.")
 376
 377 (defvar imap-log nil
 378   "Name of buffer for imap session trace.
 379 For example: (setq imap-log \"*imap-log*\")")
 380
 381 (defvar imap-debug nil                  ;"*imap-debug*"
 382   "Name of buffer for random debug spew.
 383 For example: (setq imap-debug \"*imap-debug*\")")
 384
 385 \f
 386 ;; Utility functions:
 387
 388 (defsubst imap-disable-multibyte ()
 389   "Enable multibyte in the current buffer."
 390   (when (fboundp 'set-buffer-multibyte)
 391     (set-buffer-multibyte nil)))
 392
 393 (defun imap-read-passwd (prompt &rest args)
 394   "Read a password using PROMPT.
 395 If ARGS, PROMPT is used as an argument to `format'."
 396   (let ((prompt (if args
 397                     (apply 'format prompt args)
 398                   prompt)))
 399     (funcall (if (or (fboundp 'read-passwd)
 400                      (and (load "subr" t)
 401                           (fboundp 'read-passwd))
 402                      (and (load "passwd" t)
 403                           (fboundp 'read-passwd)))
 404                  'read-passwd
 405                (autoload 'ange-ftp-read-passwd "ange-ftp")
 406                'ange-ftp-read-passwd)
 407              prompt)))
 408
 409 (defsubst imap-utf7-encode (string)
 410   (if imap-use-utf7
 411       (and string
 412            (condition-case ()
 413                (utf7-encode string t)
 414              (error (message
 415                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 416                      string)
 417                     string)))
 418     string))
 419
 420 (defsubst imap-utf7-decode (string)
 421   (if imap-use-utf7
 422       (and string
 423            (condition-case ()
 424                (utf7-decode string t)
 425              (error (message
 426                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 427                      string)
 428                     string)))
 429     string))
 430
 431 (defsubst imap-ok-p (status)
 432   (if (eq status 'OK)
 433       t
 434     (setq imap-error status)
 435     nil))
 436
 437 (defun imap-error-text (&optional buffer)
 438   (with-current-buffer (or buffer (current-buffer))
 439     (nth 3 (car imap-failed-tags))))
 440
 441 \f
 442 ;; Server functions; stream stuff:
 443
 444 (defun imap-kerberos4-stream-p (buffer)
 445   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 446
 447 (defun imap-kerberos4-open (name buffer server port)
 448   (let ((cmds imap-kerberos4-program)
 449         cmd done)
 450     (while (and (not done) (setq cmd (pop cmds)))
 451       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 452       (erase-buffer)
 453       (let* ((port (or port imap-default-port))
 454              (coding-system-for-read imap-coding-system-for-read)
 455              (coding-system-for-write imap-coding-system-for-write)
 456              (process-connection-type imap-process-connection-type)
 457              (process (start-process
 458                        name buffer shell-file-name shell-command-switch
 459                        (format-spec
 460                         cmd
 461                         (format-spec-make
 462                          ?s server
 463                          ?p (number-to-string port)
 464                          ?l imap-default-user))))
 465              response)
 466         (when process
 467           (with-current-buffer buffer
 468             (setq imap-client-eol "\n"
 469                   imap-calculate-literal-size-first t)
 470             (while (and (memq (process-status process) '(open run))
 471                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 472                         (goto-char (point-min))
 473                    ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 474                         (or (while (looking-at "^C:")
 475                               (forward-line))
 476                             t)
 477                 ;; cyrus 1.6 imtest print "S: " before server greeting
 478                         (or (not (looking-at "S: "))
 479                             (forward-char 3)
 480                             t)
 481                         (not (and (imap-parse-greeting)
 482                                   ;; success in imtest < 1.6:
 483                                   (or (re-search-forward
 484                                        "^__\\(.*\\)__\n" nil t)
 485                                       ;; success in imtest 1.6:
 486                                       (re-search-forward
 487                                        "^\\(Authenticat.*\\)" nil t))
 488                                   (setq response (match-string 1)))))
 489               (accept-process-output process 1)
 490               (sit-for 1))
 491             (and imap-log
 492                  (with-current-buffer (get-buffer-create imap-log)
 493                    (imap-disable-multibyte)
 494                    (buffer-disable-undo)
 495                    (goto-char (point-max))
 496                    (insert-buffer-substring buffer)))
 497             (erase-buffer)
 498             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 499                      (if response (concat "done, " response) "failed"))
 500             (if (and response (let ((case-fold-search nil))
 501                                 (not (string-match "failed" response))))
 502                 (setq done process)
 503               (if (memq (process-status process) '(open run))
 504                   (imap-send-command-wait "LOGOUT"))
 505               (delete-process process)
 506               nil)))))
 507     done))
 508
 509 (defun imap-gssapi-stream-p (buffer)
 510   (imap-capability 'AUTH=GSSAPI buffer))
 511
 512 (defun imap-gssapi-open (name buffer server port)
 513   (let ((cmds imap-gssapi-program)
 514         cmd done)
 515     (while (and (not done) (setq cmd (pop cmds)))
 516       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 517       (let* ((port (or port imap-default-port))
 518              (coding-system-for-read imap-coding-system-for-read)
 519              (coding-system-for-write imap-coding-system-for-write)
 520              (process-connection-type imap-process-connection-type)
 521              (process (start-process
 522                        name buffer shell-file-name shell-command-switch
 523                        (format-spec
 524                         cmd
 525                         (format-spec-make
 526                          ?s server
 527                          ?p (number-to-string port)
 528                          ?l imap-default-user))))
 529              response)
 530         (when process
 531           (with-current-buffer buffer
 532             (setq imap-client-eol "\n"
 533                   imap-calculate-literal-size-first t)
 534             (while (and (memq (process-status process) '(open run))
 535                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 536                         (goto-char (point-min))
 537                    ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 538                         (or (while (looking-at "^C:")
 539                               (forward-line))
 540                             t)
 541                 ;; cyrus 1.6 imtest print "S: " before server greeting
 542                         (or (not (looking-at "S: "))
 543                             (forward-char 3)
 544                             t)
 545                         (not (and (imap-parse-greeting)
 546                                   ;; success in imtest 1.6:
 547                                   (re-search-forward
 548                                    "^\\(Authenticat.*\\)" nil t)
 549                                   (setq response (match-string 1)))))
 550               (accept-process-output process 1)
 551               (sit-for 1))
 552             (and imap-log
 553                  (with-current-buffer (get-buffer-create imap-log)
 554                    (imap-disable-multibyte)
 555                    (buffer-disable-undo)
 556                    (goto-char (point-max))
 557                    (insert-buffer-substring buffer)))
 558             (erase-buffer)
 559             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 560             (if (and response (let ((case-fold-search nil))
 561                                 (not (string-match "failed" response))))
 562                 (setq done process)
 563               (if (memq (process-status process) '(open run))
 564                   (imap-send-command-wait "LOGOUT"))
 565               (delete-process process)
 566               nil)))))
 567     done))
 568
 569 (defun imap-ssl-p (buffer)
 570   nil)
 571
 572 (defun imap-ssl-open (name buffer server port)
 573   "Open a SSL connection to server."
 574   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 575                 (list imap-ssl-program)))
 576         cmd done)
 577     (ignore-errors (require 'ssl))
 578     (while (and (not done) (setq cmd (pop cmds)))
 579       (message "imap: Opening SSL connection with `%s'..." cmd)
 580       (let* ((port (or port imap-default-ssl-port))
 581              (coding-system-for-read imap-coding-system-for-read)
 582              (coding-system-for-write imap-coding-system-for-write)
 583              (ssl-program-name shell-file-name)
 584              (ssl-program-arguments
 585               (list shell-command-switch
 586                     (format-spec cmd (format-spec-make
 587                                       ?s server
 588                                       ?p (number-to-string port)))))
 589              process)
 590         (when (setq process (ignore-errors (open-ssl-stream
 591                                             name buffer server port)))
 592           (with-current-buffer buffer
 593             (goto-char (point-min))
 594             (while (and (memq (process-status process) '(open run))
 595                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 596                         (goto-char (point-max))
 597                         (forward-line -1)
 598                         (not (imap-parse-greeting)))
 599               (accept-process-output process 1)
 600               (sit-for 1))
 601             (and imap-log
 602                  (with-current-buffer (get-buffer-create imap-log)
 603                    (imap-disable-multibyte)
 604                    (buffer-disable-undo)
 605                    (goto-char (point-max))
 606                    (insert-buffer-substring buffer)))
 607             (erase-buffer)
 608             (when (memq (process-status process) '(open run))
 609               (setq done process))))))
 610     (if done
 611         (progn
 612           (message "imap: Opening SSL connection with `%s'...done" cmd)
 613           done)
 614       (message "imap: Opening SSL connection with `%s'...failed" cmd)
 615       nil)))
 616
 617 (defun imap-network-p (buffer)
 618   t)
 619
 620 (defun imap-network-open (name buffer server port)
 621   (let* ((port (or port imap-default-port))
 622          (coding-system-for-read imap-coding-system-for-read)
 623          (coding-system-for-write imap-coding-system-for-write)
 624          (process (open-network-stream name buffer server port)))
 625     (when process
 626       (while (and (memq (process-status process) '(open run))
 627                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 628                   (goto-char (point-min))
 629                   (not (imap-parse-greeting)))
 630         (accept-process-output process 1)
 631         (sit-for 1))
 632       (and imap-log
 633            (with-current-buffer (get-buffer-create imap-log)
 634              (imap-disable-multibyte)
 635              (buffer-disable-undo)
 636              (goto-char (point-max))
 637              (insert-buffer-substring buffer)))
 638       (when (memq (process-status process) '(open run))
 639         process))))
 640
 641 (defun imap-shell-p (buffer)
 642   nil)
 643
 644 (defun imap-shell-open (name buffer server port)
 645   (let ((cmds imap-shell-program)
 646         cmd done)
 647     (while (and (not done) (setq cmd (pop cmds)))
 648       (message "imap: Opening IMAP connection with `%s'..." cmd)
 649       (setq imap-client-eol "\n")
 650       (let* ((port (or port imap-default-port))
 651              (coding-system-for-read imap-coding-system-for-read)
 652              (coding-system-for-write imap-coding-system-for-write)
 653              (process (start-process
 654                        name buffer shell-file-name shell-command-switch
 655                        (format-spec
 656                         cmd
 657                         (format-spec-make
 658                          ?s server
 659                          ?g imap-shell-host
 660                          ?p (number-to-string port)
 661                          ?l imap-default-user)))))
 662         (when process
 663           (while (and (memq (process-status process) '(open run))
 664                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 665                       (goto-char (point-min))
 666                       (not (imap-parse-greeting)))
 667             (accept-process-output process 1)
 668             (sit-for 1))
 669           (and imap-log
 670                (with-current-buffer (get-buffer-create imap-log)
 671                  (imap-disable-multibyte)
 672                  (buffer-disable-undo)
 673                  (goto-char (point-max))
 674                  (insert-buffer-substring buffer)))
 675           (erase-buffer)
 676           (when (memq (process-status process) '(open run))
 677             (setq done process)))))
 678     (if done
 679         (progn
 680           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 681           done)
 682       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 683       nil)))
 684
 685 (defun imap-starttls-p (buffer)
 686   (and (imap-capability 'STARTTLS buffer)
 687        (condition-case ()
 688            (progn
 689              (require 'starttls)
 690              (call-process "starttls"))
 691          (error nil))))
 692
 693 (defun imap-starttls-open (name buffer server port)
 694   (let* ((port (or port imap-default-port))
 695          (coding-system-for-read imap-coding-system-for-read)
 696          (coding-system-for-write imap-coding-system-for-write)
 697          (process (starttls-open-stream name buffer server port))
 698          done)
 699     (message "imap: Connecting with STARTTLS...")
 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-min))
 704                   (not (imap-parse-greeting)))
 705         (accept-process-output process 1)
 706         (sit-for 1))
 707       (and imap-log
 708            (with-current-buffer (get-buffer-create imap-log)
 709              (buffer-disable-undo)
 710              (goto-char (point-max))
 711              (insert-buffer-substring buffer)))
 712       (let ((imap-process process))
 713         (unwind-protect
 714             (progn
 715               (set-process-filter imap-process 'imap-arrival-filter)
 716               (when (and (eq imap-stream 'starttls)
 717                          (imap-ok-p (imap-send-command-wait "STARTTLS")))
 718                 (starttls-negotiate imap-process)))
 719           (set-process-filter imap-process nil)))
 720       (when (memq (process-status process) '(open run))
 721         (setq done process)))
 722     (if done
 723         (progn
 724           (message "imap: Connecting with STARTTLS...done")
 725           done)
 726       (message "imap: Connecting with STARTTLS...failed")
 727       nil)))
 728
 729 ;; Server functions; authenticator stuff:
 730
 731 (defun imap-interactive-login (buffer loginfunc)
 732   "Login to server in BUFFER.
 733 LOGINFUNC is passed a username and a password, it should return t if
 734 it where sucessful authenticating itself to the server, nil otherwise.
 735 Returns t if login was successful, nil otherwise."
 736   (with-current-buffer buffer
 737     (make-local-variable 'imap-username)
 738     (make-local-variable 'imap-password)
 739     (let (user passwd ret)
 740       ;;      (condition-case ()
 741       (while (or (not user) (not passwd))
 742         (setq user (or imap-username
 743                        (read-from-minibuffer
 744                         (concat "IMAP username for " imap-server ": ")
 745                         (or user imap-default-user))))
 746         (setq passwd (or imap-password
 747                          (imap-read-passwd
 748                           (concat "IMAP password for " user "@"
 749                                   imap-server ": "))))
 750         (when (and user passwd)
 751           (if (funcall loginfunc user passwd)
 752               (progn
 753                 (setq ret t
 754                       imap-username user)
 755                 (if (and (not imap-password)
 756                          (y-or-n-p "Store password for this session? "))
 757                     (setq imap-password passwd)))
 758             (message "Login failed...")
 759             (setq passwd nil)
 760             (sit-for 1))))
 761       ;;        (quit (with-current-buffer buffer
 762       ;;                (setq user nil
 763       ;;                      passwd nil)))
 764       ;;        (error (with-current-buffer buffer
 765       ;;                 (setq user nil
 766       ;;