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