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

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