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

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