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

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