cgit.sxemacs.org Git - gnus/blob - lisp/imap.el

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