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