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

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