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