git.chise.org Git - elisp/gnus.git-/blob - lisp/imap.el

   1 ;;; imap.el --- imap library
   2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; imap.el is a elisp library providing an interface for talking to
  28 ;; IMAP servers.
  29 ;;
  30 ;; imap.el is roughly divided in two parts, one that parses IMAP
  31 ;; responses from the server and storing data into buffer-local
  32 ;; variables, and one for utility functions which send commands to
  33 ;; server, waits for an answer, and return information.  The latter
  34 ;; part is layered on top of the previous.
  35 ;;
  36 ;; The imap.el API consist of the following functions, other functions
  37 ;; in this file should not be called directly and the result of doing
  38 ;; so are at best undefined.
  39 ;;
  40 ;; Global commands:
  41 ;;
  42 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  43 ;; imap-capability, imap-namespace, imap-error-text
  44 ;;
  45 ;; Mailbox commands:
  46 ;;
  47 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  48 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  49 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  50 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  51 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  52 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  53 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  54 ;;
  55 ;; Message commands:
  56 ;;
  57 ;; imap-fetch-asynch,                 imap-fetch,
  58 ;; imap-current-message,              imap-list-to-message-set,
  59 ;; imap-message-get,                  imap-message-map
  60 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  61 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  62 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  63 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  64 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  65 ;; imap-message-body,                 imap-message-flag-permanent-p
  66 ;; imap-message-flags-set,            imap-message-flags-del
  67 ;; imap-message-flags-add,            imap-message-copyuid
  68 ;; imap-message-copy,                 imap-message-appenduid
  69 ;; imap-message-append,               imap-envelope-from
  70 ;; imap-body-lines
  71 ;;
  72 ;; It is my hope that theese commands should be pretty self
  73 ;; explanatory for someone that know IMAP.  All functions have
  74 ;; additional documentation on how to invoke them.
  75 ;;
  76 ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
  77 ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  78 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  79 ;; LOGINDISABLED) (with use of external library starttls.el and
  80 ;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
  81 ;; (with use of external program `imtest').  It also take advantage
  82 ;; the UNSELECT extension in Cyrus IMAPD.
  83 ;;
  84 ;; Without the work of John McClary Prevost and Jim Radford this library
  85 ;; would not have seen the light of day.  Many thanks.
  86 ;;
  87 ;; This is a transcript of short interactive session for demonstration
  88 ;; purposes.
  89 ;;
  90 ;; (imap-open "my.mail.server")
  91 ;; => " *imap* my.mail.server:0"
  92 ;;
  93 ;; The rest are invoked with current buffer as the buffer returned by
  94 ;; `imap-open'.  It is possible to do all without this, but it would
  95 ;; look ugly here since `buffer' is always the last argument for all
  96 ;; imap.el API functions.
  97 ;;
  98 ;; (imap-authenticate "myusername" "mypassword")
  99 ;; => auth
 100 ;;
 101 ;; (imap-mailbox-lsub "*")
 102 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
 103 ;;
 104 ;; (imap-mailbox-list "INBOX.n%")
 105 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
 106 ;;
 107 ;; (imap-mailbox-select "INBOX.nnimap")
 108 ;; => "INBOX.nnimap"
 109 ;;
 110 ;; (imap-mailbox-get 'exists)
 111 ;; => 166
 112 ;;
 113 ;; (imap-mailbox-get 'uidvalidity)
 114 ;; => "908992622"
 115 ;;
 116 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
 117 ;; => (235 236)
 118 ;;
 119 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
 120 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
 121 ;;
 122 ;; Todo:
 123 ;;
 124 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
 125 ;; o Don't use `read' at all (important places already fixed)
 126 ;; o Accept list of articles instead of message set string in most
 127 ;;   imap-message-* functions.
 128 ;;
 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-when-compile (require 'static))
 141
 142 (require 'base64)
 143
 144 (eval-and-compile
 145   (autoload 'starttls-open-stream "starttls")
 146   (autoload 'starttls-negotiate "starttls")
 147   (autoload 'rfc2104-hash "rfc2104")
 148   (autoload 'md5 "md5")
 149   (autoload 'utf7-encode "utf7")
 150   (autoload 'utf7-decode "utf7")
 151   (autoload 'format-spec "format-spec")
 152   (autoload 'format-spec-make "format-spec")
 153   (autoload 'open-tls-stream "tls")
 154   ;; Avoid use gnus-point-at-eol so we're independent of Gnus.  These
 155   ;; days we have point-at-eol anyhow.
 156   (if (fboundp 'point-at-eol)
 157       (defalias 'imap-point-at-eol 'point-at-eol)
 158     (defun imap-point-at-eol ()
 159       (save-excursion
 160         (end-of-line)
 161         (point))))
 162   (autoload 'sasl-digest-md5-digest-response "sasl"))
 163
 164 ;; User variables.
 165
 166 (defgroup imap nil
 167   "Low-level IMAP issues."
 168   :version "21.1"
 169   :group 'mail)
 170
 171 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 172                                     "imtest -kp %s %p")
 173   "List of strings containing commands for Kerberos 4 authentication.
 174 %s is replaced with server hostname, %p with port to connect to, and
 175 %l with the value of `imap-default-user'.  The program should accept
 176 IMAP commands on stdin and return responses to stdout.  Each entry in
 177 the list is tried until a successful connection is made."
 178   :group 'imap
 179   :type '(repeat string))
 180
 181 (defcustom imap-gssapi-program (list
 182                                 (concat "gsasl --client --connect %s:%p "
 183                                         "--imap --application-data "
 184                                         "--mechanism GSSAPI "
 185                                         "--authentication-id %l")
 186                                 "imtest -m gssapi -u %l -p %p %s")
 187   "List of strings containing commands for GSSAPI (krb5) authentication.
 188 %s is replaced with server hostname, %p with port to connect to, and
 189 %l with the value of `imap-default-user'.  The program should accept
 190 IMAP commands on stdin and return responses to stdout.  Each entry in
 191 the list is tried until a successful connection is made."
 192   :group 'imap
 193   :type '(repeat string))
 194
 195 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 196                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 197                               "s_client -quiet -ssl3 -connect %s:%p"
 198                               "s_client -quiet -ssl2 -connect %s:%p")
 199   "A string, or list of strings, containing commands for SSL connections.
 200 Within a string, %s is replaced with the server address and %p with
 201 port number on server.  The program should accept IMAP commands on
 202 stdin and return responses to stdout.  Each entry in the list is tried
 203 until a successful connection is made."
 204   :group 'imap
 205   :type '(choice string
 206                  (repeat string)))
 207
 208 (defcustom imap-shell-program '("ssh %s imapd"
 209                                 "rsh %s imapd"
 210                                 "ssh %g ssh %s imapd"
 211                                 "rsh %g rsh %s imapd")
 212   "A list of strings, containing commands for IMAP connection.
 213 Within a string, %s is replaced with the server address, %p with port
 214 number on server, %g with `imap-shell-host', and %l with
 215 `imap-default-user'.  The program should read IMAP commands from stdin
 216 and write IMAP response to stdout. Each entry in the list is tried
 217 until a successful connection is made."
 218   :group 'imap
 219   :type '(repeat string))
 220
 221 (defcustom imap-process-connection-type nil
 222   "*Value for `process-connection-type' to use for Kerberos4 and GSSAPI."
 223   :group 'imap
 224   :type 'boolean)
 225
 226 (defcustom imap-use-utf7 t
 227   "If non-nil, do utf7 encoding/decoding of mailbox names.
 228 Since the UTF7 decoding currently only decodes into ISO-8859-1
 229 characters, you may disable this decoding if you need to access UTF7
 230 encoded mailboxes which doesn't translate into ISO-8859-1."
 231   :group 'imap
 232   :type 'boolean)
 233
 234 (defcustom imap-log nil
 235   "If non-nil, a imap session trace is placed in *imap-log* buffer."
 236   :group 'imap
 237   :type 'boolean)
 238
 239 (defcustom imap-debug nil
 240   "If non-nil, random debug spews are placed in *imap-debug* buffer."
 241   :group 'imap
 242   :type 'boolean)
 243
 244 (defcustom imap-shell-host "gateway"
 245   "Hostname of rlogin proxy."
 246   :group 'imap
 247   :type 'string)
 248
 249 (defcustom imap-default-user (user-login-name)
 250   "Default username to use."
 251   :group 'imap
 252   :type 'string)
 253
 254 (defcustom imap-read-timeout (if (string-match
 255                                   "windows-nt\\|os/2\\|emx\\|cygwin"
 256                                   (symbol-name system-type))
 257                                  1.0
 258                                0.1)
 259   "*How long to wait between checking for the end of output.
 260 Shorter values mean quicker response, but is more CPU intensive."
 261   :type 'number
 262   :group 'imap)
 263
 264 ;; Various variables.
 265
 266 (defvar imap-fetch-data-hook nil
 267   "Hooks called after receiving each FETCH response.")
 268
 269 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 270   "Priority of streams to consider when opening connection to server.")
 271
 272 (defvar imap-stream-alist
 273   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 274     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 275     (tls       imap-tls-p              imap-tls-open)
 276     (ssl       imap-ssl-p              imap-ssl-open)
 277     (network   imap-network-p          imap-network-open)
 278     (shell     imap-shell-p            imap-shell-open)
 279     (starttls  imap-starttls-p         imap-starttls-open))
 280   "Definition of network streams.
 281
 282 \(NAME CHECK OPEN)
 283
 284 NAME names the stream, CHECK is a function returning non-nil if the
 285 server support the stream and OPEN is a function for opening the
 286 stream.")
 287
 288 (defvar imap-authenticators '(gssapi
 289                               kerberos4
 290                               digest-md5
 291                               cram-md5
 292                               login
 293                               anonymous)
 294   "Priority of authenticators to consider when authenticating to server.")
 295
 296 (defvar imap-authenticator-alist
 297   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 298     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 299     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 300     (login      imap-login-p          imap-login-auth)
 301     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 302     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 303   "Definition of authenticators.
 304
 305 \(NAME CHECK AUTHENTICATE)
 306
 307 NAME names the authenticator.  CHECK is a function returning non-nil if
 308 the server support the authenticator and AUTHENTICATE is a function
 309 for doing the actual authentication.")
 310
 311 (defvar imap-error nil
 312   "Error codes from the last command.")
 313
 314 ;; Internal constants.  Change theese and die.
 315
 316 (defconst imap-default-port 143)
 317 (defconst imap-default-ssl-port 993)
 318 (defconst imap-default-tls-port 993)
 319 (defconst imap-default-stream 'network)
 320 (defconst imap-local-variables '(imap-server
 321                                  imap-port
 322                                  imap-client-eol
 323                                  imap-server-eol
 324                                  imap-auth
 325                                  imap-stream
 326                                  imap-username
 327                                  imap-password
 328                                  imap-current-mailbox
 329                                  imap-current-target-mailbox
 330                                  imap-message-data
 331                                  imap-capability
 332                                  imap-namespace
 333                                  imap-state
 334                                  imap-reached-tag
 335                                  imap-failed-tags
 336                                  imap-tag
 337                                  imap-process
 338                                  imap-calculate-literal-size-first
 339                                  imap-mailbox-data))
 340 (defconst imap-log-buffer "*imap-log*")
 341 (defconst imap-debug-buffer "*imap-debug*")
 342
 343 ;; Internal variables.
 344
 345 (defvar imap-stream nil)
 346 (defvar imap-auth nil)
 347 (defvar imap-server nil)
 348 (defvar imap-port nil)
 349 (defvar imap-username nil)
 350 (defvar imap-password nil)
 351 (defvar imap-calculate-literal-size-first nil)
 352 (defvar imap-state 'closed
 353   "IMAP state.
 354 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 355 and `examine'.")
 356
 357 (defvar imap-server-eol "\r\n"
 358   "The EOL string sent from the server.")
 359
 360 (defvar imap-client-eol "\r\n"
 361   "The EOL string we send to the server.")
 362
 363 (defvar imap-current-mailbox nil
 364   "Current mailbox name.")
 365
 366 (defvar imap-current-target-mailbox nil
 367   "Current target mailbox for COPY and APPEND commands.")
 368
 369 (defvar imap-mailbox-data nil
 370   "Obarray with mailbox data.")
 371
 372 (defvar imap-mailbox-prime 997
 373   "Length of imap-mailbox-data.")
 374
 375 (defvar imap-current-message nil
 376   "Current message number.")
 377
 378 (defvar imap-message-data nil
 379   "Obarray with message data.")
 380
 381 (defvar imap-message-prime 997
 382   "Length of imap-message-data.")
 383
 384 (defvar imap-capability nil
 385   "Capability for server.")
 386
 387 (defvar imap-namespace nil
 388   "Namespace for current server.")
 389
 390 (defvar imap-reached-tag 0
 391   "Lower limit on command tags that have been parsed.")
 392
 393 (defvar imap-failed-tags nil
 394   "Alist of tags that failed.
 395 Each element is a list with four elements; tag (a integer), response
 396 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 397 human readable response text (a string).")
 398
 399 (defvar imap-tag 0
 400   "Command tag number.")
 401
 402 (defvar imap-process nil
 403   "Process.")
 404
 405 (defvar imap-continuation nil
 406   "Non-nil indicates that the server emitted a continuation request.
 407 The actual value is really the text on the continuation line.")
 408
 409 (defvar imap-callbacks nil
 410   "List of response tags and callbacks, on the form `(number . function)'.
 411 The function should take two arguments, the first the IMAP tag and the
 412 second the status (OK, NO, BAD etc) of the command.")
 413
 414 \f
 415 ;; Utility functions:
 416
 417 (defun imap-remassoc (key alist)
 418   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
 419 The modified LIST is returned.  If the first member
 420 of LIST has a car that is `equal' to KEY, there is no way to remove it
 421 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 422 sure of changing the value of `foo'."
 423   (when alist
 424     (if (equal key (caar alist))
 425         (cdr alist)
 426       (setcdr alist (imap-remassoc key (cdr alist)))
 427       alist)))
 428
 429 (defsubst imap-utf7-encode (string)
 430   (if imap-use-utf7
 431       (and string
 432            (condition-case ()
 433                (utf7-encode string t)
 434              (error (message
 435                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 436                      string)
 437                     string)))
 438     string))
 439
 440 (defsubst imap-utf7-decode (string)
 441   (if imap-use-utf7
 442       (and string
 443            (condition-case ()
 444                (utf7-decode string t)
 445              (error (message
 446                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 447                      string)
 448                     string)))
 449     string))
 450
 451 (defsubst imap-ok-p (status)
 452   (if (eq status 'OK)
 453       t
 454     (setq imap-error status)
 455     nil))
 456
 457 (defun imap-error-text (&optional buffer)
 458   (with-current-buffer (or buffer (current-buffer))
 459     (nth 3 (car imap-failed-tags))))
 460
 461 \f
 462 ;; Server functions; stream stuff:
 463
 464 (defun imap-kerberos4-stream-p (buffer)
 465   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 466
 467 (defun imap-kerberos4-open (name buffer server port)
 468   (let ((cmds imap-kerberos4-program)
 469         cmd done)
 470     (while (and (not done) (setq cmd (pop cmds)))
 471       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 472       (erase-buffer)
 473       (let* ((port (or port imap-default-port))
 474              (process-connection-type imap-process-connection-type)
 475              (process (as-binary-process
 476                        (start-process
 477                         name buffer shell-file-name shell-command-switch
 478                         (format-spec
 479                          cmd
 480                          (format-spec-make
 481                           ?s server
 482                           ?p (number-to-string port)
 483                           ?l imap-default-user)))))
 484              response)
 485         (when process
 486           (with-current-buffer buffer
 487             (setq imap-client-eol "\n"
 488                   imap-calculate-literal-size-first t)
 489             (while (and (memq (process-status process) '(open run))
 490                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 491                         (goto-char (point-min))
 492                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 493                         (or (while (looking-at "^C:")
 494                               (forward-line))
 495                             t)
 496                         ;; cyrus 1.6 imtest print "S: " before server greeting
 497                         (or (not (looking-at "S: "))
 498                             (forward-char 3)
 499                             t)
 500                         (not (and (imap-parse-greeting)
 501                                   ;; success in imtest < 1.6:
 502                                   (or (re-search-forward
 503                                        "^__\\(.*\\)__\n" nil t)
 504                                       ;; success in imtest 1.6:
 505                                       (re-search-forward
 506                                        "^\\(Authenticat.*\\)" nil t))
 507                                   (setq response (match-string 1)))))
 508               (accept-process-output process 1)
 509               (sit-for 1))
 510             (and imap-log
 511                  (with-current-buffer (get-buffer-create imap-log-buffer)
 512                    (buffer-disable-undo)
 513                    (goto-char (point-max))
 514                    (insert-buffer-substring buffer)))
 515             (erase-buffer)
 516             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 517                      (if response (concat "done, " response) "failed"))
 518             (if (and response (let ((case-fold-search nil))
 519                                 (not (string-match "failed" response))))
 520                 (setq done process)
 521               (if (memq (process-status process) '(open run))
 522                   (imap-send-command "LOGOUT"))
 523               (delete-process process)
 524               nil)))))
 525     done))
 526
 527 (defun imap-gssapi-stream-p (buffer)
 528   (imap-capability 'AUTH=GSSAPI buffer))
 529
 530 (defun imap-gssapi-open (name buffer server port)
 531   (let ((cmds imap-gssapi-program)
 532         cmd done)
 533     (while (and (not done) (setq cmd (pop cmds)))
 534       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 535       (erase-buffer)
 536       (let* ((port (or port imap-default-port))
 537              (process-connection-type imap-process-connection-type)
 538              (process (as-binary-process
 539                        (start-process
 540                         name buffer shell-file-name shell-command-switch
 541                         (format-spec
 542                          cmd
 543                          (format-spec-make
 544                           ?s server
 545                           ?p (number-to-string port)
 546                           ?l imap-default-user)))))
 547              response)
 548         (when process
 549           (with-current-buffer buffer
 550             (setq imap-client-eol "\n"
 551                   imap-calculate-literal-size-first t)
 552             (while (and (memq (process-status process) '(open run))
 553                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 554                         (goto-char (point-min))
 555                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 556                         (or (while (looking-at "^C:")
 557                               (forward-line))
 558                             t)
 559                         ;; cyrus 1.6 imtest print "S: " before server greeting
 560                         (or (not (looking-at "S: "))
 561                             (forward-char 3)
 562                             t)
 563                         (not (and (imap-parse-greeting)
 564                                   ;; success in imtest 1.6:
 565                                   (re-search-forward
 566                                    (concat "^\\(\\(Authenticat.*\\)\\|\\("
 567                                            "Client authentication "
 568                                            "finished.*\\)\\)")
 569                                    nil t)
 570                                   (setq response (match-string 1)))))
 571               (accept-process-output process 1)
 572               (sit-for 1))
 573             (and imap-log
 574                  (with-current-buffer (get-buffer-create imap-log-buffer)
 575                    (buffer-disable-undo)
 576                    (goto-char (point-max))
 577                    (insert-buffer-substring buffer)))
 578             (erase-buffer)
 579             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 580             (if (and response (let ((case-fold-search nil))
 581                                 (not (string-match "failed" response))))
 582                 (setq done process)
 583               (if (memq (process-status process) '(open run))
 584                   (imap-send-command "LOGOUT"))
 585               (delete-process process)
 586               nil)))))
 587     done))
 588
 589 (defun imap-ssl-p (buffer)
 590   nil)
 591
 592 (defun imap-ssl-open (name buffer server port)
 593   "Open a SSL connection to server."
 594   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 595                 (list imap-ssl-program)))
 596         cmd done)
 597     (while (and (not done) (setq cmd (pop cmds)))
 598       (message "imap: Opening SSL connection with `%s'..." cmd)
 599       (erase-buffer)
 600       (let ((port (or port imap-default-ssl-port))
 601             (process-connection-type nil)
 602             process)
 603         (when (prog1
 604                   (setq process (as-binary-process
 605                                  (start-process
 606                                   name buffer shell-file-name
 607                                   shell-command-switch
 608                                   (format-spec cmd
 609                                                (format-spec-make
 610                                                 ?s server
 611                                                 ?p (number-to-string port))))))
 612                 (process-kill-without-query process))
 613           (with-current-buffer buffer
 614             (goto-char (point-min))
 615             (while (and (memq (process-status process) '(open run))
 616                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 617                         (goto-char (point-max))
 618                         (forward-line -1)
 619                         (not (imap-parse-greeting)))
 620               (accept-process-output process 1)
 621               (sit-for 1))
 622             (and imap-log
 623                  (with-current-buffer (get-buffer-create imap-log-buffer)
 624                    (buffer-disable-undo)
 625                    (goto-char (point-max))
 626                    (insert-buffer-substring buffer)))
 627             (erase-buffer)
 628             (when (memq (process-status process) '(open run))
 629               (setq done process))))))
 630     (if done
 631         (progn
 632           (message "imap: Opening SSL connection with `%s'...done" cmd)
 633           done)
 634       (message "imap: Opening SSL connection with `%s'...failed" cmd)
 635       nil)))
 636
 637 (defun imap-tls-p (buffer)
 638   nil)
 639
 640 (defun imap-tls-open (name buffer server port)
 641   (let* ((port (or port imap-default-tls-port))
 642          (process (open-tls-stream name buffer server port)))
 643     (when process
 644       (while (and (memq (process-status process) '(open run))
 645                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 646                   (goto-char (point-max))
 647                   (forward-line -1)
 648                   (not (imap-parse-greeting)))
 649         (accept-process-output process 1)
 650         (sit-for 1))
 651       (and imap-log
 652            (with-current-buffer (get-buffer-create imap-log-buffer)
 653              (set-buffer-multibyte nil)
 654              (buffer-disable-undo)
 655              (goto-char (point-max))
 656              (insert-buffer-substring buffer)))
 657       (when (memq (process-status process) '(open run))
 658         process))))
 659
 660 (defun imap-network-p (buffer)
 661   t)
 662
 663 (defun imap-network-open (name buffer server port)
 664   (let* ((port (or port imap-default-port))
 665          (process (open-network-stream-as-binary name buffer server port)))
 666     (when process
 667       (while (and (memq (process-status process) '(open run))
 668                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 669                   (goto-char (point-min))
 670                   (not (imap-parse-greeting)))
 671         (accept-process-output process 1)
 672         (sit-for 1))
 673       (and imap-log
 674            (with-current-buffer (get-buffer-create imap-log-buffer)
 675              (buffer-disable-undo)
 676              (goto-char (point-max))
 677              (insert-buffer-substring buffer)))
 678       (when (memq (process-status process) '(open run))
 679         process))))
 680
 681 (defun imap-shell-p (buffer)
 682   nil)
 683
 684 (defun imap-shell-open (name buffer server port)
 685   (let ((cmds (if (listp imap-shell-program) imap-shell-program
 686                 (list imap-shell-program)))
 687         cmd done)
 688     (while (and (not done) (setq cmd (pop cmds)))
 689       (message "imap: Opening IMAP connection with `%s'..." cmd)
 690       (setq imap-client-eol "\n")
 691       (let* ((port (or port imap-default-port))
 692              (process (as-binary-process
 693                        (start-process
 694                         name buffer shell-file-name shell-command-switch
 695                         (format-spec
 696                          cmd
 697                          (format-spec-make
 698                           ?s server
 699                           ?g imap-shell-host
 700                           ?p (number-to-string port)
 701                           ?l imap-default-user))))))
 702         (when process
 703           (while (and (memq (process-status process) '(open run))
 704                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 705                       (goto-char (point-max))
 706                       (forward-line -1)
 707                       (not (imap-parse-greeting)))
 708             (accept-process-output process 1)
 709             (sit-for 1))
 710           (and imap-log
 711                (with-current-buffer (get-buffer-create imap-log-buffer)
 712                  (buffer-disable-undo)
 713                  (goto-char (point-max))
 714                  (insert-buffer-substring buffer)))
 715           (erase-buffer)
 716           (when (memq (process-status process) '(open run))
 717             (setq done process)))))
 718     (if done
 719         (progn
 720           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 721           done)
 722       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 723       nil)))
 724
 725 (defun imap-starttls-p (buffer)
 726   (imap-capability 'STARTTLS buffer))
 727
 728 (defun imap-starttls-open (name buffer server port)
 729   (let* ((port (or port imap-default-port))
 730          (process (as-binary-process
 731                    (starttls-open-stream name buffer server port)))
 732          done)
 733     (message "imap: Connecting with STARTTLS...")
 734     (when process
 735       (while (and (memq (process-status process) '(open run))
 736                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 737                   (goto-char (point-min))
 738                   (not (imap-parse-greeting)))
 739         (accept-process-output process 1)
 740         (sit-for 1))
 741       (and imap-log
 742            (with-current-buffer (get-buffer-create imap-log-buffer)
 743              (buffer-disable-undo)
 744              (goto-char (point-max))
 745              (insert-buffer-substring buffer)))
 746       (let ((imap-process process))
 747         (unwind-protect
 748             (progn
 749               (set-process-filter imap-process 'imap-arrival-filter)
 750               (when (and (eq imap-stream 'starttls)
 751                          (imap-ok-p (imap-send-command-wait "STARTTLS")))
 752                 (starttls-negotiate imap-process)))
 753           (set-process-filter imap-process nil)))
 754       (when (memq (process-status process) '(open run))
 755         (setq done process)))
 756     (if done
 757         (progn
 758           (message "imap: Connecting with STARTTLS...done")
 759           done)
 760       (message "imap: Connecting with STARTTLS...failed")
 761       nil)))
 762
 763 ;; Server functions; authenticator stuff:
 764
 765 (defun imap-interactive-login (buffer loginfunc)
 766   "Login to server in BUFFER.
 767 LOGINFUNC is passed a username and a password, it should return t if
 768 it where successful authenticating itself to the server, nil otherwise.
 769 Returns t if login was successful, nil otherwise."
 770   (with-current-buffer buffer
 771     (make-local-variable 'imap-username)
 772     (make-local-variable 'imap-password)
 773     (let (user passwd ret)
 774       ;;      (condition-case ()
 775       (while (or (not user) (not passwd))
 776         (setq user (or imap-username
 777                        (read-from-minibuffer
 778                         (concat "IMAP username for " imap-server
 779                                 " (using stream `" (symbol-name imap-stream)
 780                                 "'): ")
 781                         (or user imap-default-user))))
 782         (setq passwd (or imap-password
 783                          (read-passwd
 784                           (concat "IMAP password for " user "@"
 785                                   imap-server " (using authenticator `"
 786                                   (symbol-name imap-auth) "'): "))))
 787         (when (and user passwd)
 788           (if (funcall loginfunc user passwd)
 789               (progn
 790                 (setq ret t
 791                       imap-username user)
 792                 (if (and (not imap-password)
 793                          (y-or-n-p "Store password for this session? "))
 794                     (setq imap-password passwd)))
 795             (message "Login failed...")
 796             (setq passwd nil)
 797             (sit-for 1))))
 798       ;;        (quit (with-current-buffer buffer
 799       ;;                (setq user nil
 800       ;;                      passwd nil)))
 801       ;;        (error (with-current-buffer buffer
 802       ;;                 (setq user nil
 803       ;;                       passwd nil))))
 804       ret)))
 805
 806 (defun imap-gssapi-auth-p (buffer)
 807   (and (imap-capability 'AUTH=GSSAPI buffer)
 808        (eq imap-stream 'gssapi)))
 809
 810 (defun imap-gssapi-auth (buffer)
 811   (message "imap: Authenticating using GSSAPI...%s"
 812            (if (eq imap-stream 'gssapi) "done" "failed"))
 813   (eq imap-stream 'gssapi))
 814
 815 (defun imap-kerberos4-auth-p (buffer)
 816   (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
 817        (eq imap-stream 'kerberos4)))
 818
 819 (defun imap-kerberos4-auth (buffer)
 820   (message "imap: Authenticating using Kerberos 4...%s"
 821            (if (eq imap-stream 'kerberos4) "done" "failed"))
 822   (eq imap-stream 'kerberos4))
 823
 824 (defun imap-cram-md5-p (buffer)
 825   (imap-capability 'AUTH=CRAM-MD5 buffer))
 826
 827 (defun imap-cram-md5-auth (buffer)
 828   "Login to server using the AUTH CRAM-MD5 method."
 829   (message "imap: Authenticating using CRAM-MD5...")
 830   (let ((done (imap-interactive-login
 831                buffer
 832                (lambda (user passwd)
 833                  (imap-ok-p
 834                   (imap-send-command-wait
 835                    (list
 836                     "AUTHENTICATE CRAM-MD5"
 837                     (lambda (challenge)
 838                       (let* ((decoded (base64-decode-string challenge))
 839                              (hash-function
 840                               (if (and (featurep 'xemacs)
 841                                        (>= (function-max-args 'md5) 4))
 842                                   (lambda (object &optional start end)
 843                                     (md5 object start end 'binary))
 844                                 'md5))
 845                              (hash (rfc2104-hash hash-function 64 16
 846                                                  passwd decoded))
 847                              (response (concat user " " hash))
 848                              (encoded (base64-encode-string response)))
 849                         encoded)))))))))
 850     (if done
 851         (message "imap: Authenticating using CRAM-MD5...done")
 852       (message "imap: Authenticating using CRAM-MD5...failed"))))
 853
 854 (defun imap-login-p (buffer)
 855   (and (not (imap-capability 'LOGINDISABLED buffer))
 856        (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
 857
 858 (defun imap-login-auth (buffer)
 859   "Login to server using the LOGIN command."
 860   (message "imap: Plaintext authentication...")
 861   (imap-interactive-login buffer
 862                           (lambda (user passwd)
 863                             (imap-ok-p (imap-send-command-wait
 864                                         (concat "LOGIN \"" user "\" \""
 865                                                 passwd "\""))))))
 866
 867 (defun imap-anonymous-p (buffer)
 868   t)
 869
 870 (defun imap-anonymous-auth (buffer)
 871   (message "imap: Logging in anonymously...")
 872   (with-current-buffer buffer
 873     (imap-ok-p (imap-send-command-wait
 874                 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
 875                                                      (system-name)) "\"")))))
 876
 877 (defun imap-digest-md5-p (buffer)
 878   (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
 879        (condition-case ()
 880            (require 'digest-md5)
 881          (error nil))))
 882
 883 (defun imap-digest-md5-auth (buffer)
 884   "Login to server using the AUTH DIGEST-MD5 method."
 885   (message "imap: Authenticating using DIGEST-MD5...")
 886   (imap-interactive-login
 887    buffer
 888    (lambda (user passwd)
 889      (let ((tag
 890             (imap-send-command
 891              (list
 892               "AUTHENTICATE DIGEST-MD5"
 893               (lambda (challenge)
 894                 (base64-encode-string
 895                  (sasl-digest-md5-digest-response
 896                   (base64-decode-string challenge)
 897                   user passwd "imap" imap-server)
 898                  'no-line-break))))))
 899        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
 900            nil
 901          (setq imap-continuation nil)
 902          (imap-send-command-1 "")
 903          (imap-ok-p (imap-wait-for-tag tag)))))))
 904
 905 ;; Server functions:
 906
 907 (defun imap-open-1 (buffer)
 908   (with-current-buffer buffer
 909     (erase-buffer)
 910     (setq imap-current-mailbox nil
 911           imap-current-message nil
 912           imap-state 'initial
 913           imap-process (condition-case ()
 914                            (funcall (nth 2 (assq imap-stream
 915                                                  imap-stream-alist))
 916                                     "imap" buffer imap-server imap-port)
 917                          ((error quit) nil)))
 918     (when imap-process
 919       (set-process-filter imap-process 'imap-arrival-filter)
 920       (set-process-sentinel imap-process 'imap-sentinel)
 921       (while (and (eq imap-state 'initial)
 922                   (memq (process-status imap-process) '(open run)))
 923         (message "Waiting for response from %s..." imap-server)
 924         (accept-process-output imap-process 1))
 925       (message "Waiting for response from %s...done" imap-server)
 926       (and (memq (process-status imap-process) '(open run))
 927            imap-process))))
 928
 929 (defun imap-open (server &optional port stream auth buffer)
 930   "Open a IMAP connection to host SERVER at PORT returning a buffer.
 931 If PORT is unspecified, a default value is used (143 except
 932 for SSL which use 993).
 933 STREAM indicates the stream to use, see `imap-streams' for available
 934 streams.  If nil, it choices the best stream the server is capable of.
 935 AUTH indicates authenticator to use, see `imap-authenticators' for
 936 available authenticators.  If nil, it choices the best stream the
 937 server is capable of.
 938 BUFFER can be a buffer or a name of a buffer, which is created if
 939 necessary.  If nil, the buffer name is generated."
 940   (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
 941   (with-current-buffer (get-buffer-create buffer)
 942     (if (imap-opened buffer)
 943         (imap-close buffer))
 944     (mapcar 'make-local-variable imap-local-variables)
 945     (set-buffer-multibyte nil)
 946     (buffer-disable-undo)
 947     (setq imap-server (or server imap-server))
 948     (setq imap-port (or port imap-port))
 949     (setq imap-auth (or auth imap-auth))
 950     (setq imap-stream (or stream imap-stream))
 951     (message "imap: Connecting to %s..." imap-server)
 952     (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
 953                 (imap-open-1 buffer)))
 954         (progn
 955           (message "imap: Connecting to %s...failed" imap-server)
 956           nil)
 957       (when (null imap-stream)
 958         ;; Need to choose stream.
 959         (let ((streams imap-streams))
 960           (while (setq stream (pop streams))
 961             ;; OK to use this stream?
 962             (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
 963               ;; Stream changed?
 964               (if (not (eq imap-default-stream stream))
 965                   (with-current-buffer (get-buffer-create
 966                                         (generate-new-buffer-name " *temp*"))
 967                     (mapcar 'make-local-variable imap-local-variables)
 968                     (set-buffer-multibyte nil)
 969                     (buffer-disable-undo)
 970                     (setq imap-server (or server imap-server))
 971                     (setq imap-port (or port imap-port))
 972                     (setq imap-auth (or auth imap-auth))
 973                     (message "imap: Reconnecting with stream `%s'..." stream)
 974                     (if (null (let ((imap-stream stream))
 975                                 (imap-open-1 (current-buffer))))
 976                         (progn
 977                           (kill-buffer (current-buffer))
 978                           (message
 979                            "imap: Reconnecting with stream `%s'...failed"
 980                            stream))
 981                       ;; We're done, kill the first connection
 982                       (imap-close buffer)
 983                       (kill-buffer buffer)
 984                       (rename-buffer buffer)
 985                       (message "imap: Reconnecting with stream `%s'...done"
 986                                stream)
 987                       (setq imap-stream stream)
 988                       (setq imap-capability nil)
 989                       (setq streams nil)))
 990                 ;; We're done
 991                 (message "imap: Connecting to %s...done" imap-server)
 992                 (setq imap-stream stream)
 993                 (setq imap-capability nil)
 994                 (setq streams nil))))))
 995       (when (imap-opened buffer)
 996         (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
 997       (when imap-stream
 998         buffer))))
 999
1000 (defun imap-opened (&optional buffer)
1001   "Return non-nil if connection to imap server in BUFFER is open.
1002 If BUFFER is nil then the current buffer is used."
1003   (and (setq buffer (get-buffer (or buffer (current-buffer))))
1004        (buffer-live-p buffer)
1005        (with-current-buffer buffer
1006          (and imap-process
1007               (memq (process-status imap-process) '(open run))))))
1008
1009 (defun imap-authenticate (&optional user passwd buffer)
1010   "Authenticate to server in BUFFER, using current buffer if nil.
1011 It uses the authenticator specified when opening the server.  If the
1012 authenticator requires username/passwords, they are queried from the
1013 user and optionally stored in the buffer.  If USER and/or PASSWD is
1014 specified, the user will not be questioned and the username and/or
1015 password is remembered in the buffer."
1016   (with-current-buffer (or buffer (current-buffer))
1017     (if (not (eq imap-state 'nonauth))
1018         (or (eq imap-state 'auth)
1019             (eq imap-state 'select)
1020             (eq imap-state 'examine))
1021       (make-local-variable 'imap-username)
1022       (make-local-variable 'imap-password)
1023       (if user (setq imap-username user))
1024       (if passwd (setq imap-password passwd))
1025       (if imap-auth
1026           (and (funcall (nth 2 (assq imap-auth
1027                                      imap-authenticator-alist)) buffer)
1028                (setq imap-state 'auth))
1029         ;; Choose authenticator.
1030         (let ((auths imap-authenticators)
1031               auth)
1032           (while (setq auth (pop auths))
1033             ;; OK to use authenticator?
1034             (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1035               (message "imap: Authenticating to `%s' using `%s'..."
1036                        imap-server auth)
1037               (setq imap-auth auth)
1038               (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1039                   (progn
1040                     (message "imap: Authenticating to `%s' using `%s'...done"
1041                              imap-server auth)
1042                     (setq auths nil))
1043                 (message "imap: Authenticating to `%s' using `%s'...failed"
1044                          imap-server auth)))))
1045         imap-state))))
1046
1047 (defun imap-close (&optional buffer)
1048   "Close connection to server in BUFFER.
1049 If BUFFER is nil, the current buffer is used."
1050   (with-current-buffer (or buffer (current-buffer))
1051     (when (imap-opened)
1052       (condition-case nil
1053           (imap-send-command-wait "LOGOUT")
1054         (quit nil)))
1055     (when (and imap-process
1056                (memq (process-status imap-process) '(open run)))
1057       (delete-process imap-process))
1058     (setq imap-current-mailbox nil
1059           imap-current-message nil
1060           imap-process nil)
1061     (erase-buffer)
1062     t))
1063
1064 (defun imap-capability (&optional identifier buffer)
1065   "Return a list of identifiers which server in BUFFER support.
1066 If IDENTIFIER, return non-nil if it's among the servers capabilities.
1067 If BUFFER is nil, the current buffer is assumed."
1068   (with-current-buffer (or buffer (current-buffer))
1069     (unless imap-capability
1070       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1071         (setq imap-capability '(IMAP2))))
1072     (if identifier
1073         (memq (intern (upcase (symbol-name identifier))) imap-capability)
1074       imap-capability)))
1075
1076 (defun imap-namespace (&optional buffer)
1077   "Return a namespace hierarchy at server in BUFFER.
1078 If BUFFER is nil, the current buffer is assumed."
1079   (with-current-buffer (or buffer (current-buffer))
1080     (unless imap-namespace
1081       (when (imap-capability 'NAMESPACE)
1082         (imap-send-command-wait "NAMESPACE")))
1083     imap-namespace))
1084
1085 (defun imap-send-command-wait (command &optional buffer)
1086   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1087
1088 \f
1089 ;; Mailbox functions:
1090
1091 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1092   (with-current-buffer (or buffer (current-buffer))
1093     (if imap-mailbox-data
1094         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1095              propname value)
1096       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1097              propname value mailbox (current-buffer)))
1098     t))
1099
1100 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1101   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1102        propname))
1103
1104 (defun imap-mailbox-get (propname &optional mailbox buffer)
1105   (let ((mailbox (imap-utf7-encode mailbox)))
1106     (with-current-buffer (or buffer (current-buffer))
1107       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1108
1109 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1110   (with-current-buffer (or buffer (current-buffer))
1111     (let (result)
1112       (mapatoms
1113        (lambda (s)
1114          (push (funcall func (if mailbox-decoder
1115                                  (funcall mailbox-decoder (symbol-name s))
1116                                (symbol-name s))) result))
1117        imap-mailbox-data)
1118       result)))
1119
1120 (defun imap-mailbox-map (func &optional buffer)
1121   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1122 Function should take a mailbox name (a string) as
1123 the only argument."
1124   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1125
1126 (defun imap-current-mailbox (&optional buffer)
1127   (with-current-buffer (or buffer (current-buffer))
1128     (imap-utf7-decode imap-current-mailbox)))
1129
1130 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1131   (and (string= mailbox imap-current-mailbox)
1132        (or (and examine
1133                 (eq imap-state 'examine))
1134            (and (not examine)
1135                 (eq imap-state 'selected)))))
1136
1137 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1138   (with-current-buffer (or buffer (current-buffer))
1139     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1140
1141 (defun imap-mailbox-select-1 (mailbox &optional examine)
1142   "Select MAILBOX on server in BUFFER.
1143 If EXAMINE is non-nil, do a read-only select."
1144   (if (imap-current-mailbox-p-1 mailbox examine)
1145       imap-current-mailbox
1146     (setq imap-current-mailbox mailbox)
1147     (if (imap-ok-p (imap-send-command-wait
1148                     (concat (if examine "EXAMINE" "SELECT") " \""
1149                             mailbox "\"")))
1150         (progn
1151           (setq imap-message-data (make-vector imap-message-prime 0)
1152                 imap-state (if examine 'examine 'selected))
1153           imap-current-mailbox)
1154       ;; Failed SELECT/EXAMINE unselects current mailbox
1155       (setq imap-current-mailbox nil))))
1156
1157 (defun imap-mailbox-select (mailbox &optional examine buffer)
1158   (with-current-buffer (or buffer (current-buffer))
1159     (imap-utf7-decode
1160      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1161
1162 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1163   (with-current-buffer (or buffer (current-buffer))
1164     (imap-mailbox-select-1 mailbox 'examine)))
1165
1166 (defun imap-mailbox-examine (mailbox &optional buffer)
1167   "Examine MAILBOX on server in BUFFER."
1168   (imap-mailbox-select mailbox 'examine buffer))
1169
1170 (defun imap-mailbox-unselect (&optional buffer)
1171   "Close current folder in BUFFER, without expunging articles."
1172   (with-current-buffer (or buffer (current-buffer))
1173     (when (or (eq imap-state 'auth)
1174               (and (imap-capability 'UNSELECT)
1175                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1176               (and (imap-ok-p
1177                     (imap-send-command-wait (concat "EXAMINE \""
1178                                                     imap-current-mailbox
1179                                                     "\"")))
1180                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1181       (setq imap-current-mailbox nil
1182             imap-message-data nil
1183             imap-state 'auth)
1184       t)))
1185
1186 (defun imap-mailbox-expunge (&optional asynch buffer)
1187   "Expunge articles in current folder in BUFFER.
1188 If ASYNCH, do not wait for succesful completion of the command.
1189 If BUFFER is nil the current buffer is assumed."
1190   (with-current-buffer (or buffer (current-buffer))
1191     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1192       (if asynch
1193           (imap-send-command "EXPUNGE")
1194       (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1195
1196 (defun imap-mailbox-close (&optional asynch buffer)
1197   "Expunge articles and close current folder in BUFFER.
1198 If ASYNCH, do not wait for succesful completion of the command.
1199 If BUFFER is nil the current buffer is assumed."
1200   (with-current-buffer (or buffer (current-buffer))
1201     (when imap-current-mailbox
1202       (if asynch
1203           (imap-add-callback (imap-send-command "CLOSE")
1204                              `(lambda (tag status)
1205                                 (message "IMAP mailbox `%s' closed... %s"
1206                                          imap-current-mailbox status)
1207                                 (when (eq ,imap-current-mailbox
1208                                           imap-current-mailbox)
1209                                   ;; Don't wipe out data if another mailbox
1210                                   ;; was selected...
1211                                   (setq imap-current-mailbox nil
1212                                         imap-message-data nil
1213                                         imap-state 'auth))))
1214         (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1215           (setq imap-current-mailbox nil
1216                 imap-message-data nil
1217                 imap-state 'auth)))
1218       t)))
1219
1220 (defun imap-mailbox-create-1 (mailbox)
1221   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1222
1223 (defun imap-mailbox-create (mailbox &optional buffer)
1224   "Create MAILBOX on server in BUFFER.
1225 If BUFFER is nil the current buffer is assumed."
1226   (with-current-buffer (or buffer (current-buffer))
1227     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1228
1229 (defun imap-mailbox-delete (mailbox &optional buffer)
1230   "Delete MAILBOX on server in BUFFER.
1231 If BUFFER is nil the current buffer is assumed."
1232   (let ((mailbox (imap-utf7-encode mailbox)))
1233     (with-current-buffer (or buffer (current-buffer))
1234       (imap-ok-p
1235        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1236
1237 (defun imap-mailbox-rename (oldname newname &optional buffer)
1238   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1239 If BUFFER is nil the current buffer is assumed."
1240   (let ((oldname (imap-utf7-encode oldname))
1241         (newname (imap-utf7-encode newname)))
1242     (with-current-buffer (or buffer (current-buffer))
1243       (imap-ok-p
1244        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1245                                      "\"" newname "\""))))))
1246
1247 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1248   "Return a list of subscribed mailboxes on server in BUFFER.
1249 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1250 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1251 implementation-specific string that has to be passed to lsub command."
1252   (with-current-buffer (or buffer (current-buffer))
1253     ;; Make sure we know the hierarchy separator for root's hierarchy
1254     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1255       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1256                                       (imap-utf7-encode root) "\"")))
1257     ;; clear list data (NB not delimiter and other stuff)
1258     (imap-mailbox-map-1 (lambda (mailbox)
1259                           (imap-mailbox-put 'lsub nil mailbox)))
1260     (when (imap-ok-p
1261            (imap-send-command-wait
1262             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1263                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1264                     "%\"")))
1265       (let (out)
1266         (imap-mailbox-map-1 (lambda (mailbox)
1267                               (when (imap-mailbox-get-1 'lsub mailbox)
1268                                 (push (imap-utf7-decode mailbox) out))))
1269         (nreverse out)))))
1270
1271 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1272   "Return a list of mailboxes matching ROOT on server in BUFFER.
1273 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1274 root.  REFERENCE is a implementation-specific string that has to be
1275 passed to list command."
1276   (with-current-buffer (or buffer (current-buffer))
1277     ;; Make sure we know the hierarchy separator for root's hierarchy
1278     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1279       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1280                                       (imap-utf7-encode root) "\"")))
1281     ;; clear list data (NB not delimiter and other stuff)
1282     (imap-mailbox-map-1 (lambda (mailbox)
1283                           (imap-mailbox-put 'list nil mailbox)))
1284     (when (imap-ok-p
1285            (imap-send-command-wait
1286             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1287                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1288                     "%\"")))
1289       (let (out)
1290         (imap-mailbox-map-1 (lambda (mailbox)
1291                               (when (imap-mailbox-get-1 'list mailbox)
1292                                 (push (imap-utf7-decode mailbox) out))))
1293         (nreverse out)))))
1294
1295 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1296   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1297 Returns non-nil if successful."
1298   (with-current-buffer (or buffer (current-buffer))
1299     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1300                                                (imap-utf7-encode mailbox)
1301                                                "\"")))))
1302
1303 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1304   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1305 Returns non-nil if successful."
1306   (with-current-buffer (or buffer (current-buffer))
1307     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1308                                                (imap-utf7-encode mailbox)
1309                                                "\"")))))
1310
1311 (defun imap-mailbox-status (mailbox items &optional buffer)
1312   "Get status items ITEM in MAILBOX from server in BUFFER.
1313 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1314 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1315 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1316 returned, if ITEMS is a symbol only its value is returned."
1317   (with-current-buffer (or buffer (current-buffer))
1318     (when (imap-ok-p
1319            (imap-send-command-wait (list "STATUS \""
1320                                          (imap-utf7-encode mailbox)
1321                                          "\" "
1322                                          (format "%s"
1323                                                  (if (listp items)
1324                                                      items
1325                                                    (list items))))))
1326       (if (listp items)
1327           (mapcar (lambda (item)
1328                     (imap-mailbox-get item mailbox))
1329                   items)
1330         (imap-mailbox-get items mailbox)))))
1331
1332 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1333   "Send status item request ITEM on MAILBOX to server in BUFFER.
1334 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1335 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1336 or 'unseen.  The IMAP command tag is returned."
1337   (with-current-buffer (or buffer (current-buffer))
1338     (imap-send-command (list "STATUS \""
1339                              (imap-utf7-encode mailbox)
1340                              "\" "
1341                              (format "%s"
1342                                      (if (listp items)
1343                                          items
1344                                        (list items)))))))
1345
1346 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1347   "Get ACL on mailbox from server in BUFFER."
1348   (let ((mailbox (imap-utf7-encode mailbox)))
1349     (with-current-buffer (or buffer (current-buffer))
1350       (when (imap-ok-p
1351              (imap-send-command-wait (list "GETACL \""
1352                                            (or mailbox imap-current-mailbox)
1353                                            "\"")))
1354         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1355
1356 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1357   "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1358   (let ((mailbox (imap-utf7-encode mailbox)))
1359     (with-current-buffer (or buffer (current-buffer))
1360       (imap-ok-p
1361        (imap-send-command-wait (list "SETACL \""
1362                                      (or mailbox imap-current-mailbox)
1363                                      "\" "
1364                                      identifier
1365                                      " "
1366                                      rights))))))
1367
1368 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1369   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1370   (let ((mailbox (imap-utf7-encode mailbox)))
1371     (with-current-buffer (or buffer (current-buffer))
1372       (imap-ok-p
1373        (imap-send-command-wait (list "DELETEACL \""
1374                                      (or mailbox imap-current-mailbox)
1375                                      "\" "
1376                                      identifier))))))
1377
1378 \f
1379 ;; Message functions:
1380
1381 (defun imap-current-message (&optional buffer)
1382   (with-current-buffer (or buffer (current-buffer))
1383     imap-current-message))
1384
1385 (defun imap-list-to-message-set (list)
1386   (mapconcat (lambda (item)
1387                (number-to-string item))
1388              (if (listp list)
1389                  list
1390                (list list))
1391              ","))
1392
1393 (defun imap-range-to-message-set (range)
1394   (mapconcat
1395    (lambda (item)
1396      (if (consp item)
1397          (format "%d:%d"
1398                  (car item) (cdr item))
1399        (format "%d" item)))
1400    (if (and (listp range) (not (listp (cdr range))))
1401        (list range) ;; make (1 . 2) into ((1 . 2))
1402      range)
1403    ","))
1404
1405 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1406   (with-current-buffer (or buffer (current-buffer))
1407     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1408                                (if (listp uids)
1409                                    (imap-list-to-message-set uids)
1410                                  uids)
1411                                props))))
1412
1413 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1414   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1415 UIDS can be a string, number or a list of numbers.  If RECEIVE
1416 is non-nil return theese properties."
1417   (with-current-buffer (or buffer (current-buffer))
1418     (when (imap-ok-p (imap-send-command-wait
1419                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1420                               (if (listp uids)
1421                                   (imap-list-to-message-set uids)
1422                                 uids)
1423                               props)))
1424       (if (or (null receive) (stringp uids))
1425           t
1426         (if (listp uids)
1427             (mapcar (lambda (uid)
1428                       (if (listp receive)
1429                           (mapcar (lambda (prop)
1430                                     (imap-message-get uid prop))
1431                                   receive)
1432                         (imap-message-get uid receive)))
1433                     uids)
1434           (imap-message-get uids receive))))))
1435
1436 (defun imap-message-put (uid propname value &optional buffer)
1437   (with-current-buffer (or buffer (current-buffer))
1438     (if imap-message-data
1439         (put (intern (number-to-string uid) imap-message-data)
1440              propname value)
1441       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1442              uid propname value (current-buffer)))
1443     t))
1444
1445 (defun imap-message-get (uid propname &optional buffer)
1446   (with-current-buffer (or buffer (current-buffer))
1447     (get (intern-soft (number-to-string uid) imap-message-data)
1448          propname)))
1449
1450 (defun imap-message-map (func propname &optional buffer)
1451   "Map a function across each mailbox in `imap-message-data', returning a list."
1452   (with-current-buffer (or buffer (current-buffer))
1453     (let (result)
1454       (mapatoms
1455        (lambda (s)
1456          (push (funcall func (get s 'UID) (get s propname)) result))
1457        imap-message-data)
1458       result)))
1459
1460 (defmacro imap-message-envelope-date (uid &optional buffer)
1461   `(with-current-buffer (or ,buffer (current-buffer))
1462      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1463
1464 (defmacro imap-message-envelope-subject (uid &optional buffer)
1465   `(with-current-buffer (or ,buffer (current-buffer))
1466      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1467
1468 (defmacro imap-message-envelope-from (uid &optional buffer)
1469   `(with-current-buffer (or ,buffer (current-buffer))
1470      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1471
1472 (defmacro imap-message-envelope-sender (uid &optional buffer)
1473   `(with-current-buffer (or ,buffer (current-buffer))
1474      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1475
1476 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1477   `(with-current-buffer (or ,buffer (current-buffer))
1478      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1479
1480 (defmacro imap-message-envelope-to (uid &optional buffer)
1481   `(with-current-buffer (or ,buffer (current-buffer))
1482      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1483
1484 (defmacro imap-message-envelope-cc (uid &optional buffer)
1485   `(with-current-buffer (or ,buffer (current-buffer))
1486      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1487
1488 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1489   `(with-current-buffer (or ,buffer (current-buffer))
1490      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1491
1492 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1493   `(with-current-buffer (or ,buffer (current-buffer))
1494      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1495
1496 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1497   `(with-current-buffer (or ,buffer (current-buffer))
1498      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1499
1500 (defmacro imap-message-body (uid &optional buffer)
1501   `(with-current-buffer (or ,buffer (current-buffer))
1502      (imap-message-get ,uid 'BODY)))
1503
1504 (defun imap-search (predicate &optional buffer)
1505   (with-current-buffer (or buffer (current-buffer))
1506     (imap-mailbox-put 'search 'dummy)
1507     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1508       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1509           (progn
1510             (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1511             nil)
1512         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1513
1514 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1515   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1516   (with-current-buffer (or buffer (current-buffer))
1517     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1518         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1519
1520 (defun imap-message-flags-set (articles flags &optional silent buffer)
1521   (when (and articles flags)
1522     (with-current-buffer (or buffer (current-buffer))
1523       (imap-ok-p (imap-send-command-wait
1524                   (concat "UID STORE " articles
1525                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1526
1527 (defun imap-message-flags-del (articles flags &optional silent buffer)
1528   (when (and articles flags)
1529     (with-current-buffer (or buffer (current-buffer))
1530       (imap-ok-p (imap-send-command-wait
1531                   (concat "UID STORE " articles
1532                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1533
1534 (defun imap-message-flags-add (articles flags &optional silent buffer)
1535   (when (and articles flags)
1536     (with-current-buffer (or buffer (current-buffer))
1537       (imap-ok-p (imap-send-command-wait
1538                   (concat "UID STORE " articles
1539                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1540
1541 (defun imap-message-copyuid-1 (mailbox)
1542   (if (imap-capability 'UIDPLUS)
1543       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1544             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1545     (let ((old-mailbox imap-current-mailbox)
1546           (state imap-state)
1547           (imap-message-data (make-vector 2 0)))
1548       (when (imap-mailbox-examine-1 mailbox)
1549         (prog1
1550             (and (imap-fetch "*" "UID")
1551                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1552                        (apply 'max (imap-message-map
1553                                     (lambda (uid prop) uid) 'UID))))
1554           (if old-mailbox
1555               (imap-mailbox-select old-mailbox (eq state 'examine))
1556             (imap-mailbox-unselect)))))))
1557
1558 (defun imap-message-copyuid (mailbox &optional buffer)
1559   (with-current-buffer (or buffer (current-buffer))
1560     (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1561
1562 (defun imap-message-copy (articles mailbox
1563                                    &optional dont-create no-copyuid buffer)
1564   "Copy ARTICLES (a string message set) to MAILBOX on server in
1565 BUFFER, creating mailbox if it doesn't exist.  If dont-create is
1566 non-nil, it will not create a mailbox.  On success, return a list with
1567 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1568 first element, rest of list contain the saved articles' UIDs."
1569   (when articles
1570     (with-current-buffer (or buffer (current-buffer))
1571       (let ((mailbox (imap-utf7-encode mailbox)))
1572         (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1573                   (imap-current-target-mailbox mailbox))
1574               (if (imap-ok-p (imap-send-command-wait cmd))
1575                   t
1576                 (when (and (not dont-create)
1577                            ;; removed because of buggy Oracle server
1578                            ;; that doesn't send TRYCREATE tags (which
1579                            ;; is a MUST according to specifications):
1580                            ;;(imap-mailbox-get-1 'trycreate mailbox)
1581                            (imap-mailbox-create-1 mailbox))
1582                   (imap-ok-p (imap-send-command-wait cmd)))))
1583             (or no-copyuid
1584                 (imap-message-copyuid-1 mailbox)))))))
1585
1586 (defun imap-message-appenduid-1 (mailbox)
1587   (if (imap-capability 'UIDPLUS)
1588       (imap-mailbox-get-1 'appenduid mailbox)
1589     (let ((old-mailbox imap-current-mailbox)
1590           (state imap-state)
1591           (imap-message-data (make-vector 2 0)))
1592       (when (imap-mailbox-examine-1 mailbox)
1593         (prog1
1594             (and (imap-fetch "*" "UID")
1595                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1596                        (apply 'max (imap-message-map
1597                                     (lambda (uid prop) uid) 'UID))))
1598           (if old-mailbox
1599               (imap-mailbox-select old-mailbox (eq state 'examine))
1600             (imap-mailbox-unselect)))))))
1601
1602 (defun imap-message-appenduid (mailbox &optional buffer)
1603   (with-current-buffer (or buffer (current-buffer))
1604     (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1605
1606 (defun imap-message-append (mailbox article &optional flags date-time buffer)
1607   "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1608 FLAGS and DATE-TIME is currently not used.  Return a cons holding
1609 uidvalidity of MAILBOX and UID the newly created article got, or nil
1610 on failure."
1611   (let ((mailbox (imap-utf7-encode mailbox)))
1612     (with-current-buffer (or buffer (current-buffer))
1613       (and (let ((imap-current-target-mailbox mailbox))
1614              (imap-ok-p
1615               (imap-send-command-wait
1616                (list "APPEND \"" mailbox "\" "  article))))
1617            (imap-message-appenduid-1 mailbox)))))
1618
1619 (defun imap-body-lines (body)
1620   "Return number of lines in article by looking at the mime bodystructure BODY."
1621   (if (listp body)
1622       (if (stringp (car body))
1623           (cond ((and (string= (upcase (car body)) "TEXT")
1624                       (numberp (nth 7 body)))
1625                  (nth 7 body))
1626                 ((and (string= (upcase (car body)) "MESSAGE")
1627                       (numberp (nth 9 body)))
1628                  (nth 9 body))
1629                 (t 0))
1630         (apply '+ (mapcar 'imap-body-lines body)))
1631     0))
1632
1633 (defun imap-envelope-from (from)
1634   "Return a from string line."
1635   (and from
1636        (concat (aref from 0)
1637                (if (aref from 0) " <")
1638                (aref from 2)
1639                "@"
1640                (aref from 3)
1641                (if (aref from 0) ">"))))
1642
1643 \f
1644 ;; Internal functions.
1645
1646 (defun imap-add-callback (tag func)
1647   (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1648
1649 (defun imap-send-command-1 (cmdstr)
1650   (setq cmdstr (concat cmdstr imap-client-eol))
1651   (and imap-log
1652        (with-current-buffer (get-buffer-create imap-log-buffer)
1653          (buffer-disable-undo)
1654          (goto-char (point-max))
1655          (insert cmdstr)))
1656   (process-send-string imap-process cmdstr))
1657
1658 (defun imap-send-command (command &optional buffer)
1659   (with-current-buffer (or buffer (current-buffer))
1660     (if (not (listp command)) (setq command (list command)))
1661     (let ((tag (setq imap-tag (1+ imap-tag)))
1662           cmd cmdstr)
1663       (setq cmdstr (concat (number-to-string imap-tag) " "))
1664       (while (setq cmd (pop command))
1665         (cond ((stringp cmd)
1666                (setq cmdstr (concat cmdstr cmd)))
1667               ((bufferp cmd)
1668                (let ((eol imap-client-eol)
1669                      (calcfirst imap-calculate-literal-size-first)
1670                      size)
1671                  (with-current-buffer cmd
1672                    (if calcfirst
1673                        (setq size (buffer-size)))
1674                    (when (not (equal eol "\r\n"))
1675                      ;; XXX modifies buffer!
1676                      (goto-char (point-min))
1677                      (while (search-forward "\r\n" nil t)
1678                        (replace-match eol)))
1679                    (if (not calcfirst)
1680                        (setq size (buffer-size))))
1681                  (setq cmdstr
1682                        (concat cmdstr (format "{%d}" size))))
1683                (unwind-protect
1684                    (progn
1685                      (imap-send-command-1 cmdstr)
1686                      (setq cmdstr nil)
1687                      (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1688                          (setq command nil);; abort command if no cont-req
1689                        (let ((process imap-process)
1690                              (stream imap-stream)
1691                              (eol imap-client-eol))
1692                          (with-current-buffer cmd
1693                            (and imap-log
1694                                 (with-current-buffer (get-buffer-create
1695                                                       imap-log-buffer)
1696                                   (buffer-disable-undo)
1697                                   (goto-char (point-max))
1698                                   (insert-buffer-substring cmd)))
1699                            (process-send-region process (point-min)
1700                                                 (point-max)))
1701                          (process-send-string process imap-client-eol))))
1702                  (setq imap-continuation nil)))
1703               ((functionp cmd)
1704                (imap-send-command-1 cmdstr)
1705                (setq cmdstr nil)
1706                (unwind-protect
1707                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1708                        (setq command nil);; abort command if no cont-req
1709                      (setq command (cons (funcall cmd imap-continuation)
1710                                          command)))
1711                  (setq imap-continuation nil)))
1712               (t
1713                (error "Unknown command type"))))
1714       (if cmdstr
1715           (imap-send-command-1 cmdstr))
1716       tag)))
1717
1718 (defun imap-wait-for-tag (tag &optional buffer)
1719   (with-current-buffer (or buffer (current-buffer))
1720     (let (imap-have-messaged)
1721       (while (and (null imap-continuation)
1722                   (memq (process-status imap-process) '(open run))
1723                   (< imap-reached-tag tag))
1724         (let ((len (/ (point-max) 1024))
1725               message-log-max)
1726           (unless (< len 10)
1727             (setq imap-have-messaged t)
1728             (message "imap read: %dk" len))
1729           (accept-process-output imap-process
1730                                  (truncate imap-read-timeout)
1731                                  (truncate (* (- imap-read-timeout
1732                                                  (truncate imap-read-timeout))
1733                                               1000)))))
1734       (when imap-have-messaged
1735         (message ""))
1736       (and (memq (process-status imap-process) '(open run))
1737            (or (assq tag imap-failed-tags)
1738                (if imap-continuation
1739                    'INCOMPLETE
1740                  'OK))))))
1741
1742 (defun imap-sentinel (process string)
1743   (delete-process process))
1744
1745 (defun imap-find-next-line ()
1746   "Return point at end of current line, taking into account literals.
1747 Return nil if no complete line has arrived."
1748   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1749                                    imap-server-eol)
1750                            nil t)
1751     (if (match-string 1)
1752         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1753             nil
1754           (goto-char (+ (point) (string-to-number (match-string 1))))
1755           (imap-find-next-line))
1756       (point))))
1757
1758 (defun imap-arrival-filter (proc string)
1759   "IMAP process filter."
1760   (with-current-buffer (process-buffer proc)
1761     (goto-char (point-max))
1762     (insert string)
1763     (and imap-log
1764          (with-current-buffer (get-buffer-create imap-log-buffer)
1765            (buffer-disable-undo)
1766            (goto-char (point-max))
1767            (insert string)))
1768     (let (end)
1769       (goto-char (point-min))
1770       (while (setq end (imap-find-next-line))
1771         (save-restriction
1772           (narrow-to-region (point-min) end)
1773           (delete-backward-char (length imap-server-eol))
1774           (goto-char (point-min))
1775           (unwind-protect
1776               (cond ((eq imap-state 'initial)
1777                      (imap-parse-greeting))
1778                     ((or (eq imap-state 'auth)
1779                          (eq imap-state 'nonauth)
1780                          (eq imap-state 'selected)
1781                          (eq imap-state 'examine))
1782                      (imap-parse-response))
1783                     (t
1784                      (message "Unknown state %s in arrival filter"
1785                               imap-state)))
1786             (delete-region (point-min) (point-max))))))))
1787
1788 \f
1789 ;; Imap parser.
1790
1791 (defsubst imap-forward ()
1792   (or (eobp) (forward-char)))
1793
1794 ;;   number          = 1*DIGIT
1795 ;;                       ; Unsigned 32-bit integer
1796 ;;                       ; (0 <= n < 4,294,967,296)
1797
1798 (defsubst imap-parse-number ()
1799   (when (looking-at "[0-9]+")
1800     (prog1
1801         (string-to-number (match-string 0))
1802       (goto-char (match-end 0)))))
1803
1804 ;;   literal         = "{" number "}" CRLF *CHAR8
1805 ;;                       ; Number represents the number of CHAR8s
1806
1807 (defsubst imap-parse-literal ()
1808   (when (looking-at "{\\([0-9]+\\)}\r\n")
1809     (let ((pos (match-end 0))
1810           (len (string-to-number (match-string 1))))
1811       (if (< (point-max) (+ pos len))
1812           nil
1813         (goto-char (+ pos len))
1814         (buffer-substring pos (+ pos len))))))
1815
1816 ;;   string          = quoted / literal
1817 ;;
1818 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
1819 ;;
1820 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
1821 ;;                     "\" quoted-specials
1822 ;;
1823 ;;   quoted-specials = DQUOTE / "\"
1824 ;;
1825 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1826
1827 (defsubst imap-parse-string ()
1828   (cond ((eq (char-after) ?\")
1829          (forward-char 1)
1830          (let ((p (point)) (name ""))
1831            (skip-chars-forward "^\"\\\\")
1832            (setq name (buffer-substring p (point)))
1833            (while (eq (char-after) ?\\)
1834              (setq p (1+ (point)))
1835              (forward-char 2)
1836              (skip-chars-forward "^\"\\\\")
1837              (setq name (concat name (buffer-substring p (point)))))
1838            (forward-char 1)
1839            name))
1840         ((eq (char-after) ?{)
1841          (imap-parse-literal))))
1842
1843 ;;   nil             = "NIL"
1844
1845 (defsubst imap-parse-nil ()
1846   (if (looking-at "NIL")
1847       (goto-char (match-end 0))))
1848
1849 ;;   nstring         = string / nil
1850
1851 (defsubst imap-parse-nstring ()
1852   (or (imap-parse-string)
1853       (and (imap-parse-nil)
1854            nil)))
1855
1856 ;;   astring         = atom / string
1857 ;;
1858 ;;   atom            = 1*ATOM-CHAR
1859 ;;
1860 ;;   ATOM-CHAR       = <any CHAR except atom-specials>
1861 ;;
1862 ;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
1863 ;;                     quoted-specials
1864 ;;
1865 ;;   list-wildcards  = "%" / "*"
1866 ;;
1867 ;;   quoted-specials = DQUOTE / "\"
1868
1869 (defsubst imap-parse-astring ()
1870   (or (imap-parse-string)
1871       (buffer-substring (point)
1872                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1873                             (goto-char (1- (match-end 0)))
1874                           (end-of-line)
1875                           (point)))))
1876
1877 ;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
1878 ;;                      addr-host ")"
1879 ;;
1880 ;;   addr-adl        = nstring
1881 ;;                       ; Holds route from [RFC-822] route-addr if
1882 ;;                       ; non-nil
1883 ;;
1884 ;;   addr-host       = nstring
1885 ;;                       ; nil indicates [RFC-822] group syntax.
1886 ;;                       ; Otherwise, holds [RFC-822] domain name
1887 ;;
1888 ;;   addr-mailbox    = nstring
1889 ;;                       ; nil indicates end of [RFC-822] group; if
1890 ;;                       ; non-nil and addr-host is nil, holds
1891 ;;                       ; [RFC-822] group name.
1892 ;;                       ; Otherwise, holds [RFC-822] local-part
1893 ;;                       ; after removing [RFC-822] quoting
1894 ;;
1895 ;;   addr-name       = nstring
1896 ;;                       ; If non-nil, holds phrase from [RFC-822]
1897 ;;                       ; mailbox after removing [RFC-822] quoting
1898 ;;
1899
1900 (defsubst imap-parse-address ()
1901   (let (address)
1902     (when (eq (char-after) ?\()
1903       (imap-forward)
1904       (setq address (vector (prog1 (imap-parse-nstring)
1905                               (imap-forward))
1906                             (prog1 (imap-parse-nstring)
1907                               (imap-forward))
1908                             (prog1 (imap-parse-nstring)
1909                               (imap-forward))
1910                             (imap-parse-nstring)))
1911       (when (eq (char-after) ?\))
1912         (imap-forward)
1913         address))))
1914
1915 ;;   address-list    = "(" 1*address ")" / nil
1916 ;;
1917 ;;   nil             = "NIL"
1918
1919 (defsubst imap-parse-address-list ()
1920   (if (eq (char-after) ?\()
1921       (let (address addresses)
1922         (imap-forward)
1923         (while (and (not (eq (char-after) ?\)))
1924                     ;; next line for MS Exchange bug
1925                     (progn (and (eq (char-after) ? ) (imap-forward)) t)
1926                     (setq address (imap-parse-address)))
1927           (setq addresses (cons address addresses)))
1928         (when (eq (char-after) ?\))
1929           (imap-forward)
1930           (nreverse addresses)))
1931     (assert (imap-parse-nil) t "In imap-parse-address-list")))
1932
1933 ;;   mailbox         = "INBOX" / astring
1934 ;;                       ; INBOX is case-insensitive.  All case variants of
1935 ;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
1936 ;;                       ; not as an astring.  An astring which consists of
1937 ;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
1938 ;;                       ; is considered to be INBOX and not an astring.
1939 ;;                       ;  Refer to section 5.1 for further
1940 ;;                       ; semantic details of mailbox names.
1941
1942 (defsubst imap-parse-mailbox ()
1943   (let ((mailbox (imap-parse-astring)))
1944     (if (string-equal "INBOX" (upcase mailbox))
1945         "INBOX"
1946       mailbox)))
1947
1948 ;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
1949 ;;
1950 ;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
1951 ;;                       ; Authentication condition
1952 ;;
1953 ;;   resp-cond-bye   = "BYE" SP resp-text
1954
1955 (defun imap-parse-greeting ()
1956   "Parse a IMAP greeting."
1957   (cond ((looking-at "\\* OK ")
1958          (setq imap-state 'nonauth))
1959         ((looking-at "\\* PREAUTH ")
1960          (setq imap-state 'auth))
1961         ((looking-at "\\* BYE ")
1962          (setq imap-state 'closed))))
1963
1964 ;;   response        = *(continue-req / response-data) response-done
1965 ;;
1966 ;;   continue-req    = "+" SP (resp-text / base64) CRLF
1967 ;;
1968 ;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
1969 ;;                     mailbox-data / message-data / capability-data) CRLF
1970 ;;
1971 ;;   response-done   = response-tagged / response-fatal
1972 ;;
1973 ;;   response-fatal  = "*" SP resp-cond-bye CRLF
1974 ;;                       ; Server closes connection immediately
1975 ;;
1976 ;;   response-tagged = tag SP resp-cond-state CRLF
1977 ;;
1978 ;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
1979 ;;                       ; Status condition
1980 ;;
1981 ;;   resp-cond-bye   = "BYE" SP resp-text
1982 ;;
1983 ;;   mailbox-data    =  "FLAGS" SP flag-list /
1984 ;;                      "LIST" SP mailbox-list /
1985 ;;                      "LSUB" SP mailbox-list /
1986 ;;                      "SEARCH" *(SP nz-number) /
1987 ;;                      "STATUS" SP mailbox SP "("
1988 ;;                            [status-att SP number *(SP status-att SP number)] ")" /
1989 ;;                      number SP "EXISTS" /
1990 ;;                      number SP "RECENT"
1991 ;;
1992 ;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
1993 ;;
1994 ;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
1995 ;;                     *(SP capability)
1996 ;;                       ; IMAP4rev1 servers which offer RFC 1730
1997 ;;                       ; compatibility MUST list "IMAP4" as the first
1998 ;;                       ; capability.
1999
2000 (defun imap-parse-response ()
2001   "Parse a IMAP command response."
2002   (let (token)
2003     (case (setq token (read (current-buffer)))
2004       (+ (setq imap-continuation
2005                (or (buffer-substring (min (point-max) (1+ (point)))
2006                                      (point-max))
2007                    t)))
2008       (* (case (prog1 (setq token (read (current-buffer)))
2009                  (imap-forward))
2010            (OK         (imap-parse-resp-text))
2011            (NO         (imap-parse-resp-text))
2012            (BAD        (imap-parse-resp-text))
2013            (BYE        (imap-parse-resp-text))
2014            (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
2015            (LIST       (imap-parse-data-list 'list))
2016            (LSUB       (imap-parse-data-list 'lsub))
2017            (SEARCH     (imap-mailbox-put
2018                         'search
2019                         (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2020            (STATUS     (imap-parse-status))
2021            (CAPABILITY (setq imap-capability
2022                                (read (concat "(" (upcase (buffer-substring
2023                                                           (point) (point-max)))
2024                                              ")"))))
2025            (ACL        (imap-parse-acl))
2026            (t       (case (prog1 (read (current-buffer))
2027                             (imap-forward))
2028                       (EXISTS  (imap-mailbox-put 'exists token))
2029                       (RECENT  (imap-mailbox-put 'recent token))
2030                       (EXPUNGE t)
2031                       (FETCH   (imap-parse-fetch token))
2032                       (t       (message "Garbage: %s" (buffer-string)))))))
2033       (t (let (status)
2034            (if (not (integerp token))
2035                (message "Garbage: %s" (buffer-string))
2036              (case (prog1 (setq status (read (current-buffer)))
2037                      (imap-forward))
2038                (OK  (progn
2039                       (setq imap-reached-tag (max imap-reached-tag token))
2040                       (imap-parse-resp-text)))
2041                (NO  (progn
2042                       (setq imap-reached-tag (max imap-reached-tag token))
2043                       (save-excursion
2044                         (imap-parse-resp-text))
2045                       (let (code text)
2046                         (when (eq (char-after) ?\[)
2047                           (setq code (buffer-substring (point)
2048                                                        (search-forward "]")))
2049                           (imap-forward))
2050                         (setq text (buffer-substring (point) (point-max)))
2051                         (push (list token status code text)
2052                               imap-failed-tags))))
2053                (BAD (progn
2054                       (setq imap-reached-tag (max imap-reached-tag token))
2055                       (save-excursion
2056                         (imap-parse-resp-text))
2057                       (let (code text)
2058                         (when (eq (char-after) ?\[)
2059                           (setq code (buffer-substring (point)
2060                                                        (search-forward "]")))
2061                           (imap-forward))
2062                         (setq text (buffer-substring (point) (point-max)))
2063                         (push (list token status code text) imap-failed-tags)
2064                         (error "Internal error, tag %s status %s code %s text %s"
2065                                token status code text))))
2066                (t   (message "Garbage: %s" (buffer-string))))
2067              (when (assq token imap-callbacks)
2068                (funcall (cdr (assq token imap-callbacks)) token status)
2069                (setq imap-callbacks
2070                      (imap-remassoc token imap-callbacks)))))))))
2071
2072 ;;   resp-text       = ["[" resp-text-code "]" SP] text
2073 ;;
2074 ;;   text            = 1*TEXT-CHAR
2075 ;;
2076 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
2077
2078 (defun imap-parse-resp-text ()
2079   (imap-parse-resp-text-code))
2080
2081 ;;   resp-text-code  = "ALERT" /
2082 ;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
2083 ;;                     "NEWNAME" SP string SP string /
2084 ;;                     "PARSE" /
2085 ;;                     "PERMANENTFLAGS" SP "("
2086 ;;                               [flag-perm *(SP flag-perm)] ")" /
2087 ;;                     "READ-ONLY" /
2088 ;;                     "READ-WRITE" /
2089 ;;                     "TRYCREATE" /
2090 ;;                     "UIDNEXT" SP nz-number /
2091 ;;                     "UIDVALIDITY" SP nz-number /
2092 ;;                     "UNSEEN" SP nz-number /
2093 ;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2094 ;;
2095 ;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
2096 ;;
2097 ;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
2098 ;;
2099 ;;   set             = sequence-num / (sequence-num ":" sequence-num) /
2100 ;;                        (set "," set)
2101 ;;                          ; Identifies a set of messages.  For message
2102 ;;                          ; sequence numbers, these are consecutive
2103 ;;                          ; numbers from 1 to the number of messages in
2104 ;;                          ; the mailbox
2105 ;;                          ; Comma delimits individual numbers, colon
2106 ;;                          ; delimits between two numbers inclusive.
2107 ;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2108 ;;                          ; 14,15 for a mailbox with 15 messages.
2109 ;;
2110 ;;   sequence-num    = nz-number / "*"
2111 ;;                          ; * is the largest number in use.  For message
2112 ;;                          ; sequence numbers, it is the number of messages
2113 ;;                          ; in the mailbox.  For unique identifiers, it is
2114 ;;                          ; the unique identifier of the last message in
2115 ;;                          ; the mailbox.
2116 ;;
2117 ;;   flag-perm       = flag / "\*"
2118 ;;
2119 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2120 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2121 ;;                       ; Does not include "\Recent"
2122 ;;
2123 ;;   flag-extension  = "\" atom
2124 ;;                       ; Future expansion.  Client implementations
2125 ;;                       ; MUST accept flag-extension flags.  Server
2126 ;;                       ; implementations MUST NOT generate
2127 ;;                       ; flag-extension flags except as defined by
2128 ;;                       ; future standard or standards-track
2129 ;;                       ; revisions of this specification.
2130 ;;
2131 ;;   flag-keyword    = atom
2132 ;;
2133 ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
2134
2135 (defun imap-parse-resp-text-code ()
2136   ;; xxx next line for stalker communigate pro 3.3.1 bug
2137   (when (looking-at " \\[")
2138     (imap-forward))
2139   (when (eq (char-after) ?\[)
2140     (imap-forward)
2141     (cond ((search-forward "PERMANENTFLAGS " nil t)
2142            (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2143           ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2144            (imap-mailbox-put 'uidnext (match-string 1)))
2145           ((search-forward "UNSEEN " nil t)
2146            (imap-mailbox-put 'first-unseen (read (current-buffer))))
2147           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2148            (imap-mailbox-put 'uidvalidity (match-string 1)))
2149           ((search-forward "READ-ONLY" nil t)
2150            (imap-mailbox-put 'read-only t))
2151           ((search-forward "NEWNAME " nil t)
2152            (let (oldname newname)
2153              (setq oldname (imap-parse-string))
2154              (imap-forward)
2155              (setq newname (imap-parse-string))
2156              (imap-mailbox-put 'newname newname oldname)))
2157           ((search-forward "TRYCREATE" nil t)
2158            (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2159           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2160            (imap-mailbox-put 'appenduid
2161                              (list (match-string 1)
2162                                    (string-to-number (match-string 2)))
2163                              imap-current-target-mailbox))
2164           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2165            (imap-mailbox-put 'copyuid (list (match-string 1)
2166                                             (match-string 2)
2167                                             (match-string 3))
2168                              imap-current-target-mailbox))
2169           ((search-forward "ALERT] " nil t)
2170            (message "Imap server %s information: %s" imap-server
2171                     (buffer-substring (point) (point-max)))))))
2172
2173 ;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
2174 ;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2175 ;;
2176 ;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
2177 ;;                     *(SP mbx-list-oflag) /
2178 ;;                     mbx-list-oflag *(SP mbx-list-oflag)
2179 ;;
2180 ;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
2181 ;;                       ; Other flags; multiple possible per LIST response
2182 ;;
2183 ;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
2184 ;;                       ; Selectability flags; only one per LIST response
2185 ;;
2186 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
2187 ;;                     "\" quoted-specials
2188 ;;
2189 ;;   quoted-specials = DQUOTE / "\"
2190
2191 (defun imap-parse-data-list (type)
2192   (let (flags delimiter mailbox)
2193     (setq flags (imap-parse-flag-list))
2194     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2195       (setq delimiter (match-string 1))
2196       (goto-char (1+ (match-end 0)))
2197       (when (setq mailbox (imap-parse-mailbox))
2198         (imap-mailbox-put type t mailbox)
2199         (imap-mailbox-put 'list-flags flags mailbox)
2200         (imap-mailbox-put 'delimiter delimiter mailbox)))))
2201
2202 ;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
2203 ;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2204 ;;                      "INTERNALDATE" SPACE date_time /
2205 ;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2206 ;;                      "RFC822.SIZE" SPACE number /
2207 ;;                      "BODY" ["STRUCTURE"] SPACE body /
2208 ;;                      "BODY" section ["<" number ">"] SPACE nstring /
2209 ;;                      "UID" SPACE uniqueid) ")"
2210 ;;
2211 ;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
2212 ;;                      SPACE time SPACE zone <">
2213 ;;
2214 ;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
2215 ;;                      ["." (section_text / "MIME")])] "]"
2216 ;;
2217 ;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2218 ;;                      SPACE header_list / "TEXT"
2219 ;;
2220 ;;  header_fld_name ::= astring
2221 ;;
2222 ;;  header_list     ::= "(" 1#header_fld_name ")"
2223
2224 (defsubst imap-parse-header-list ()
2225   (when (eq (char-after) ?\()
2226     (let (strlist)
2227       (while (not (eq (char-after) ?\)))
2228         (imap-forward)
2229         (push (imap-parse-astring) strlist))
2230       (imap-forward)
2231       (nreverse strlist))))
2232
2233 (defsubst imap-parse-fetch-body-section ()
2234   (let ((section
2235          (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2236     (if (eq (char-before) ? )
2237         (prog1
2238             (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2239           (search-forward "]" nil t))
2240       section)))
2241
2242 (defun imap-parse-fetch (response)
2243   (when (eq (char-after) ?\()
2244     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2245               rfc822size body bodydetail bodystructure flags-empty)
2246       (while (not (eq (char-after) ?\)))
2247         (imap-forward)
2248         (let ((token (read (current-buffer))))
2249           (imap-forward)
2250           (cond ((eq token 'UID)
2251                  (setq uid (condition-case ()
2252                                (read (current-buffer))
2253                              (error))))
2254                 ((eq token 'FLAGS)
2255                  (setq flags (imap-parse-flag-list))
2256                  (if (not flags)
2257                      (setq flags-empty 't)))
2258                 ((eq token 'ENVELOPE)
2259                  (setq envelope (imap-parse-envelope)))
2260                 ((eq token 'INTERNALDATE)
2261                  (setq internaldate (imap-parse-string)))
2262                 ((eq token 'RFC822)
2263                  (setq rfc822 (imap-parse-nstring)))
2264                 ((eq token 'RFC822.HEADER)
2265                  (setq rfc822header (imap-parse-nstring)))
2266                 ((eq token 'RFC822.TEXT)
2267                  (setq rfc822text (imap-parse-nstring)))
2268                 ((eq token 'RFC822.SIZE)
2269                  (setq rfc822size (read (current-buffer))))
2270                 ((eq token 'BODY)
2271                  (if (eq (char-before) ?\[)
2272                      (push (list
2273                             (upcase (imap-parse-fetch-body-section))
2274                             (and (eq (char-after) ?<)
2275                                  (buffer-substring (1+ (point))
2276                                                    (search-forward ">" nil t)))
2277                             (progn (imap-forward)
2278                                    (imap-parse-nstring)))
2279                            bodydetail)
2280                    (setq body (imap-parse-body))))
2281                 ((eq token 'BODYSTRUCTURE)
2282                  (setq bodystructure (imap-parse-body))))))
2283       (when uid
2284         (setq imap-current-message uid)
2285         (imap-message-put uid 'UID uid)
2286         (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2287         (and envelope (imap-message-put uid 'ENVELOPE envelope))
2288         (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2289         (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2290         (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2291         (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2292         (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2293         (and body (imap-message-put uid 'BODY body))
2294         (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2295         (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2296         (run-hooks 'imap-fetch-data-hook)))))
2297
2298 ;;   mailbox-data    =  ...
2299 ;;                      "STATUS" SP mailbox SP "("
2300 ;;                            [status-att SP number
2301 ;;                            *(SP status-att SP number)] ")"
2302 ;;                      ...
2303 ;;
2304 ;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2305 ;;                     "UNSEEN"
2306
2307 (defun imap-parse-status ()
2308   (let ((mailbox (imap-parse-mailbox)))
2309     (if (eq (char-after) ? )
2310         (forward-char))
2311     (when (and mailbox (eq (char-after) ?\())
2312       (while (and (not (eq (char-after) ?\)))
2313                   (or (forward-char) t)
2314                   (looking-at "\\([A-Za-z]+\\) "))
2315         (let ((token (match-string 1)))
2316           (goto-char (match-end 0))
2317           (cond ((string= token "MESSAGES")
2318                  (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2319                 ((string= token "RECENT")
2320                  (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2321                 ((string= token "UIDNEXT")
2322                  (and (looking-at "[0-9]+")
2323                       (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2324                       (goto-char (match-end 0))))
2325                 ((string= token "UIDVALIDITY")
2326                  (and (looking-at "[0-9]+")
2327                       (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2328                       (goto-char (match-end 0))))
2329                 ((string= token "UNSEEN")
2330                  (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2331                 (t
2332                  (message "Unknown status data %s in mailbox %s ignored"
2333                           token mailbox)
2334                  (read (current-buffer)))))))))
2335
2336 ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2337 ;;                        rights)
2338 ;;
2339 ;;   identifier      ::= astring
2340 ;;
2341 ;;   rights          ::= astring
2342
2343 (defun imap-parse-acl ()
2344   (let ((mailbox (imap-parse-mailbox))
2345         identifier rights acl)
2346     (while (eq (char-after) ?\ )
2347       (imap-forward)
2348       (setq identifier (imap-parse-astring))
2349       (imap-forward)
2350       (setq rights (imap-parse-astring))
2351       (setq acl (append acl (list (cons identifier rights)))))
2352     (imap-mailbox-put 'acl acl mailbox)))
2353
2354 ;;   flag-list       = "(" [flag *(SP flag)] ")"
2355 ;;
2356 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2357 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2358 ;;                       ; Does not include "\Recent"
2359 ;;
2360 ;;   flag-keyword    = atom
2361 ;;
2362 ;;   flag-extension  = "\" atom
2363 ;;                       ; Future expansion.  Client implementations
2364 ;;                       ; MUST accept flag-extension flags.  Server
2365 ;;                       ; implementations MUST NOT generate
2366 ;;                       ; flag-extension flags except as defined by
2367 ;;                       ; future standard or standards-track
2368 ;;                       ; revisions of this specification.
2369
2370 (defun imap-parse-flag-list ()
2371   (let (flag-list start)
2372     (assert (eq (char-after) ?\() t "In imap-parse-flag-list")
2373     (while (and (not (eq (char-after) ?\)))
2374                 (setq start (progn
2375                               (imap-forward)
2376                               ;; next line for Courier IMAP bug.
2377                               (skip-chars-forward " ")
2378                               (point)))
2379                 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
2380       (push (buffer-substring start (point)) flag-list))
2381     (assert (eq (char-after) ?\)) t "In imap-parse-flag-list")
2382     (imap-forward)
2383     (nreverse flag-list)))
2384
2385 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2386 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2387 ;;                     env-in-reply-to SP env-message-id ")"
2388 ;;
2389 ;;   env-bcc         = "(" 1*address ")" / nil
2390 ;;
2391 ;;   env-cc          = "(" 1*address ")" / nil
2392 ;;
2393 ;;   env-date        = nstring
2394 ;;
2395 ;;   env-from        = "(" 1*address ")" / nil
2396 ;;
2397 ;;   env-in-reply-to = nstring
2398 ;;
2399 ;;   env-message-id  = nstring
2400 ;;
2401 ;;   env-reply-to    = "(" 1*address ")" / nil
2402 ;;
2403 ;;   env-sender      = "(" 1*address ")" / nil
2404 ;;
2405 ;;   env-subject     = nstring
2406 ;;
2407 ;;   env-to          = "(" 1*address ")" / nil
2408
2409 (defun imap-parse-envelope ()
2410   (when (eq (char-after) ?\()
2411     (imap-forward)
2412     (vector (prog1 (imap-parse-nstring);; date
2413               (imap-forward))
2414             (prog1 (imap-parse-nstring);; subject
2415               (imap-forward))
2416             (prog1 (imap-parse-address-list);; from
2417               (imap-forward))
2418             (prog1 (imap-parse-address-list);; sender
2419               (imap-forward))
2420             (prog1 (imap-parse-address-list);; reply-to
2421               (imap-forward))
2422             (prog1 (imap-parse-address-list);; to
2423               (imap-forward))
2424             (prog1 (imap-parse-address-list);; cc
2425               (imap-forward))
2426             (prog1 (imap-parse-address-list);; bcc
2427               (imap-forward))
2428             (prog1 (imap-parse-nstring);; in-reply-to
2429               (imap-forward))
2430             (prog1 (imap-parse-nstring);; message-id
2431               (imap-forward)))))
2432
2433 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2434
2435 (defsubst imap-parse-string-list ()
2436   (cond ((eq (char-after) ?\();; body-fld-param
2437          (let (strlist str)
2438            (imap-forward)
2439            (while (setq str (imap-parse-string))
2440              (push str strlist)
2441              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2442              ;; between body-fld-param's sometimes
2443              (or (eq (char-after) ?\")
2444                  (imap-forward)))
2445            (nreverse strlist)))
2446         ((imap-parse-nil)
2447          nil)))
2448
2449 ;;   body-extension  = nstring / number /
2450 ;;                      "(" body-extension *(SP body-extension) ")"
2451 ;;                       ; Future expansion.  Client implementations
2452 ;;                       ; MUST accept body-extension fields.  Server
2453 ;;                       ; implementations MUST NOT generate
2454 ;;                       ; body-extension fields except as defined by
2455 ;;                       ; future standard or standards-track
2456 ;;                       ; revisions of this specification.
2457
2458 (defun imap-parse-body-extension ()
2459   (if (eq (char-after) ?\()
2460       (let (b-e)
2461         (imap-forward)
2462         (push (imap-parse-body-extension) b-e)
2463         (while (eq (char-after) ?\ )
2464           (imap-forward)
2465           (push (imap-parse-body-extension) b-e))
2466         (assert (eq (char-after) ?\)) t "In imap-parse-body-extension")
2467         (imap-forward)
2468         (nreverse b-e))
2469     (or (imap-parse-number)
2470         (imap-parse-nstring))))
2471
2472 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2473 ;;                     *(SP body-extension)]]
2474 ;;                       ; MUST NOT be returned on non-extensible
2475 ;;                       ; "BODY" fetch
2476 ;;
2477 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2478 ;;                     *(SP body-extension)]]
2479 ;;                       ; MUST NOT be returned on non-extensible
2480 ;;                       ; "BODY" fetch
2481
2482 (defsubst imap-parse-body-ext ()
2483   (let (ext)
2484     (when (eq (char-after) ?\ );; body-fld-dsp
2485       (imap-forward)
2486       (let (dsp)
2487         (if (eq (char-after) ?\()
2488             (progn
2489               (imap-forward)
2490               (push (imap-parse-string) dsp)
2491               (imap-forward)
2492               (push (imap-parse-string-list) dsp)
2493               (imap-forward))
2494           (assert (imap-parse-nil) t "In imap-parse-body-ext"))
2495         (push (nreverse dsp) ext))
2496       (when (eq (char-after) ?\ );; body-fld-lang
2497         (imap-forward)
2498         (if (eq (char-after) ?\()
2499             (push (imap-parse-string-list) ext)
2500           (push (imap-parse-nstring) ext))
2501         (while (eq (char-after) ?\ );; body-extension
2502           (imap-forward)
2503           (setq ext (append (imap-parse-body-extension) ext)))))
2504     ext))
2505
2506 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2507 ;;
2508 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2509 ;;                     *(SP body-extension)]]
2510 ;;                       ; MUST NOT be returned on non-extensible
2511 ;;                       ; "BODY" fetch
2512 ;;
2513 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2514 ;;                     *(SP body-extension)]]
2515 ;;                       ; MUST NOT be returned on non-extensible
2516 ;;                       ; "BODY" fetch
2517 ;;
2518 ;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2519 ;;                     body-fld-enc SP body-fld-octets
2520 ;;
2521 ;;   body-fld-desc   = nstring
2522 ;;
2523 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2524 ;;
2525 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2526 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2527 ;;
2528 ;;   body-fld-id     = nstring
2529 ;;
2530 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2531 ;;
2532 ;;   body-fld-lines  = number
2533 ;;
2534 ;;   body-fld-md5    = nstring
2535 ;;
2536 ;;   body-fld-octets = number
2537 ;;
2538 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2539 ;;
2540 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2541 ;;                     [SP body-ext-1part]
2542 ;;
2543 ;;   body-type-basic = media-basic SP body-fields
2544 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2545 ;;
2546 ;;   body-type-msg   = media-message SP body-fields SP envelope
2547 ;;                     SP body SP body-fld-lines
2548 ;;
2549 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2550 ;;
2551 ;;   body-type-mpart = 1*body SP media-subtype
2552 ;;                     [SP body-ext-mpart]
2553 ;;
2554 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2555 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2556 ;;                       ; Defined in [MIME-IMT]
2557 ;;
2558 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2559 ;;                      ; Defined in [MIME-IMT]
2560 ;;
2561 ;;   media-subtype   = string
2562 ;;                       ; Defined in [MIME-IMT]
2563 ;;
2564 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2565 ;;                       ; Defined in [MIME-IMT]
2566
2567 (defun imap-parse-body ()
2568   (let (body)
2569     (when (eq (char-after) ?\()
2570       (imap-forward)
2571       (if (eq (char-after) ?\()
2572           (let (subbody)
2573             (while (and (eq (char-after) ?\()
2574                         (setq subbody (imap-parse-body)))
2575               ;; buggy stalker communigate pro 3.0 insert a SPC between
2576               ;; parts in multiparts
2577               (when (and (eq (char-after) ?\ )
2578                          (eq (char-after (1+ (point))) ?\())
2579                 (imap-forward))
2580               (push subbody body))
2581             (imap-forward)
2582             (push (imap-parse-string) body);; media-subtype
2583             (when (eq (char-after) ?\ );; body-ext-mpart:
2584               (imap-forward)
2585               (if (eq (char-after) ?\();; body-fld-param
2586                   (push (imap-parse-string-list) body)
2587                 (push (and (imap-parse-nil) nil) body))
2588               (setq body
2589                     (append (imap-parse-body-ext) body)));; body-ext-...
2590             (assert (eq (char-after) ?\)) t "In imap-parse-body")
2591             (imap-forward)
2592             (nreverse body))
2593
2594         (push (imap-parse-string) body);; media-type
2595         (imap-forward)
2596         (push (imap-parse-string) body);; media-subtype
2597         (imap-forward)
2598         ;; next line for Sun SIMS bug
2599         (and (eq (char-after) ? ) (imap-forward))
2600         (if (eq (char-after) ?\();; body-fld-param
2601             (push (imap-parse-string-list) body)
2602           (push (and (imap-parse-nil) nil) body))
2603         (imap-forward)
2604         (push (imap-parse-nstring) body);; body-fld-id
2605         (imap-forward)
2606         (push (imap-parse-nstring) body);; body-fld-desc
2607         (imap-forward)
2608         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2609         ;; nstring and return nil instead of defaulting back to 7BIT
2610         ;; as the standard says.
2611         (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc
2612         (imap-forward)
2613         (push (imap-parse-number) body);; body-fld-octets
2614
2615         ;; ok, we're done parsing the required parts, what comes now is one
2616         ;; of three things:
2617         ;;
2618         ;; envelope       (then we're parsing body-type-msg)
2619         ;; body-fld-lines (then we're parsing body-type-text)
2620         ;; body-ext-1part (then we're parsing body-type-basic)
2621         ;;
2622         ;; the problem is that the two first are in turn optionally followed
2623         ;; by the third.  So we parse the first two here (if there are any)...
2624
2625         (when (eq (char-after) ?\ )
2626           (imap-forward)
2627           (let (lines)
2628             (cond ((eq (char-after) ?\();; body-type-msg:
2629                    (push (imap-parse-envelope) body);; envelope
2630                    (imap-forward)
2631                    (push (imap-parse-body) body);; body
2632                    ;; buggy stalker communigate pro 3.0 doesn't print
2633                    ;; number of lines in message/rfc822 attachment
2634                    (if (eq (char-after) ?\))
2635                        (push 0 body)
2636                      (imap-forward)
2637                      (push (imap-parse-number) body))) ;; body-fld-lines
2638                   ((setq lines (imap-parse-number))    ;; body-type-text:
2639                    (push lines body))                  ;; body-fld-lines
2640                   (t
2641                    (backward-char)))))                 ;; no match...
2642
2643         ;; ...and then parse the third one here...
2644
2645         (when (eq (char-after) ?\ );; body-ext-1part:
2646           (imap-forward)
2647           (push (imap-parse-nstring) body);; body-fld-md5
2648           (setq body (append (imap-parse-body-ext) body)));; body-ext-1part..
2649
2650         (assert (eq (char-after) ?\)) t "In imap-parse-body 2")
2651         (imap-forward)
2652         (nreverse body)))))
2653
2654 (when imap-debug                        ; (untrace-all)
2655   (require 'trace)
2656   (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2657   (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
2658           '(
2659             imap-utf7-encode
2660             imap-utf7-decode
2661             imap-error-text
2662             imap-kerberos4s-p
2663             imap-kerberos4-open
2664             imap-ssl-p
2665             imap-ssl-open
2666             imap-network-p
2667             imap-network-open
2668             imap-interactive-login
2669             imap-kerberos4a-p
2670             imap-kerberos4-auth
2671             imap-cram-md5-p
2672             imap-cram-md5-auth
2673             imap-login-p
2674             imap-login-auth
2675             imap-anonymous-p
2676             imap-anonymous-auth
2677             imap-open-1
2678             imap-open
2679             imap-opened
2680             imap-authenticate
2681             imap-close
2682             imap-capability
2683             imap-namespace
2684             imap-send-command-wait
2685             imap-mailbox-put
2686             imap-mailbox-get
2687             imap-mailbox-map-1
2688             imap-mailbox-map
2689             imap-current-mailbox
2690             imap-current-mailbox-p-1
2691             imap-current-mailbox-p
2692             imap-mailbox-select-1
2693             imap-mailbox-select
2694             imap-mailbox-examine-1
2695             imap-mailbox-examine
2696             imap-mailbox-unselect
2697             imap-mailbox-expunge
2698             imap-mailbox-close
2699             imap-mailbox-create-1
2700             imap-mailbox-create
2701             imap-mailbox-delete
2702             imap-mailbox-rename
2703             imap-mailbox-lsub
2704             imap-mailbox-list
2705             imap-mailbox-subscribe
2706             imap-mailbox-unsubscribe
2707             imap-mailbox-status
2708             imap-mailbox-acl-get
2709             imap-mailbox-acl-set
2710             imap-mailbox-acl-delete
2711             imap-current-message
2712             imap-list-to-message-set
2713             imap-fetch-asynch
2714             imap-fetch
2715             imap-message-put
2716             imap-message-get
2717             imap-message-map
2718             imap-search
2719             imap-message-flag-permanent-p
2720             imap-message-flags-set
2721             imap-message-flags-del
2722             imap-message-flags-add
2723             imap-message-copyuid-1
2724             imap-message-copyuid
2725             imap-message-copy
2726             imap-message-appenduid-1
2727             imap-message-appenduid
2728             imap-message-append
2729             imap-body-lines
2730             imap-envelope-from
2731             imap-send-command-1
2732             imap-send-command
2733             imap-wait-for-tag
2734             imap-sentinel
2735             imap-find-next-line
2736             imap-arrival-filter
2737             imap-parse-greeting
2738             imap-parse-response
2739             imap-parse-resp-text
2740             imap-parse-resp-text-code
2741             imap-parse-data-list
2742             imap-parse-fetch
2743             imap-parse-status
2744             imap-parse-acl
2745             imap-parse-flag-list
2746             imap-parse-envelope
2747             imap-parse-body-extension
2748             imap-parse-body
2749             )))
2750
2751 (provide 'imap)
2752
2753 ;;; imap.el ends here