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

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