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