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

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