git.chise.org Git - elisp/gnus.git-/blob - lisp/imap.el

   1 ;;; imap.el --- imap library
   2 ;; Copyright (C) 1998, 1999, 2000
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; imap.el is a elisp library providing an interface for talking to
  28 ;; IMAP servers.
  29 ;;
  30 ;; imap.el is roughly divided in two parts, one that parses IMAP
  31 ;; responses from the server and storing data into buffer-local
  32 ;; variables, and one for utility functions which send commands to
  33 ;; server, waits for an answer, and return information.  The latter
  34 ;; part is layered on top of the previous.
  35 ;;
  36 ;; The imap.el API consist of the following functions, other functions
  37 ;; in this file should not be called directly and the result of doing
  38 ;; so are at best undefined.
  39 ;;
  40 ;; Global commands:
  41 ;;
  42 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  43 ;; imap-capability, imap-namespace, imap-error-text
  44 ;;
  45 ;; Mailbox commands:
  46 ;;
  47 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  48 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  49 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  50 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  51 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  52 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  53 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  54 ;;
  55 ;; Message commands:
  56 ;;
  57 ;; imap-fetch-asynch,                 imap-fetch,
  58 ;; imap-current-message,              imap-list-to-message-set,
  59 ;; imap-message-get,                  imap-message-map
  60 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  61 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  62 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  63 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  64 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  65 ;; imap-message-body,                 imap-message-flag-permanent-p
  66 ;; imap-message-flags-set,            imap-message-flags-del
  67 ;; imap-message-flags-add,            imap-message-copyuid
  68 ;; imap-message-copy,                 imap-message-appenduid
  69 ;; imap-message-append,               imap-envelope-from
  70 ;; imap-body-lines
  71 ;;
  72 ;; It is my hope that theese commands should be pretty self
  73 ;; explanatory for someone that know IMAP.  All functions have
  74 ;; additional documentation on how to invoke them.
  75 ;;
  76 ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
  77 ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  78 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  79 ;; 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-when-compile (require 'static))
 141
 142 (require 'base64)
 143
 144 (eval-and-compile
 145   (autoload 'open-ssl-stream "ssl")
 146   (autoload 'starttls-open-stream "starttls")
 147   (autoload 'starttls-negotiate "starttls")
 148   (autoload 'rfc2104-hash "rfc2104")
 149   (autoload 'md5 "md5")
 150   (autoload 'utf7-encode "utf7")
 151   (autoload 'utf7-decode "utf7")
 152   (autoload 'format-spec "format-spec")
 153   (autoload 'format-spec-make "format-spec")
 154   ;; Avoid use gnus-point-at-eol so we're independent of Gnus.  These
 155   ;; days we have point-at-eol anyhow.
 156   (if (fboundp 'point-at-eol)
 157       (defalias 'imap-point-at-eol 'point-at-eol)
 158     (defun imap-point-at-eol ()
 159       (save-excursion
 160         (end-of-line)
 161         (point))))
 162   (autoload 'sasl-digest-md5-digest-response "sasl"))
 163
 164 ;; User variables.
 165
 166 (defgroup imap nil
 167   "Low-level IMAP issues."
 168   :version "21.1"
 169   :group 'mail)
 170
 171 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 172                                     "imtest -kp %s %p")
 173   "List of strings containing commands for Kerberos 4 authentication.
 174 %s is replaced with server hostname, %p with port to connect to, and
 175 %l with the value of `imap-default-user'.  The program should accept
 176 IMAP commands on stdin and return responses to stdout.  Each entry in
 177 the list is tried until a successful connection is made."
 178   :group 'imap
 179   :type '(repeat string))
 180
 181 (defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s")
 182   "List of strings containing commands for GSSAPI (krb5) authentication.
 183 %s is replaced with server hostname, %p with port to connect to, and
 184 %l with the value of `imap-default-user'.  The program should accept
 185 IMAP commands on stdin and return responses to stdout.  Each entry in
 186 the list is tried until a successful connection is made."
 187   :group 'imap
 188   :type '(repeat string))
 189
 190 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 191                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 192                               "s_client -quiet -ssl3 -connect %s:%p"
 193                               "s_client -quiet -ssl2 -connect %s:%p")
 194   "A string, or list of strings, containing commands for SSL connections.
 195 Within a string, %s is replaced with the server address and %p with
 196 port number on server.  The program should accept IMAP commands on
 197 stdin and return responses to stdout.  Each entry in the list is tried
 198 until a successful connection is made."
 199   :group 'imap
 200   :type '(choice string
 201                  (repeat string)))
 202
 203 (defcustom imap-shell-program '("ssh %s imapd"
 204                                 "rsh %s imapd"
 205                                 "ssh %g ssh %s imapd"
 206                                 "rsh %g rsh %s imapd")
 207   "A list of strings, containing commands for IMAP connection.
 208 Within a string, %s is replaced with the server address, %p with port
 209 number on server, %g with `imap-shell-host', and %l with
 210 `imap-default-user'.  The program should read IMAP commands from stdin
 211 and write IMAP response to stdout. Each entry in the list is tried
 212 until a successful connection is made."
 213   :group 'imap
 214   :type '(repeat string))
 215
 216 (defcustom imap-process-connection-type nil
 217   "*Value for `process-connection-type' to use for Kerberos4 and GSSAPI."
 218   :group 'imap
 219   :type 'boolean)
 220
 221 (defvar imap-shell-host "gateway"
 222   "Hostname of rlogin proxy.")
 223
 224 (defvar imap-default-user (user-login-name)
 225   "Default username to use.")
 226
 227 (defvar imap-error nil
 228   "Error codes from the last command.")
 229
 230 ;; Various variables.
 231
 232 (defvar imap-fetch-data-hook nil
 233   "Hooks called after receiving each FETCH response.")
 234
 235 (defvar imap-streams '(gssapi kerberos4 starttls ssl network shell)
 236   "Priority of streams to consider when opening connection to server.")
 237
 238 (defvar imap-stream-alist
 239   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 240     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 241     (ssl       imap-ssl-p              imap-ssl-open)
 242     (network   imap-network-p          imap-network-open)
 243     (shell     imap-shell-p            imap-shell-open)
 244     (starttls  imap-starttls-p         imap-starttls-open))
 245   "Definition of network streams.
 246
 247 \(NAME CHECK OPEN)
 248
 249 NAME names the stream, CHECK is a function returning non-nil if the
 250 server support the stream and OPEN is a function for opening the
 251 stream.")
 252
 253 (defvar imap-authenticators '(gssapi
 254                               kerberos4
 255                               digest-md5
 256                               cram-md5
 257                               login
 258                               anonymous)
 259   "Priority of authenticators to consider when authenticating to server.")
 260
 261 (defvar imap-authenticator-alist
 262   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 263     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 264     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 265     (login      imap-login-p          imap-login-auth)
 266     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 267     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 268   "Definition of authenticators.
 269
 270 \(NAME CHECK AUTHENTICATE)
 271
 272 NAME names the authenticator.  CHECK is a function returning non-nil if
 273 the server support the authenticator and AUTHENTICATE is a function
 274 for doing the actuall authentification.")
 275
 276 (defvar imap-use-utf7 t
 277   "If non-nil, do utf7 encoding/decoding of mailbox names.
 278 Since the UTF7 decoding currently only decodes into ISO-8859-1
 279 characters, you may disable this decoding if you need to access UTF7
 280 encoded mailboxes which doesn't translate into ISO-8859-1.")
 281
 282 ;; Internal constants.  Change theese and die.
 283
 284 (defconst imap-default-port 143)
 285 (defconst imap-default-ssl-port 993)
 286 (defconst imap-default-stream 'network)
 287 (defconst imap-local-variables '(imap-server
 288                                  imap-port
 289                                  imap-client-eol
 290                                  imap-server-eol
 291                                  imap-auth
 292                                  imap-stream
 293                                  imap-username
 294                                  imap-password
 295                                  imap-current-mailbox
 296                                  imap-current-target-mailbox
 297                                  imap-message-data
 298                                  imap-capability
 299                                  imap-namespace
 300                                  imap-state
 301                                  imap-reached-tag
 302                                  imap-failed-tags
 303                                  imap-tag
 304                                  imap-process
 305                                  imap-calculate-literal-size-first
 306                                  imap-mailbox-data))
 307
 308 ;; Internal variables.
 309
 310 (defvar imap-stream nil)
 311 (defvar imap-auth nil)
 312 (defvar imap-server nil)
 313 (defvar imap-port nil)
 314 (defvar imap-username nil)
 315 (defvar imap-password nil)
 316 (defvar imap-calculate-literal-size-first nil)
 317 (defvar imap-state 'closed
 318   "IMAP state.
 319 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 320 and `examine'.")
 321
 322 (defvar imap-server-eol "\r\n"
 323   "The EOL string sent from the server.")
 324
 325 (defvar imap-client-eol "\r\n"
 326   "The EOL string we send to the server.")
 327
 328 (defvar imap-current-mailbox nil
 329   "Current mailbox name.")
 330
 331 (defvar imap-current-target-mailbox nil
 332   "Current target mailbox for COPY and APPEND commands.")
 333
 334 (defvar imap-mailbox-data nil
 335   "Obarray with mailbox data.")
 336
 337 (defvar imap-mailbox-prime 997
 338   "Length of imap-mailbox-data.")
 339
 340 (defvar imap-current-message nil
 341   "Current message number.")
 342
 343 (defvar imap-message-data nil
 344   "Obarray with message data.")
 345
 346 (defvar imap-message-prime 997
 347   "Length of imap-message-data.")
 348
 349 (defvar imap-capability nil
 350   "Capability for server.")
 351
 352 (defvar imap-namespace nil
 353   "Namespace for current server.")
 354
 355 (defvar imap-reached-tag 0
 356   "Lower limit on command tags that have been parsed.")
 357
 358 (defvar imap-failed-tags nil
 359   "Alist of tags that failed.
 360 Each element is a list with four elements; tag (a integer), response
 361 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 362 human readable response text (a string).")
 363
 364 (defvar imap-tag 0
 365   "Command tag number.")
 366
 367 (defvar imap-process nil
 368   "Process.")
 369
 370 (defvar imap-continuation nil
 371   "Non-nil indicates that the server emitted a continuation request.
 372 The actually value is really the text on the continuation line.")
 373
 374 (defvar imap-log nil
 375   "Name of buffer for imap session trace.
 376 For example: (setq imap-log \"*imap-log*\")")
 377
 378 (defvar imap-debug nil                  ;"*imap-debug*"
 379   "Name of buffer for random debug spew.
 380 For example: (setq imap-debug \"*imap-debug*\")")
 381
 382 \f
 383 ;; Utility functions:
 384
 385 (defun imap-read-passwd (prompt &rest args)
 386   "Read a password using PROMPT.
 387 If ARGS, PROMPT is used as an argument to `format'."
 388   (let ((prompt (if args
 389                     (apply 'format prompt args)
 390                   prompt)))
 391     (funcall (if (or (fboundp 'read-passwd)
 392                      (and (load "subr" t)
 393                           (fboundp 'read-passwd))
 394                      (and (load "passwd" t)
 395                           (fboundp 'read-passwd)))
 396                  'read-passwd
 397                (autoload 'ange-ftp-read-passwd "ange-ftp")
 398                'ange-ftp-read-passwd)
 399              prompt)))
 400
 401 (defsubst imap-utf7-encode (string)
 402   (if imap-use-utf7
 403       (and string
 404            (condition-case ()
 405                (utf7-encode string t)
 406              (error (message
 407                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 408                      string)
 409                     string)))
 410     string))
 411
 412 (defsubst imap-utf7-decode (string)
 413   (if imap-use-utf7
 414       (and string
 415            (condition-case ()
 416                (utf7-decode string t)
 417              (error (message
 418                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 419                      string)
 420                     string)))
 421     string))
 422
 423 (defsubst imap-ok-p (status)
 424   (if (eq status 'OK)
 425       t
 426     (setq imap-error status)
 427     nil))
 428
 429 (defun imap-error-text (&optional buffer)
 430   (with-current-buffer (or buffer (current-buffer))
 431     (nth 3 (car imap-failed-tags))))
 432
 433 \f
 434 ;; Server functions; stream stuff:
 435
 436 (defun imap-kerberos4-stream-p (buffer)
 437   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 438
 439 (defun imap-kerberos4-open (name buffer server port)
 440   (let ((cmds imap-kerberos4-program)
 441         cmd done)
 442     (while (and (not done) (setq cmd (pop cmds)))
 443       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 444       (erase-buffer)
 445       (let* ((port (or port imap-default-port))
 446              (process-connection-type imap-process-connection-type)
 447              (process (as-binary-process
 448                        (start-process
 449                         name buffer shell-file-name shell-command-switch
 450                         (format-spec
 451                          cmd
 452                          (format-spec-make
 453                           ?s server
 454                           ?p (number-to-string port)
 455                           ?l imap-default-user)))))
 456              response)
 457         (when process
 458           (with-current-buffer buffer
 459             (setq imap-client-eol "\n"
 460                   imap-calculate-literal-size-first t)
 461             (while (and (memq (process-status process) '(open run))
 462                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 463                         (goto-char (point-min))
 464                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 465                         (or (while (looking-at "^C:")
 466                               (forward-line))
 467                             t)
 468                         ;; cyrus 1.6 imtest print "S: " before server greeting
 469                         (or (not (looking-at "S: "))
 470                             (forward-char 3)
 471                             t)
 472                         (not (and (imap-parse-greeting)
 473                                   ;; success in imtest < 1.6:
 474                                   (or (re-search-forward
 475                                        "^__\\(.*\\)__\n" nil t)
 476                                       ;; success in imtest 1.6:
 477                                       (re-search-forward
 478                                        "^\\(Authenticat.*\\)" nil t))
 479                                   (setq response (match-string 1)))))
 480               (accept-process-output process 1)
 481               (sit-for 1))
 482             (and imap-log
 483                  (with-current-buffer (get-buffer-create imap-log)
 484                    (buffer-disable-undo)
 485                    (goto-char (point-max))
 486                    (insert-buffer-substring buffer)))
 487             (erase-buffer)
 488             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 489                      (if response (concat "done, " response) "failed"))
 490             (if (and response (let ((case-fold-search nil))
 491                                 (not (string-match "failed" response))))
 492                 (setq done process)
 493               (if (memq (process-status process) '(open run))
 494                   (imap-send-command-wait "LOGOUT"))
 495               (delete-process process)
 496               nil)))))
 497     done))
 498
 499 (defun imap-gssapi-stream-p (buffer)
 500   (imap-capability 'AUTH=GSSAPI buffer))
 501
 502 (defun imap-gssapi-open (name buffer server port)
 503   (let ((cmds imap-gssapi-program)
 504         cmd done)
 505     (while (and (not done) (setq cmd (pop cmds)))
 506       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 507       (let* ((port (or port imap-default-port))
 508              (process-connection-type imap-process-connection-type)
 509              (process (as-binary-process
 510                        (start-process
 511                         name buffer shell-file-name shell-command-switch
 512                         (format-spec
 513                          cmd
 514                          (format-spec-make
 515                           ?s server
 516                           ?p (number-to-string port)
 517                           ?l imap-default-user)))))
 518              response)
 519         (when process
 520           (with-current-buffer buffer
 521             (setq imap-client-eol "\n"
 522                   imap-calculate-literal-size-first t)
 523             (while (and (memq (process-status process) '(open run))
 524                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 525                         (goto-char (point-min))
 526                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 527                         (or (while (looking-at "^C:")
 528                               (forward-line))
 529                             t)
 530                         ;; cyrus 1.6 imtest print "S: " before server greeting
 531                         (or (not (looking-at "S: "))
 532                             (forward-char 3)
 533                             t)
 534                         (not (and (imap-parse-greeting)
 535                                   ;; success in imtest 1.6:
 536                                   (re-search-forward
 537                                    "^\\(Authenticat.*\\)" nil t)
 538                                   (setq response (match-string 1)))))
 539               (accept-process-output process 1)
 540               (sit-for 1))
 541             (and imap-log
 542                  (with-current-buffer (get-buffer-create imap-log)
 543                    (buffer-disable-undo)
 544                    (goto-char (point-max))
 545                    (insert-buffer-substring buffer)))
 546             (erase-buffer)
 547             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 548             (if (and response (let ((case-fold-search nil))
 549                                 (not (string-match "failed" response))))
 550                 (setq done process)
 551               (if (memq (process-status process) '(open run))
 552                   (imap-send-command-wait "LOGOUT"))
 553               (delete-process process)
 554               nil)))))
 555     done))
 556
 557 (defun imap-ssl-p (buffer)
 558   nil)
 559
 560 (defun imap-ssl-open (name buffer server port)
 561   "Open a SSL connection to server."
 562   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 563                 (list imap-ssl-program)))
 564         cmd done)
 565     (ignore-errors (require 'ssl))
 566     (while (and (not done) (setq cmd (pop cmds)))
 567       (message "imap: Opening SSL connection with `%s'..." cmd)
 568       (let* ((port (or port imap-default-ssl-port))
 569              (ssl-program-name shell-file-name)
 570              (ssl-program-arguments
 571               (list shell-command-switch
 572                     (format-spec cmd (format-spec-make
 573                                       ?s server
 574                                       ?p (number-to-string port)))))
 575              process)
 576         (when (setq process
 577                     (ignore-errors
 578                       (cond ((eq system-type 'windows-nt)
 579                              (let (selective-display
 580                                    (coding-system-for-write 'binary)
 581                                    (coding-system-for-read 'raw-text-dos)
 582                                    (output-coding-system 'binary)
 583                                    (input-coding-system 'raw-text-dos))
 584                                (open-ssl-stream name buffer server port)))
 585                             (t
 586                              (as-binary-process
 587                               (open-ssl-stream name buffer server port))))))
 588           (with-current-buffer buffer
 589             (goto-char (point-min))
 590             (while (and (memq (process-status process) '(open run))
 591                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 592                         (goto-char (point-max))
 593                         (forward-line -1)
 594                         (not (imap-parse-greeting)))
 595               (accept-process-output process 1)
 596               (sit-for 1))
 597             (and imap-log
 598                  (with-current-buffer (get-buffer-create imap-log)
 599                    (buffer-disable-undo)
 600                    (goto-char (point-max))
 601                    (insert-buffer-substring buffer)))
 602             (erase-buffer)
 603             (when (memq (process-status process) '(open run))
 604               (setq done process))))))
 605     (if done
 606         (progn
 607           (message "imap: Opening SSL connection with `%s'...done" cmd)
 608           done)
 609           (message "imap: Opening SSL connection with `%s'...failed" cmd)
 610       nil)))
 611
 612 (defun imap-network-p (buffer)
 613   t)
 614
 615 (defun imap-network-open (name buffer server port)
 616   (let* ((port (or port imap-default-port))
 617          (process (open-network-stream-as-binary name buffer server port)))
 618     (when process
 619       (while (and (memq (process-status process) '(open run))
 620                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 621                   (goto-char (point-min))
 622                   (not (imap-parse-greeting)))
 623         (accept-process-output process 1)
 624         (sit-for 1))
 625       (and imap-log
 626            (with-current-buffer (get-buffer-create imap-log)
 627              (buffer-disable-undo)
 628              (goto-char (point-max))
 629              (insert-buffer-substring buffer)))
 630       (when (memq (process-status process) '(open run))
 631         process))))
 632
 633 (defun imap-shell-p (buffer)
 634   nil)
 635
 636 (defun imap-shell-open (name buffer server port)
 637   (let ((cmds imap-shell-program)
 638         cmd done)
 639     (while (and (not done) (setq cmd (pop cmds)))
 640       (message "imap: Opening IMAP connection with `%s'..." cmd)
 641       (setq imap-client-eol "\n")
 642       (let* ((port (or port imap-default-port))
 643              (process (as-binary-process
 644                        (start-process
 645                         name buffer shell-file-name shell-command-switch
 646                         (format-spec
 647                          cmd
 648                          (format-spec-make
 649                           ?s server
 650                           ?g imap-shell-host
 651                           ?p (number-to-string port)
 652                           ?l imap-default-user))))))
 653         (when process
 654           (while (and (memq (process-status process) '(open run))
 655                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 656                       (goto-char (point-min))
 657                       (not (imap-parse-greeting)))
 658             (accept-process-output process 1)
 659             (sit-for 1))
 660           (and imap-log
 661                (with-current-buffer (get-buffer-create imap-log)
 662                  (buffer-disable-undo)
 663                  (goto-char (point-max))
 664                  (insert-buffer-substring buffer)))
 665           (erase-buffer)
 666           (when (memq (process-status process) '(open run))
 667             (setq done process)))))
 668     (if done
 669         (progn
 670           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 671           done)
 672       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 673       nil)))
 674
 675 (defun imap-starttls-p (buffer)
 676   (and (imap-capability 'STARTTLS buffer)
 677        (condition-case ()
 678            (progn
 679              (require 'starttls)
 680              (call-process "starttls"))
 681          (error nil))))
 682
 683 (defun imap-starttls-open (name buffer server port)
 684   (let* ((port (or port imap-default-port))
 685          (process (as-binary-process
 686                    (starttls-open-stream name buffer server port)))
 687          done)
 688     (message "imap: Connecting with STARTTLS...")
 689     (when process
 690       (while (and (memq (process-status process) '(open run))
 691                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 692                   (goto-char (point-min))
 693                   (not (imap-parse-greeting)))
 694         (accept-process-output process 1)
 695         (sit-for 1))
 696       (and imap-log
 697            (with-current-buffer (get-buffer-create imap-log)
 698              (buffer-disable-undo)
 699              (goto-char (point-max))
 700              (insert-buffer-substring buffer)))
 701       (let ((imap-process process))
 702         (unwind-protect
 703             (progn
 704               (set-process-filter imap-process 'imap-arrival-filter)
 705               (when (and (eq imap-stream 'starttls)
 706                          (imap-ok-p (imap-send-command-wait "STARTTLS")))
 707                 (starttls-negotiate imap-process)))
 708           (set-process-filter imap-process nil)))
 709       (when (memq (process-status process) '(open run))
 710         (setq done process)))
 711     (if done
 712         (progn
 713           (message "imap: Connecting with STARTTLS...done")
 714           done)
 715       (message "imap: Connecting with STARTTLS...failed")
 716       nil)))
 717
 718 ;; Server functions; authenticator stuff:
 719
 720 (defun imap-interactive-login (buffer loginfunc)
 721   "Login to server in BUFFER.
 722 LOGINFUNC is passed a username and a password, it should return t if
 723 it where sucessful authenticating itself to the server, nil otherwise.
 724 Returns t if login was successful, nil otherwise."
 725   (with-current-buffer buffer
 726     (make-local-variable 'imap-username)
 727     (make-local-variable 'imap-password)
 728     (let (user passwd ret)
 729       ;;      (condition-case ()
 730       (while (or (not user) (not passwd))
 731         (setq user (or imap-username
 732                        (read-from-minibuffer
 733                         (concat "IMAP username for " imap-server ": ")
 734                         (or user imap-default-user))))
 735         (setq passwd (or imap-password
 736                          (imap-read-passwd
 737                           (concat "IMAP password for " user "@"
 738                                   imap-server ": "))))
 739         (when (and user passwd)
 740           (if (funcall loginfunc user passwd)
 741               (progn
 742                 (setq ret t
 743                       imap-username user)
 744                 (if (and (not imap-password)
 745                          (y-or-n-p "Store password for this session? "))
 746                     (setq imap-password passwd)))
 747             (message "Login failed...")
 748             (setq passwd nil)
 749             (sit-for 1))))
 750       ;;        (quit (with-current-buffer buffer
 751       ;;                (setq user nil
 752       ;;                      passwd nil)))
 753       ;;        (error (with-current-buffer buffer
 754       ;;                 (setq user nil
 755       ;;                       passwd nil))))
 756       ret)))
 757
 758 (defun imap-gssapi-auth-p (buffer)
 759   (imap-capability 'AUTH=GSSAPI buffer))
 760
 761 (defun imap-gssapi-auth (buffer)
 762   (message "imap: Authenticating using GSSAPI...%s"
 763            (if (eq imap-stream 'gssapi) "done" "failed"))
 764   (eq imap-stream 'gssapi))
 765
 766 (defun imap-kerberos4-auth-p (buffer)
 767   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 768
 769 (defun imap-kerberos4-auth (buffer)
 770   (message "imap: Authenticating using Kerberos 4...%s"
 771            (if (eq imap-stream 'kerberos4) "done" "failed"))
 772   (eq imap-stream 'kerberos4))
 773
 774 (defun imap-cram-md5-p (buffer)
 775   (imap-capability 'AUTH=CRAM-MD5 buffer))
 776
 777 (defun imap-cram-md5-auth (buffer)
 778   "Login to server using the AUTH CRAM-MD5 method."
 779   (message "imap: Authenticating using CRAM-MD5...")
 780   (let ((done (imap-interactive-login
 781                buffer
 782                (lambda (user passwd)
 783                  (imap-ok-p
 784                   (imap-send-command-wait
 785                    (list
 786                     "AUTHENTICATE CRAM-MD5"
 787                     (lambda (challenge)
 788                       (let* ((decoded (base64-decode-string challenge))
 789                              (hash-function
 790                               (if (and (featurep 'xemacs)
 791                                        (>= (function-max-args 'md5) 4))
 792                                   (lambda (object &optional start end)
 793                                     (md5 object start end 'binary))
 794                                 'md5))
 795                              (hash (rfc2104-hash hash-function 64 16
 796                                                  passwd decoded))
 797                              (response (concat user " " hash))
 798                              (encoded (base64-encode-string response)))
 799                         encoded)))))))))
 800     (if done
 801         (message "imap: Authenticating using CRAM-MD5...done")
 802       (message "imap: Authenticating using CRAM-MD5...failed"))))
 803
 804 (defun imap-login-p (buffer)
 805   (and (not (imap-capability 'LOGINDISABLED buffer))
 806        (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
 807
 808 (defun imap-login-auth (buffer)
 809   "Login to server using the LOGIN command."
 810   (message "imap: Plaintext authentication...")
 811   (imap-interactive-login buffer
 812                           (lambda (user passwd)
 813                             (imap-ok-p (imap-send-command-wait
 814                                         (concat "LOGIN \"" user "\" \""
 815                                                 passwd "\""))))))
 816
 817 (defun imap-anonymous-p (buffer)
 818   t)
 819
 820 (defun imap-anonymous-auth (buffer)
 821   (message "imap: Loging in anonymously...")
 822   (with-current-buffer buffer
 823     (imap-ok-p (imap-send-command-wait
 824                 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
 825                                                      (system-name)) "\"")))))
 826
 827 (defun imap-digest-md5-p (buffer)
 828   (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
 829        (condition-case ()
 830            (require 'digest-md5)
 831          (error nil))))
 832
 833 (defun imap-digest-md5-auth (buffer)
 834   "Login to server using the AUTH DIGEST-MD5 method."
 835   (message "imap: Authenticating using DIGEST-MD5...")
 836   (imap-interactive-login
 837    buffer
 838    (lambda (user passwd)
 839      (let ((tag
 840             (imap-send-command
 841              (list
 842               "AUTHENTICATE DIGEST-MD5"
 843               (lambda (challenge)
 844                 (base64-encode-string
 845                  (sasl-digest-md5-digest-response
 846                   (base64-decode-string challenge)
 847                   user passwd "imap" imap-server)
 848                  'no-line-break))))))
 849        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
 850            nil
 851          (setq imap-continuation nil)
 852          (imap-send-command-1 "")
 853          (imap-ok-p (imap-wait-for-tag tag)))))))
 854
 855 ;; Server functions:
 856
 857 (defun imap-open-1 (buffer)
 858   (with-current-buffer buffer
 859     (erase-buffer)
 860     (setq imap-current-mailbox nil
 861           imap-current-message nil
 862           imap-state 'initial
 863           imap-process (condition-case ()
 864                            (funcall (nth 2 (assq imap-stream
 865                                                  imap-stream-alist))
 866                                     "imap" buffer imap-server imap-port)
 867                          ((error quit) nil)))
 868     (when imap-process
 869       (set-process-filter imap-process 'imap-arrival-filter)
 870       (set-process-sentinel imap-process 'imap-sentinel)
 871       (while (and (eq imap-state 'initial)
 872                   (memq (process-status imap-process) '(open run)))
 873         (message "Waiting for response from %s..." imap-server)
 874         (accept-process-output imap-process 1))
 875       (message "Waiting for response from %s...done" imap-server)
 876       (and (memq (process-status imap-process) '(open run))
 877            imap-process))))
 878
 879 (defun imap-open (server &optional port stream auth buffer)
 880   "Open a IMAP connection to host SERVER at PORT returning a buffer.
 881 If PORT is unspecified, a default value is used (143 except
 882 for SSL which use 993).
 883 STREAM indicates the stream to use, see `imap-streams' for available
 884 streams.  If nil, it choices the best stream the server is capable of.
 885 AUTH indicates authenticator to use, see `imap-authenticators' for
 886 available authenticators.  If nil, it choices the best stream the
 887 server is capable of.
 888 BUFFER can be a buffer or a name of a buffer, which is created if
 889 necessery.  If nil, the buffer name is generated."
 890   (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
 891   (with-current-buffer (get-buffer-create buffer)
 892     (if (imap-opened buffer)
 893         (imap-close buffer))
 894     (mapcar 'make-local-variable imap-local-variables)
 895     (set-buffer-multibyte nil)
 896     (buffer-disable-undo)
 897     (setq imap-server (or server imap-server))
 898     (setq imap-port (or port imap-port))
 899     (setq imap-auth (or auth imap-auth))
 900     (setq imap-stream (or stream imap-stream))
 901     (message "imap: Connecting to %s..." imap-server)
 902     (if (let ((imap-stream (or imap-stream imap-default-stream)))
 903           (imap-open-1 buffer))
 904         ;; Choose stream.
 905         (let (stream-changed)
 906           (message "imap: Connecting to %s...done" imap-server)
 907           (when (null imap-stream)
 908             (let ((streams imap-streams))
 909               (while (setq stream (pop streams))
 910                 (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
 911                     (setq stream-changed (not (eq (or imap-stream
 912                                                       imap-default-stream)
 913                                                   stream))
 914                           imap-stream stream
 915                           streams nil)))
 916               (unless imap-stream
 917                 (error "Couldn't figure out a stream for server"))))
 918           (when stream-changed
 919             (message "imap: Reconnecting with stream `%s'..." imap-stream)
 920             (imap-close buffer)
 921             (if (imap-open-1 buffer)
 922                 (message "imap: Reconnecting with stream `%s'...done"
 923                          imap-stream)
 924               (message "imap: Reconnecting with stream `%s'...failed"
 925                        imap-stream))
 926             (setq imap-capability nil))
 927           (if (imap-opened buffer)
 928               ;; Choose authenticator
 929               (when (and (null imap-auth) (not (eq imap-state 'auth)))
 930                 (let ((auths imap-authenticators))
 931                   (while (setq auth (pop auths))
 932                     (if (funcall (nth 1 (assq auth imap-authenticator-alist))
 933                                  buffer)
 934                         (setq imap-auth auth
 935                               auths nil)))
 936                   (unless imap-auth
 937                     (error "Couldn't figure out authenticator for server"))))))
 938       (message "imap: Connecting to %s...failed" imap-server))
 939     (when (imap-opened buffer)
 940       (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))
 941       buffer)))
 942
 943 (defun imap-opened (&optional buffer)
 944   "Return non-nil if connection to imap server in BUFFER is open.
 945 If BUFFER is nil then the current buffer is used."
 946   (and (setq buffer (get-buffer (or buffer (current-buffer))))
 947        (buffer-live-p buffer)
 948        (with-current-buffer buffer
 949          (and imap-process
 950               (memq (process-status imap-process) '(open run))))))
 951
 952 (defun imap-authenticate (&optional user passwd buffer)
 953   "Authenticate to server in BUFFER, using current buffer if nil.
 954 It uses the authenticator specified when opening the server.  If the
 955 authenticator requires username/passwords, they are queried from the
 956 user and optionally stored in the buffer.  If USER and/or PASSWD is
 957 specified, the user will not be questioned and the username and/or
 958 password is remembered in the buffer."
 959   (with-current-buffer (or buffer (current-buffer))
 960     (if (not (eq imap-state 'nonauth))
 961         (or (eq imap-state 'auth)
 962             (eq imap-state 'select)
 963             (eq imap-state 'examine))
 964       (make-local-variable 'imap-username)
 965       (make-local-variable 'imap-password)
 966       (if user (setq imap-username user))
 967       (if passwd (setq imap-password passwd))
 968       (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer)
 969           (setq imap-state 'auth)))))
 970
 971 (defun imap-close (&optional buffer)
 972   "Close connection to server in BUFFER.
 973 If BUFFER is nil, the current buffer is used."
 974   (with-current-buffer (or buffer (current-buffer))
 975     (and (imap-opened)
 976          (not (imap-ok-p (imap-send-command-wait "LOGOUT")))
 977          (message "Server %s didn't let me log out" imap-server))
 978     (when (and imap-process
 979                (memq (process-status imap-process) '(open run)))
 980       (delete-process imap-process))
 981     (setq imap-current-mailbox nil
 982           imap-current-message nil
 983           imap-process nil)
 984     (erase-buffer)
 985     t))
 986
 987 (defun imap-capability (&optional identifier buffer)
 988   "Return a list of identifiers which server in BUFFER support.
 989 If IDENTIFIER, return non-nil if it's among the servers capabilities.
 990 If BUFFER is nil, the current buffer is assumed."
 991   (with-current-buffer (or buffer (current-buffer))
 992     (unless imap-capability
 993       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
 994         (setq imap-capability '(IMAP2))))
 995     (if identifier
 996         (memq (intern (upcase (symbol-name identifier))) imap-capability)
 997       imap-capability)))
 998
 999 (defun imap-namespace (&optional buffer)
1000   "Return a namespace hierarchy at server in BUFFER.
1001 If BUFFER is nil, the current buffer is assumed."
1002   (with-current-buffer (or buffer (current-buffer))
1003     (unless imap-namespace
1004       (when (imap-capability 'NAMESPACE)
1005         (imap-send-command-wait "NAMESPACE")))
1006     imap-namespace))
1007
1008 (defun imap-send-command-wait (command &optional buffer)
1009   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1010
1011 \f
1012 ;; Mailbox functions:
1013
1014 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1015   (with-current-buffer (or buffer (current-buffer))
1016     (if imap-mailbox-data
1017         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1018              propname value)
1019       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1020              propname value mailbox (current-buffer)))
1021     t))
1022
1023 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1024   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1025        propname))
1026
1027 (defun imap-mailbox-get (propname &optional mailbox buffer)
1028   (let ((mailbox (imap-utf7-encode mailbox)))
1029     (with-current-buffer (or buffer (current-buffer))
1030       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1031
1032 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1033   (with-current-buffer (or buffer (current-buffer))
1034     (let (result)
1035       (mapatoms
1036        (lambda (s)
1037          (push (funcall func (if mailbox-decoder
1038                                  (funcall mailbox-decoder (symbol-name s))
1039                                (symbol-name s))) result))
1040        imap-mailbox-data)
1041       result)))
1042
1043 (defun imap-mailbox-map (func &optional buffer)
1044   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1045 Function should take a mailbox name (a string) as
1046 the only argument."
1047   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1048
1049 (defun imap-current-mailbox (&optional buffer)
1050   (with-current-buffer (or buffer (current-buffer))
1051     (imap-utf7-decode imap-current-mailbox)))
1052
1053 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1054   (and (string= mailbox imap-current-mailbox)
1055        (or (and examine
1056                 (eq imap-state 'examine))
1057            (and (not examine)
1058                 (eq imap-state 'selected)))))
1059
1060 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1061   (with-current-buffer (or buffer (current-buffer))
1062     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1063
1064 (defun imap-mailbox-select-1 (mailbox &optional examine)
1065   "Select MAILBOX on server in BUFFER.
1066 If EXAMINE is non-nil, do a read-only select."
1067   (if (imap-current-mailbox-p-1 mailbox examine)
1068       imap-current-mailbox
1069     (setq imap-current-mailbox mailbox)
1070     (if (imap-ok-p (imap-send-command-wait
1071                     (concat (if examine "EXAMINE" "SELECT") " \""
1072                             mailbox "\"")))
1073         (progn
1074           (setq imap-message-data (make-vector imap-message-prime 0)
1075                 imap-state (if examine 'examine 'selected))
1076           imap-current-mailbox)
1077       ;; Failed SELECT/EXAMINE unselects current mailbox
1078       (setq imap-current-mailbox nil))))
1079
1080 (defun imap-mailbox-select (mailbox &optional examine buffer)
1081   (with-current-buffer (or buffer (current-buffer))
1082     (imap-utf7-decode
1083      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1084
1085 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1086   (with-current-buffer (or buffer (current-buffer))
1087     (imap-mailbox-select-1 mailbox 'exmine)))
1088
1089 (defun imap-mailbox-examine (mailbox &optional buffer)
1090   "Examine MAILBOX on server in BUFFER."
1091   (imap-mailbox-select mailbox 'exmine buffer))
1092
1093 (defun imap-mailbox-unselect (&optional buffer)
1094   "Close current folder in BUFFER, without expunging articles."
1095   (with-current-buffer (or buffer (current-buffer))
1096     (when (or (eq imap-state 'auth)
1097               (and (imap-capability 'UNSELECT)
1098                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1099               (and (imap-ok-p
1100                     (imap-send-command-wait (concat "EXAMINE \""
1101                                                     imap-current-mailbox
1102                                                     "\"")))
1103                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1104       (setq imap-current-mailbox nil
1105             imap-message-data nil
1106             imap-state 'auth)
1107       t)))
1108
1109 (defun imap-mailbox-expunge (&optional buffer)
1110   "Expunge articles in current folder in BUFFER.
1111 If BUFFER is nil the current buffer is assumed."
1112   (with-current-buffer (or buffer (current-buffer))
1113     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1114       (imap-ok-p (imap-send-command-wait "EXPUNGE")))))
1115
1116 (defun imap-mailbox-close (&optional buffer)
1117   "Expunge articles and close current folder in BUFFER.
1118 If BUFFER is nil the current buffer is assumed."
1119   (with-current-buffer (or buffer (current-buffer))
1120     (when (and imap-current-mailbox
1121                (imap-ok-p (imap-send-command-wait "CLOSE")))
1122       (setq imap-current-mailbox nil
1123             imap-message-data nil
1124             imap-state 'auth)
1125       t)))
1126
1127 (defun imap-mailbox-create-1 (mailbox)
1128   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1129
1130 (defun imap-mailbox-create (mailbox &optional buffer)
1131   "Create MAILBOX on server in BUFFER.
1132 If BUFFER is nil the current buffer is assumed."
1133   (with-current-buffer (or buffer (current-buffer))
1134     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1135
1136 (defun imap-mailbox-delete (mailbox &optional buffer)
1137   "Delete MAILBOX on server in BUFFER.
1138 If BUFFER is nil the current buffer is assumed."
1139   (let ((mailbox (imap-utf7-encode mailbox)))
1140     (with-current-buffer (or buffer (current-buffer))
1141       (imap-ok-p
1142        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1143
1144 (defun imap-mailbox-rename (oldname newname &optional buffer)
1145   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1146 If BUFFER is nil the current buffer is assumed."
1147   (let ((oldname (imap-utf7-encode oldname))
1148         (newname (imap-utf7-encode newname)))
1149     (with-current-buffer (or buffer (current-buffer))
1150       (imap-ok-p
1151        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1152                                      "\"" newname "\""))))))
1153
1154 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1155   "Return a list of subscribed mailboxes on server in BUFFER.
1156 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1157 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1158 implementation-specific string that has to be passed to lsub command."
1159   (with-current-buffer (or buffer (current-buffer))
1160     ;; Make sure we know the hierarchy separator for root's hierarchy
1161     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1162       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1163                                       (imap-utf7-encode root) "\"")))
1164     ;; clear list data (NB not delimiter and other stuff)
1165     (imap-mailbox-map-1 (lambda (mailbox)
1166                           (imap-mailbox-put 'lsub nil mailbox)))
1167     (when (imap-ok-p
1168            (imap-send-command-wait
1169             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1170                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1171                     "%\"")))
1172       (let (out)
1173         (imap-mailbox-map-1 (lambda (mailbox)
1174                               (when (imap-mailbox-get-1 'lsub mailbox)
1175                                 (push (imap-utf7-decode mailbox) out))))
1176         (nreverse out)))))
1177
1178 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1179   "Return a list of mailboxes matching ROOT on server in BUFFER.
1180 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1181 root.  REFERENCE is a implementation-specific string that has to be
1182 passed to list command."
1183   (with-current-buffer (or buffer (current-buffer))
1184     ;; Make sure we know the hierarchy separator for root's hierarchy
1185     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1186       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1187                                       (imap-utf7-encode root) "\"")))
1188     ;; clear list data (NB not delimiter and other stuff)
1189     (imap-mailbox-map-1 (lambda (mailbox)
1190                           (imap-mailbox-put 'list nil mailbox)))
1191     (when (imap-ok-p
1192            (imap-send-command-wait
1193             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1194                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1195                     "%\"")))
1196       (let (out)
1197         (imap-mailbox-map-1 (lambda (mailbox)
1198                               (when (imap-mailbox-get-1 'list mailbox)
1199                                 (push (imap-utf7-decode mailbox) out))))
1200         (nreverse out)))))
1201
1202 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1203   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1204 Returns non-nil if successful."
1205   (with-current-buffer (or buffer (current-buffer))
1206     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1207                                                (imap-utf7-encode mailbox)
1208                                                "\"")))))
1209
1210 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1211   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1212 Returns non-nil if successful."
1213   (with-current-buffer (or buffer (current-buffer))
1214     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1215                                                (imap-utf7-encode mailbox)
1216                                                "\"")))))
1217
1218 (defun imap-mailbox-status (mailbox items &optional buffer)
1219   "Get status items ITEM in MAILBOX from server in BUFFER.
1220 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1221 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1222 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1223 returned, if ITEMS is a symbol only it's value is returned."
1224   (with-current-buffer (or buffer (current-buffer))
1225     (when (imap-ok-p
1226            (imap-send-command-wait (list "STATUS \""
1227                                          (imap-utf7-encode mailbox)
1228                                          "\" "
1229                                          (format "%s"
1230                                                  (if (listp items)
1231                                                      items
1232                                                    (list items))))))
1233       (if (listp items)
1234           (mapcar (lambda (item)
1235                     (imap-mailbox-get item mailbox))
1236                   items)
1237         (imap-mailbox-get items mailbox)))))
1238
1239 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1240   "Get ACL on mailbox from server in BUFFER."
1241   (let ((mailbox (imap-utf7-encode mailbox)))
1242     (with-current-buffer (or buffer (current-buffer))
1243       (when (imap-ok-p
1244              (imap-send-command-wait (list "GETACL \""
1245                                            (or mailbox imap-current-mailbox)
1246                                            "\"")))
1247         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1248
1249 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1250   "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1251   (let ((mailbox (imap-utf7-encode mailbox)))
1252     (with-current-buffer (or buffer (current-buffer))
1253       (imap-ok-p
1254        (imap-send-command-wait (list "SETACL \""
1255                                      (or mailbox imap-current-mailbox)
1256                                      "\" "
1257                                      identifier
1258                                      " "
1259                                      rights))))))
1260
1261 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1262   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1263   (let ((mailbox (imap-utf7-encode mailbox)))
1264     (with-current-buffer (or buffer (current-buffer))
1265       (imap-ok-p
1266        (imap-send-command-wait (list "DELETEACL \""
1267                                      (or mailbox imap-current-mailbox)
1268                                      "\" "
1269                                      identifier))))))
1270
1271 \f
1272 ;; Message functions:
1273
1274 (defun imap-current-message (&optional buffer)
1275   (with-current-buffer (or buffer (current-buffer))
1276     imap-current-message))
1277
1278 (defun imap-list-to-message-set (list)
1279   (mapconcat (lambda (item)
1280                (number-to-string item))
1281              (if (listp list)
1282                  list
1283                (list list))
1284              ","))
1285
1286 (defun imap-range-to-message-set (range)
1287   (mapconcat
1288    (lambda (item)
1289      (if (consp item)
1290          (format "%d:%d"
1291                  (car item) (cdr item))
1292        (format "%d" item)))
1293    (if (and (listp range) (not (listp (cdr range))))
1294        (list range) ;; make (1 . 2) into ((1 . 2))
1295      range)
1296    ","))
1297
1298 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1299   (with-current-buffer (or buffer (current-buffer))
1300     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1301                                (if (listp uids)
1302                                    (imap-list-to-message-set uids)
1303                                  uids)
1304                                props))))
1305
1306 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1307   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1308 UIDS can be a string, number or a list of numbers.  If RECEIVE
1309 is non-nil return theese properties."
1310   (with-current-buffer (or buffer (current-buffer))
1311     (when (imap-ok-p (imap-send-command-wait
1312                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1313                               (if (listp uids)
1314                                   (imap-list-to-message-set uids)
1315                                 uids)
1316                               props)))
1317       (if (or (null receive) (stringp uids))
1318           t
1319         (if (listp uids)
1320             (mapcar (lambda (uid)
1321                       (if (listp receive)
1322                           (mapcar (lambda (prop)
1323                                     (imap-message-get uid prop))
1324                                   receive)
1325                         (imap-message-get uid receive)))
1326                     uids)
1327           (imap-message-get uids receive))))))
1328
1329 (defun imap-message-put (uid propname value &optional buffer)
1330   (with-current-buffer (or buffer (current-buffer))
1331     (if imap-message-data
1332         (put (intern (number-to-string uid) imap-message-data)
1333              propname value)
1334       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1335              uid propname value (current-buffer)))
1336     t))
1337
1338 (defun imap-message-get (uid propname &optional buffer)
1339   (with-current-buffer (or buffer (current-buffer))
1340     (get (intern-soft (number-to-string uid) imap-message-data)
1341          propname)))
1342
1343 (defun imap-message-map (func propname &optional buffer)
1344   "Map a function across each mailbox in `imap-message-data', returning a list."
1345   (with-current-buffer (or buffer (current-buffer))
1346     (let (result)
1347       (mapatoms
1348        (lambda (s)
1349          (push (funcall func (get s 'UID) (get s propname)) result))
1350        imap-message-data)
1351       result)))
1352
1353 (defmacro imap-message-envelope-date (uid &optional buffer)
1354   `(with-current-buffer (or ,buffer (current-buffer))
1355      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1356
1357 (defmacro imap-message-envelope-subject (uid &optional buffer)
1358   `(with-current-buffer (or ,buffer (current-buffer))
1359      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1360
1361 (defmacro imap-message-envelope-from (uid &optional buffer)
1362   `(with-current-buffer (or ,buffer (current-buffer))
1363      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1364
1365 (defmacro imap-message-envelope-sender (uid &optional buffer)
1366   `(with-current-buffer (or ,buffer (current-buffer))
1367      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1368
1369 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1370   `(with-current-buffer (or ,buffer (current-buffer))
1371      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1372
1373 (defmacro imap-message-envelope-to (uid &optional buffer)
1374   `(with-current-buffer (or ,buffer (current-buffer))
1375      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1376
1377 (defmacro imap-message-envelope-cc (uid &optional buffer)
1378   `(with-current-buffer (or ,buffer (current-buffer))
1379      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1380
1381 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1382   `(with-current-buffer (or ,buffer (current-buffer))
1383      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1384
1385 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1386   `(with-current-buffer (or ,buffer (current-buffer))
1387      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1388
1389 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1390   `(with-current-buffer (or ,buffer (current-buffer))
1391      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1392
1393 (defmacro imap-message-body (uid &optional buffer)
1394   `(with-current-buffer (or ,buffer (current-buffer))
1395      (imap-message-get ,uid 'BODY)))
1396
1397 (defun imap-search (predicate &optional buffer)
1398   (with-current-buffer (or buffer (current-buffer))
1399     (imap-mailbox-put 'search 'dummy)
1400     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1401       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1402           (error "Missing SEARCH response to a SEARCH command")
1403         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1404
1405 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1406   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1407   (with-current-buffer (or buffer (current-buffer))
1408     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1409         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1410
1411 (defun imap-message-flags-set (articles flags &optional silent buffer)
1412   (when (and articles flags)
1413     (with-current-buffer (or buffer (current-buffer))
1414       (imap-ok-p (imap-send-command-wait
1415                   (concat "UID STORE " articles
1416                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1417
1418 (defun imap-message-flags-del (articles flags &optional silent buffer)
1419   (when (and articles flags)
1420     (with-current-buffer (or buffer (current-buffer))
1421       (imap-ok-p (imap-send-command-wait
1422                   (concat "UID STORE " articles
1423                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1424
1425 (defun imap-message-flags-add (articles flags &optional silent buffer)
1426   (when (and articles flags)
1427     (with-current-buffer (or buffer (current-buffer))
1428       (imap-ok-p (imap-send-command-wait
1429                   (concat "UID STORE " articles
1430                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1431
1432 (defun imap-message-copyuid-1 (mailbox)
1433   (if (imap-capability 'UIDPLUS)
1434       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1435             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1436     (let ((old-mailbox imap-current-mailbox)
1437           (state imap-state)
1438           (imap-message-data (make-vector 2 0)))
1439       (when (imap-mailbox-examine-1 mailbox)
1440         (prog1
1441             (and (imap-fetch "*" "UID")
1442                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1443                        (apply 'max (imap-message-map
1444                                     (lambda (uid prop) uid) 'UID))))
1445           (if old-mailbox
1446               (imap-mailbox-select old-mailbox (eq state 'examine))
1447             (imap-mailbox-unselect)))))))
1448
1449 (defun imap-message-copyuid (mailbox &optional buffer)
1450   (with-current-buffer (or buffer (current-buffer))
1451     (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1452
1453 (defun imap-message-copy (articles mailbox
1454                                    &optional dont-create no-copyuid buffer)
1455   "Copy ARTICLES (a string message set) to MAILBOX on server in
1456 BUFFER, creating mailbox if it doesn't exist.  If dont-create is
1457 non-nil, it will not create a mailbox.  On success, return a list with
1458 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1459 first element, rest of list contain the saved articles' UIDs."
1460   (when articles
1461     (with-current-buffer (or buffer (current-buffer))
1462       (let ((mailbox (imap-utf7-encode mailbox)))
1463         (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1464                   (imap-current-target-mailbox mailbox))
1465               (if (imap-ok-p (imap-send-command-wait cmd))
1466                   t
1467                 (when (and (not dont-create)
1468                            ;; removed because of buggy Oracle server
1469                            ;; that doesn't send TRYCREATE tags (which
1470                            ;; is a MUST according to specifications):
1471                            ;;(imap-mailbox-get-1 'trycreate mailbox)
1472                            (imap-mailbox-create-1 mailbox))
1473                   (imap-ok-p (imap-send-command-wait cmd)))))
1474             (or no-copyuid
1475                 (imap-message-copyuid-1 mailbox)))))))
1476
1477 (defun imap-message-appenduid-1 (mailbox)
1478   (if (imap-capability 'UIDPLUS)
1479       (imap-mailbox-get-1 'appenduid mailbox)
1480     (let ((old-mailbox imap-current-mailbox)
1481           (state imap-state)
1482           (imap-message-data (make-vector 2 0)))
1483       (when (imap-mailbox-examine-1 mailbox)
1484         (prog1
1485             (and (imap-fetch "*" "UID")
1486                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1487                        (apply 'max (imap-message-map
1488                                     (lambda (uid prop) uid) 'UID))))
1489           (if old-mailbox
1490               (imap-mailbox-select old-mailbox (eq state 'examine))
1491             (imap-mailbox-unselect)))))))
1492
1493 (defun imap-message-appenduid (mailbox &optional buffer)
1494   (with-current-buffer (or buffer (current-buffer))
1495     (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1496
1497 (defun imap-message-append (mailbox article &optional flags date-time buffer)
1498   "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1499 FLAGS and DATE-TIME is currently not used.  Return a cons holding
1500 uidvalidity of MAILBOX and UID the newly created article got, or nil
1501 on failure."
1502   (let ((mailbox (imap-utf7-encode mailbox)))
1503     (with-current-buffer (or buffer (current-buffer))
1504       (and (let ((imap-current-target-mailbox mailbox))
1505              (imap-ok-p
1506               (imap-send-command-wait
1507                (list "APPEND \"" mailbox "\" "  article))))
1508            (imap-message-appenduid-1 mailbox)))))
1509
1510 (defun imap-body-lines (body)
1511   "Return number of lines in article by looking at the mime bodystructure BODY."
1512   (if (listp body)
1513       (if (stringp (car body))
1514           (cond ((and (string= (upcase (car body)) "TEXT")
1515                       (numberp (nth 7 body)))
1516                  (nth 7 body))
1517                 ((and (string= (upcase (car body)) "MESSAGE")
1518                       (numberp (nth 9 body)))
1519                  (nth 9 body))
1520                 (t 0))
1521         (apply '+ (mapcar 'imap-body-lines body)))
1522     0))
1523
1524 (defun imap-envelope-from (from)
1525   "Return a from string line."
1526   (and from
1527        (concat (aref from 0)
1528                (if (aref from 0) " <")
1529                (aref from 2)
1530                "@"
1531                (aref from 3)
1532                (if (aref from 0) ">"))))
1533
1534 \f
1535 ;; Internal functions.
1536
1537 (defun imap-send-command-1 (cmdstr)
1538   (setq cmdstr (concat cmdstr imap-client-eol))
1539   (and imap-log
1540        (with-current-buffer (get-buffer-create imap-log)
1541          (buffer-disable-undo)
1542          (goto-char (point-max))
1543          (insert cmdstr)))
1544   (process-send-string imap-process cmdstr))
1545
1546 (defun imap-send-command (command &optional buffer)
1547   (with-current-buffer (or buffer (current-buffer))
1548     (if (not (listp command)) (setq command (list command)))
1549     (let ((tag (setq imap-tag (1+ imap-tag)))
1550           cmd cmdstr)
1551       (setq cmdstr (concat (number-to-string imap-tag) " "))
1552       (while (setq cmd (pop command))
1553         (cond ((stringp cmd)
1554                (setq cmdstr (concat cmdstr cmd)))
1555               ((bufferp cmd)
1556                (let ((eol imap-client-eol)
1557                      (calcfirst imap-calculate-literal-size-first)
1558                      size)
1559                  (with-current-buffer cmd
1560                    (if calcfirst
1561                        (setq size (buffer-size)))
1562                    (when (not (equal eol "\r\n"))
1563                      ;; XXX modifies buffer!
1564                      (goto-char (point-min))
1565                      (while (search-forward "\r\n" nil t)
1566                        (replace-match eol)))
1567                    (if (not calcfirst)
1568                        (setq size (buffer-size))))
1569                  (setq cmdstr
1570                        (concat cmdstr (format "{%d}" size))))
1571                (unwind-protect
1572                    (progn
1573                      (imap-send-command-1 cmdstr)
1574                      (setq cmdstr nil)
1575                      (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1576                          (setq command nil);; abort command if no cont-req
1577                        (let ((process imap-process)
1578                              (stream imap-stream)
1579                              (eol imap-client-eol))
1580                          (with-current-buffer cmd
1581                            (and imap-log
1582                                 (with-current-buffer (get-buffer-create
1583                                                       imap-log)
1584                                   (buffer-disable-undo)
1585                                   (goto-char (point-max))
1586                                   (insert-buffer-substring cmd)))
1587                            (process-send-region process (point-min)
1588                                                 (point-max)))
1589                          (process-send-string process imap-client-eol))))
1590                  (setq imap-continuation nil)))
1591               ((functionp cmd)
1592                (imap-send-command-1 cmdstr)
1593                (setq cmdstr nil)
1594                (unwind-protect
1595                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1596                        (setq command nil);; abort command if no cont-req
1597                      (setq command (cons (funcall cmd imap-continuation)
1598                                          command)))
1599                  (setq imap-continuation nil)))
1600               (t
1601                (error "Unknown command type"))))
1602       (if cmdstr
1603           (imap-send-command-1 cmdstr))
1604       tag)))
1605
1606 (defun imap-wait-for-tag (tag &optional buffer)
1607   (with-current-buffer (or buffer (current-buffer))
1608     (while (and (null imap-continuation)
1609                 (< imap-reached-tag tag))
1610       (or (and (not (memq (process-status imap-process) '(open run)))
1611                (sit-for 1))
1612           (let ((len (/ (point-max) 1024))
1613                 message-log-max)
1614             (unless (< len 10)
1615               (message "imap read: %dk" len))
1616             (accept-process-output imap-process 1))))
1617     (message "")
1618     (or (assq tag imap-failed-tags)
1619         (if imap-continuation
1620             'INCOMPLETE
1621           'OK))))
1622
1623 (defun imap-sentinel (process string)
1624   (delete-process process))
1625
1626 (defun imap-find-next-line ()
1627   "Return point at end of current line, taking into account literals.
1628 Return nil if no complete line has arrived."
1629   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1630                                    imap-server-eol)
1631                            nil t)
1632     (if (match-string 1)
1633         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1634             nil
1635           (goto-char (+ (point) (string-to-number (match-string 1))))
1636           (imap-find-next-line))
1637       (point))))
1638
1639 (defun imap-arrival-filter (proc string)
1640   "IMAP process filter."
1641   (with-current-buffer (process-buffer proc)
1642     (goto-char (point-max))
1643     (insert string)
1644     (and imap-log
1645          (with-current-buffer (get-buffer-create imap-log)
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) t "In imap-parse-address-list")))
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) ?\() t "In imap-parse-flag-list")
2238     (while (and (not (eq (char-after) ?\)))
2239                 (setq start (progn
2240                               (imap-forward)
2241                               ;; next line for Courier IMAP bug.
2242                               (skip-chars-forward " ")
2243                               (point)))
2244                 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
2245       (push (buffer-substring start (point)) flag-list))
2246     (assert (eq (char-after) ?\)) t "In imap-parse-flag-list")
2247     (imap-forward)
2248     (nreverse flag-list)))
2249
2250 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2251 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2252 ;;                     env-in-reply-to SP env-message-id ")"
2253 ;;
2254 ;;   env-bcc         = "(" 1*address ")" / nil
2255 ;;
2256 ;;   env-cc          = "(" 1*address ")" / nil
2257 ;;
2258 ;;   env-date        = nstring
2259 ;;
2260 ;;   env-from        = "(" 1*address ")" / nil
2261 ;;
2262 ;;   env-in-reply-to = nstring
2263 ;;
2264 ;;   env-message-id  = nstring
2265 ;;
2266 ;;   env-reply-to    = "(" 1*address ")" / nil
2267 ;;
2268 ;;   env-sender      = "(" 1*address ")" / nil
2269 ;;
2270 ;;   env-subject     = nstring
2271 ;;
2272 ;;   env-to          = "(" 1*address ")" / nil
2273
2274 (defun imap-parse-envelope ()
2275   (when (eq (char-after) ?\()
2276     (imap-forward)
2277     (vector (prog1 (imap-parse-nstring);; date
2278               (imap-forward))
2279             (prog1 (imap-parse-nstring);; subject
2280               (imap-forward))
2281             (prog1 (imap-parse-address-list);; from
2282               (imap-forward))
2283             (prog1 (imap-parse-address-list);; sender
2284               (imap-forward))
2285             (prog1 (imap-parse-address-list);; reply-to
2286               (imap-forward))
2287             (prog1 (imap-parse-address-list);; to
2288               (imap-forward))
2289             (prog1 (imap-parse-address-list);; cc
2290               (imap-forward))
2291             (prog1 (imap-parse-address-list);; bcc
2292               (imap-forward))
2293             (prog1 (imap-parse-nstring);; in-reply-to
2294               (imap-forward))
2295             (prog1 (imap-parse-nstring);; message-id
2296               (imap-forward)))))
2297
2298 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2299
2300 (defsubst imap-parse-string-list ()
2301   (cond ((eq (char-after) ?\();; body-fld-param
2302          (let (strlist str)
2303            (imap-forward)
2304            (while (setq str (imap-parse-string))
2305              (push str strlist)
2306              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2307              ;; between body-fld-param's sometimes
2308              (or (eq (char-after) ?\")
2309                  (imap-forward)))
2310            (nreverse strlist)))
2311         ((imap-parse-nil)
2312          nil)))
2313
2314 ;;   body-extension  = nstring / number /
2315 ;;                      "(" body-extension *(SP body-extension) ")"
2316 ;;                       ; Future expansion.  Client implementations
2317 ;;                       ; MUST accept body-extension fields.  Server
2318 ;;                       ; implementations MUST NOT generate
2319 ;;                       ; body-extension fields except as defined by
2320 ;;                       ; future standard or standards-track
2321 ;;                       ; revisions of this specification.
2322
2323 (defun imap-parse-body-extension ()
2324   (if (eq (char-after) ?\()
2325       (let (b-e)
2326         (imap-forward)
2327         (push (imap-parse-body-extension) b-e)
2328         (while (eq (char-after) ?\ )
2329           (imap-forward)
2330           (push (imap-parse-body-extension) b-e))
2331         (assert (eq (char-after) ?\)) t "In imap-parse-body-extension")
2332         (imap-forward)
2333         (nreverse b-e))
2334     (or (imap-parse-number)
2335         (imap-parse-nstring))))
2336
2337 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2338 ;;                     *(SP body-extension)]]
2339 ;;                       ; MUST NOT be returned on non-extensible
2340 ;;                       ; "BODY" fetch
2341 ;;
2342 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2343 ;;                     *(SP body-extension)]]
2344 ;;                       ; MUST NOT be returned on non-extensible
2345 ;;                       ; "BODY" fetch
2346
2347 (defsubst imap-parse-body-ext ()
2348   (let (ext)
2349     (when (eq (char-after) ?\ );; body-fld-dsp
2350       (imap-forward)
2351       (let (dsp)
2352         (if (eq (char-after) ?\()
2353             (progn
2354               (imap-forward)
2355               (push (imap-parse-string) dsp)
2356               (imap-forward)
2357               (push (imap-parse-string-list) dsp)
2358               (imap-forward))
2359           (assert (imap-parse-nil) t "In imap-parse-body-ext"))
2360         (push (nreverse dsp) ext))
2361       (when (eq (char-after) ?\ );; body-fld-lang
2362         (imap-forward)
2363         (if (eq (char-after) ?\()
2364             (push (imap-parse-string-list) ext)
2365           (push (imap-parse-nstring) ext))
2366         (while (eq (char-after) ?\ );; body-extension
2367           (imap-forward)
2368           (setq ext (append (imap-parse-body-extension) ext)))))
2369     ext))
2370
2371 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2372 ;;
2373 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2374 ;;                     *(SP body-extension)]]
2375 ;;                       ; MUST NOT be returned on non-extensible
2376 ;;                       ; "BODY" fetch
2377 ;;
2378 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2379 ;;                     *(SP body-extension)]]
2380 ;;                       ; MUST NOT be returned on non-extensible
2381 ;;                       ; "BODY" fetch
2382 ;;
2383 ;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2384 ;;                     body-fld-enc SP body-fld-octets
2385 ;;
2386 ;;   body-fld-desc   = nstring
2387 ;;
2388 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2389 ;;
2390 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2391 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2392 ;;
2393 ;;   body-fld-id     = nstring
2394 ;;
2395 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2396 ;;
2397 ;;   body-fld-lines  = number
2398 ;;
2399 ;;   body-fld-md5    = nstring
2400 ;;
2401 ;;   body-fld-octets = number
2402 ;;
2403 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2404 ;;
2405 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2406 ;;                     [SP body-ext-1part]
2407 ;;
2408 ;;   body-type-basic = media-basic SP body-fields
2409 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2410 ;;
2411 ;;   body-type-msg   = media-message SP body-fields SP envelope
2412 ;;                     SP body SP body-fld-lines
2413 ;;
2414 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2415 ;;
2416 ;;   body-type-mpart = 1*body SP media-subtype
2417 ;;                     [SP body-ext-mpart]
2418 ;;
2419 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2420 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2421 ;;                       ; Defined in [MIME-IMT]
2422 ;;
2423 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2424 ;;                      ; Defined in [MIME-IMT]
2425 ;;
2426 ;;   media-subtype   = string
2427 ;;                       ; Defined in [MIME-IMT]
2428 ;;
2429 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2430 ;;                       ; Defined in [MIME-IMT]
2431
2432 (defun imap-parse-body ()
2433   (let (body)
2434     (when (eq (char-after) ?\()
2435       (imap-forward)
2436       (if (eq (char-after) ?\()
2437           (let (subbody)
2438             (while (and (eq (char-after) ?\()
2439                         (setq subbody (imap-parse-body)))
2440               ;; buggy stalker communigate pro 3.0 insert a SPC between
2441               ;; parts in multiparts
2442               (when (and (eq (char-after) ?\ )
2443                          (eq (char-after (1+ (point))) ?\())
2444                 (imap-forward))
2445               (push subbody body))
2446             (imap-forward)
2447             (push (imap-parse-string) body);; media-subtype
2448             (when (eq (char-after) ?\ );; body-ext-mpart:
2449               (imap-forward)
2450               (if (eq (char-after) ?\();; body-fld-param
2451                   (push (imap-parse-string-list) body)
2452                 (push (and (imap-parse-nil) nil) body))
2453               (setq body
2454                     (append (imap-parse-body-ext) body)));; body-ext-...
2455             (assert (eq (char-after) ?\)) t "In imap-parse-body")
2456             (imap-forward)
2457             (nreverse body))
2458
2459         (push (imap-parse-string) body);; media-type
2460         (imap-forward)
2461         (push (imap-parse-string) body);; media-subtype
2462         (imap-forward)
2463         ;; next line for Sun SIMS bug
2464         (and (eq (char-after) ? ) (imap-forward))
2465         (if (eq (char-after) ?\();; body-fld-param
2466             (push (imap-parse-string-list) body)
2467           (push (and (imap-parse-nil) nil) body))
2468         (imap-forward)
2469         (push (imap-parse-nstring) body);; body-fld-id
2470         (imap-forward)
2471         (push (imap-parse-nstring) body);; body-fld-desc
2472         (imap-forward)
2473         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2474         ;; nstring and return NIL instead of defaulting back to 7BIT
2475         ;; as the standard says.
2476         (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc
2477         (imap-forward)
2478         (push (imap-parse-number) body);; body-fld-octets
2479
2480         ;; ok, we're done parsing the required parts, what comes now is one
2481         ;; of three things:
2482         ;;
2483         ;; envelope       (then we're parsing body-type-msg)
2484         ;; body-fld-lines (then we're parsing body-type-text)
2485         ;; body-ext-1part (then we're parsing body-type-basic)
2486         ;;
2487         ;; the problem is that the two first are in turn optionally followed
2488         ;; by the third.  So we parse the first two here (if there are any)...
2489
2490         (when (eq (char-after) ?\ )
2491           (imap-forward)
2492           (let (lines)
2493             (cond ((eq (char-after) ?\();; body-type-msg:
2494                    (push (imap-parse-envelope) body);; envelope
2495                    (imap-forward)
2496                    (push (imap-parse-body) body);; body
2497                    ;; buggy stalker communigate pro 3.0 doesn't print
2498                    ;; number of lines in message/rfc822 attachment
2499                    (if (eq (char-after) ?\))
2500                        (push 0 body)
2501                      (imap-forward)
2502                      (push (imap-parse-number) body))) ;; body-fld-lines
2503                   ((setq lines (imap-parse-number))    ;; body-type-text:
2504                    (push lines body))                  ;; body-fld-lines
2505                   (t
2506                    (backward-char)))))                 ;; no match...
2507
2508         ;; ...and then parse the third one here...
2509
2510         (when (eq (char-after) ?\ );; body-ext-1part:
2511           (imap-forward)
2512           (push (imap-parse-nstring) body);; body-fld-md5
2513           (setq body (append (imap-parse-body-ext) body)));; body-ext-1part..
2514
2515         (assert (eq (char-after) ?\)) t "In imap-parse-body 2")
2516         (imap-forward)
2517         (nreverse body)))))
2518
2519 (when imap-debug                        ; (untrace-all)
2520   (require 'trace)
2521   (buffer-disable-undo (get-buffer-create imap-debug))
2522   (mapcar (lambda (f) (trace-function-background f imap-debug))
2523           '(
2524             imap-read-passwd
2525             imap-utf7-encode
2526             imap-utf7-decode
2527             imap-error-text
2528             imap-kerberos4s-p
2529             imap-kerberos4-open
2530             imap-ssl-p
2531             imap-ssl-open
2532             imap-network-p
2533             imap-network-open
2534             imap-interactive-login
2535             imap-kerberos4a-p
2536             imap-kerberos4-auth
2537             imap-cram-md5-p
2538             imap-cram-md5-auth
2539             imap-login-p
2540             imap-login-auth
2541             imap-anonymous-p
2542             imap-anonymous-auth
2543             imap-open-1
2544             imap-open
2545             imap-opened
2546             imap-authenticate
2547             imap-close
2548             imap-capability
2549             imap-namespace
2550             imap-send-command-wait
2551             imap-mailbox-put
2552             imap-mailbox-get
2553             imap-mailbox-map-1
2554             imap-mailbox-map
2555             imap-current-mailbox
2556             imap-current-mailbox-p-1
2557             imap-current-mailbox-p
2558             imap-mailbox-select-1
2559             imap-mailbox-select
2560             imap-mailbox-examine-1
2561             imap-mailbox-examine
2562             imap-mailbox-unselect
2563             imap-mailbox-expunge
2564             imap-mailbox-close
2565             imap-mailbox-create-1
2566             imap-mailbox-create
2567             imap-mailbox-delete
2568             imap-mailbox-rename
2569             imap-mailbox-lsub
2570             imap-mailbox-list
2571             imap-mailbox-subscribe
2572             imap-mailbox-unsubscribe
2573             imap-mailbox-status
2574             imap-mailbox-acl-get
2575             imap-mailbox-acl-set
2576             imap-mailbox-acl-delete
2577             imap-current-message
2578             imap-list-to-message-set
2579             imap-fetch-asynch
2580             imap-fetch
2581             imap-message-put
2582             imap-message-get
2583             imap-message-map
2584             imap-search
2585             imap-message-flag-permanent-p
2586             imap-message-flags-set
2587             imap-message-flags-del
2588             imap-message-flags-add
2589             imap-message-copyuid-1
2590             imap-message-copyuid
2591             imap-message-copy
2592             imap-message-appenduid-1
2593             imap-message-appenduid
2594             imap-message-append
2595             imap-body-lines
2596             imap-envelope-from
2597             imap-send-command-1
2598             imap-send-command
2599             imap-wait-for-tag
2600             imap-sentinel
2601             imap-find-next-line
2602             imap-arrival-filter
2603             imap-parse-greeting
2604             imap-parse-response
2605             imap-parse-resp-text
2606             imap-parse-resp-text-code
2607             imap-parse-data-list
2608             imap-parse-fetch
2609             imap-parse-status
2610             imap-parse-acl
2611             imap-parse-flag-list
2612             imap-parse-envelope
2613             imap-parse-body-extension
2614             imap-parse-body
2615             )))
2616
2617 (provide 'imap)
2618
2619 ;;; imap.el ends here