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