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