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