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

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