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