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