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