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

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