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           (let ((len (/ (point-max) 1024))
1586                 message-log-max)
1587             (unless (< len 10)
1588               (message "imap read: %dk" len))
1589             (accept-process-output imap-process 1))))
1590     (message "")
1591     (or (assq tag imap-failed-tags)
1592         (if imap-continuation
1593             'INCOMPLETE
1594           'OK))))
1595
1596 (defun imap-sentinel (process string)
1597   (delete-process process))
1598
1599 (defun imap-find-next-line ()
1600   "Return point at end of current line, taking into account literals.
1601 Return nil if no complete line has arrived."
1602   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1603                                    imap-server-eol)
1604                            nil t)
1605     (if (match-string 1)
1606         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1607             nil
1608           (goto-char (+ (point) (string-to-number (match-string 1))))
1609           (imap-find-next-line))
1610       (point))))
1611
1612 (defun imap-arrival-filter (proc string)
1613   "IMAP process filter."
1614   (with-current-buffer (process-buffer proc)
1615     (goto-char (point-max))
1616     (insert string)
1617     (and imap-log
1618          (with-current-buffer (get-buffer-create imap-log)
1619            (buffer-disable-undo)
1620            (goto-char (point-max))
1621            (insert string)))
1622     (let (end)
1623       (goto-char (point-min))
1624       (while (setq end (imap-find-next-line))
1625         (save-restriction
1626           (narrow-to-region (point-min) end)
1627           (delete-backward-char (length imap-server-eol))
1628           (goto-char (point-min))
1629           (unwind-protect
1630               (cond ((eq imap-state 'initial)
1631                      (imap-parse-greeting))
1632                     ((or (eq imap-state 'auth)
1633                          (eq imap-state 'nonauth)
1634                          (eq imap-state 'selected)
1635                          (eq imap-state 'examine))
1636                      (imap-parse-response))
1637                     (t
1638                      (message "Unknown state %s in arrival filter"
1639                               imap-state)))
1640             (delete-region (point-min) (point-max))))))))
1641
1642 \f
1643 ;; Imap parser.
1644
1645 (defsubst imap-forward ()
1646   (or (eobp) (forward-char)))
1647
1648 ;;   number          = 1*DIGIT
1649 ;;                       ; Unsigned 32-bit integer
1650 ;;                       ; (0 <= n < 4,294,967,296)
1651
1652 (defsubst imap-parse-number ()
1653   (when (looking-at "[0-9]+")
1654     (prog1
1655         (string-to-number (match-string 0))
1656       (goto-char (match-end 0)))))
1657
1658 ;;   literal         = "{" number "}" CRLF *CHAR8
1659 ;;                       ; Number represents the number of CHAR8s
1660
1661 (defsubst imap-parse-literal ()
1662   (when (looking-at "{\\([0-9]+\\)}\r\n")
1663     (let ((pos (match-end 0))
1664           (len (string-to-number (match-string 1))))
1665       (if (< (point-max) (+ pos len))
1666           nil
1667         (goto-char (+ pos len))
1668         (buffer-substring pos (+ pos len))))))
1669
1670 ;;   string          = quoted / literal
1671 ;;
1672 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
1673 ;;
1674 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
1675 ;;                     "\" quoted-specials
1676 ;;
1677 ;;   quoted-specials = DQUOTE / "\"
1678 ;;
1679 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1680
1681 (defsubst imap-parse-string ()
1682   (cond ((eq (char-after) ?\")
1683          (forward-char 1)
1684          (let ((p (point)) (name ""))
1685            (skip-chars-forward "^\"\\\\")
1686            (setq name (buffer-substring p (point)))
1687            (while (eq (char-after) ?\\)
1688              (setq p (1+ (point)))
1689              (forward-char 2)
1690              (skip-chars-forward "^\"\\\\")
1691              (setq name (concat name (buffer-substring p (point)))))
1692            (forward-char 1)
1693            name))
1694         ((eq (char-after) ?{)
1695          (imap-parse-literal))))
1696
1697 ;;   nil             = "NIL"
1698
1699 (defsubst imap-parse-nil ()
1700   (if (looking-at "NIL")
1701       (goto-char (match-end 0))))
1702
1703 ;;   nstring         = string / nil
1704
1705 (defsubst imap-parse-nstring ()
1706   (or (imap-parse-string)
1707       (and (imap-parse-nil)
1708            nil)))
1709
1710 ;;   astring         = atom / string
1711 ;;
1712 ;;   atom            = 1*ATOM-CHAR
1713 ;;
1714 ;;   ATOM-CHAR       = <any CHAR except atom-specials>
1715 ;;
1716 ;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
1717 ;;                     quoted-specials
1718 ;;
1719 ;;   list-wildcards  = "%" / "*"
1720 ;;
1721 ;;   quoted-specials = DQUOTE / "\"
1722
1723 (defsubst imap-parse-astring ()
1724   (or (imap-parse-string)
1725       (buffer-substring (point)
1726                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1727                             (goto-char (1- (match-end 0)))
1728                           (end-of-line)
1729                           (point)))))
1730
1731 ;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
1732 ;;                      addr-host ")"
1733 ;;
1734 ;;   addr-adl        = nstring
1735 ;;                       ; Holds route from [RFC-822] route-addr if
1736 ;;                       ; non-NIL
1737 ;;
1738 ;;   addr-host       = nstring
1739 ;;                       ; NIL indicates [RFC-822] group syntax.
1740 ;;                       ; Otherwise, holds [RFC-822] domain name
1741 ;;
1742 ;;   addr-mailbox    = nstring
1743 ;;                       ; NIL indicates end of [RFC-822] group; if
1744 ;;                       ; non-NIL and addr-host is NIL, holds
1745 ;;                       ; [RFC-822] group name.
1746 ;;                       ; Otherwise, holds [RFC-822] local-part
1747 ;;                       ; after removing [RFC-822] quoting
1748 ;;
1749 ;;   addr-name       = nstring
1750 ;;                       ; If non-NIL, holds phrase from [RFC-822]
1751 ;;                       ; mailbox after removing [RFC-822] quoting
1752 ;;
1753
1754 (defsubst imap-parse-address ()
1755   (let (address)
1756     (when (eq (char-after) ?\()
1757       (imap-forward)
1758       (setq address (vector (prog1 (imap-parse-nstring)
1759                               (imap-forward))
1760                             (prog1 (imap-parse-nstring)
1761                               (imap-forward))
1762                             (prog1 (imap-parse-nstring)
1763                               (imap-forward))
1764                             (imap-parse-nstring)))
1765       (when (eq (char-after) ?\))
1766         (imap-forward)
1767         address))))
1768
1769 ;;   address-list    = "(" 1*address ")" / nil
1770 ;;
1771 ;;   nil             = "NIL"
1772
1773 (defsubst imap-parse-address-list ()
1774   (if (eq (char-after) ?\()
1775       (let (address addresses)
1776         (imap-forward)
1777         (while (and (not (eq (char-after) ?\)))
1778                     ;; next line for MS Exchange bug
1779                     (progn (and (eq (char-after) ? ) (imap-forward)) t)
1780                     (setq address (imap-parse-address)))
1781           (setq addresses (cons address addresses)))
1782         (when (eq (char-after) ?\))
1783           (imap-forward)
1784           (nreverse addresses)))
1785     (assert (imap-parse-nil))))
1786
1787 ;;   mailbox         = "INBOX" / astring
1788 ;;                       ; INBOX is case-insensitive.  All case variants of
1789 ;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
1790 ;;                       ; not as an astring.  An astring which consists of
1791 ;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
1792 ;;                       ; is considered to be INBOX and not an astring.
1793 ;;                       ;  Refer to section 5.1 for further
1794 ;;                       ; semantic details of mailbox names.
1795
1796 (defsubst imap-parse-mailbox ()
1797   (let ((mailbox (imap-parse-astring)))
1798     (if (string-equal "INBOX" (upcase mailbox))
1799         "INBOX"
1800       mailbox)))
1801
1802 ;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
1803 ;;
1804 ;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
1805 ;;                       ; Authentication condition
1806 ;;
1807 ;;   resp-cond-bye   = "BYE" SP resp-text
1808
1809 (defun imap-parse-greeting ()
1810   "Parse a IMAP greeting."
1811   (cond ((looking-at "\\* OK ")
1812          (setq imap-state 'nonauth))
1813         ((looking-at "\\* PREAUTH ")
1814          (setq imap-state 'auth))
1815         ((looking-at "\\* BYE ")
1816          (setq imap-state 'closed))))
1817
1818 ;;   response        = *(continue-req / response-data) response-done
1819 ;;
1820 ;;   continue-req    = "+" SP (resp-text / base64) CRLF
1821 ;;
1822 ;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
1823 ;;                     mailbox-data / message-data / capability-data) CRLF
1824 ;;
1825 ;;   response-done   = response-tagged / response-fatal
1826 ;;
1827 ;;   response-fatal  = "*" SP resp-cond-bye CRLF
1828 ;;                       ; Server closes connection immediately
1829 ;;
1830 ;;   response-tagged = tag SP resp-cond-state CRLF
1831 ;;
1832 ;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
1833 ;;                       ; Status condition
1834 ;;
1835 ;;   resp-cond-bye   = "BYE" SP resp-text
1836 ;;
1837 ;;   mailbox-data    =  "FLAGS" SP flag-list /
1838 ;;                      "LIST" SP mailbox-list /
1839 ;;                      "LSUB" SP mailbox-list /
1840 ;;                      "SEARCH" *(SP nz-number) /
1841 ;;                      "STATUS" SP mailbox SP "("
1842 ;;                            [status-att SP number *(SP status-att SP number)] ")" /
1843 ;;                      number SP "EXISTS" /
1844 ;;                      number SP "RECENT"
1845 ;;
1846 ;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
1847 ;;
1848 ;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
1849 ;;                     *(SP capability)
1850 ;;                       ; IMAP4rev1 servers which offer RFC 1730
1851 ;;                       ; compatibility MUST list "IMAP4" as the first
1852 ;;                       ; capability.
1853
1854 (defun imap-parse-response ()
1855   "Parse a IMAP command response."
1856   (let (token)
1857     (case (setq token (read (current-buffer)))
1858       (+ (setq imap-continuation
1859                (or (buffer-substring (min (point-max) (1+ (point)))
1860                                      (point-max))
1861                    t)))
1862       (* (case (prog1 (setq token (read (current-buffer)))
1863                  (imap-forward))
1864            (OK         (imap-parse-resp-text))
1865            (NO         (imap-parse-resp-text))
1866            (BAD        (imap-parse-resp-text))
1867            (BYE        (imap-parse-resp-text))
1868            (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
1869            (LIST       (imap-parse-data-list 'list))
1870            (LSUB       (imap-parse-data-list 'lsub))
1871            (SEARCH     (imap-mailbox-put
1872                         'search
1873                         (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
1874            (STATUS     (imap-parse-status))
1875            (CAPABILITY (setq imap-capability
1876                              (read (concat "(" (upcase (buffer-substring
1877                                                         (point) (point-max)))
1878                                            ")"))))
1879            (ACL        (imap-parse-acl))
1880            (t       (case (prog1 (read (current-buffer))
1881                             (imap-forward))
1882                       (EXISTS  (imap-mailbox-put 'exists token))
1883                       (RECENT  (imap-mailbox-put 'recent token))
1884                       (EXPUNGE t)
1885                       (FETCH   (imap-parse-fetch token))
1886                       (t       (message "Garbage: %s" (buffer-string)))))))
1887       (t (let (status)
1888            (if (not (integerp token))
1889                (message "Garbage: %s" (buffer-string))
1890              (case (prog1 (setq status (read (current-buffer)))
1891                      (imap-forward))
1892                (OK  (progn
1893                       (setq imap-reached-tag (max imap-reached-tag token))
1894                       (imap-parse-resp-text)))
1895                (NO  (progn
1896                       (setq imap-reached-tag (max imap-reached-tag token))
1897                       (save-excursion
1898                         (imap-parse-resp-text))
1899                       (let (code text)
1900                         (when (eq (char-after) ?\[)
1901                           (setq code (buffer-substring (point)
1902                                                        (search-forward "]")))
1903                           (imap-forward))
1904                         (setq text (buffer-substring (point) (point-max)))
1905                         (push (list token status code text)
1906                               imap-failed-tags))))
1907                (BAD (progn
1908                       (setq imap-reached-tag (max imap-reached-tag token))
1909                       (save-excursion
1910                         (imap-parse-resp-text))
1911                       (let (code text)
1912                         (when (eq (char-after) ?\[)
1913                           (setq code (buffer-substring (point)
1914                                                        (search-forward "]")))
1915                           (imap-forward))
1916                         (setq text (buffer-substring (point) (point-max)))
1917                         (push (list token status code text) imap-failed-tags)
1918                         (error "Internal error, tag %s status %s code %s text %s"
1919                                token status code text))))
1920                (t   (message "Garbage: %s" (buffer-string))))))))))
1921
1922 ;;   resp-text       = ["[" resp-text-code "]" SP] text
1923 ;;
1924 ;;   text            = 1*TEXT-CHAR
1925 ;;
1926 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1927
1928 (defun imap-parse-resp-text ()
1929   (imap-parse-resp-text-code))
1930
1931 ;;   resp-text-code  = "ALERT" /
1932 ;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
1933 ;;                     "NEWNAME" SP string SP string /
1934 ;;                     "PARSE" /
1935 ;;                     "PERMANENTFLAGS" SP "("
1936 ;;                               [flag-perm *(SP flag-perm)] ")" /
1937 ;;                     "READ-ONLY" /
1938 ;;                     "READ-WRITE" /
1939 ;;                     "TRYCREATE" /
1940 ;;                     "UIDNEXT" SP nz-number /
1941 ;;                     "UIDVALIDITY" SP nz-number /
1942 ;;                     "UNSEEN" SP nz-number /
1943 ;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
1944 ;;
1945 ;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
1946 ;;
1947 ;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
1948 ;;
1949 ;;   set             = sequence-num / (sequence-num ":" sequence-num) /
1950 ;;                        (set "," set)
1951 ;;                          ; Identifies a set of messages.  For message
1952 ;;                          ; sequence numbers, these are consecutive
1953 ;;                          ; numbers from 1 to the number of messages in
1954 ;;                          ; the mailbox
1955 ;;                          ; Comma delimits individual numbers, colon
1956 ;;                          ; delimits between two numbers inclusive.
1957 ;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
1958 ;;                          ; 14,15 for a mailbox with 15 messages.
1959 ;;
1960 ;;   sequence-num    = nz-number / "*"
1961 ;;                          ; * is the largest number in use.  For message
1962 ;;                          ; sequence numbers, it is the number of messages
1963 ;;                          ; in the mailbox.  For unique identifiers, it is
1964 ;;                          ; the unique identifier of the last message in
1965 ;;                          ; the mailbox.
1966 ;;
1967 ;;   flag-perm       = flag / "\*"
1968 ;;
1969 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
1970 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
1971 ;;                       ; Does not include "\Recent"
1972 ;;
1973 ;;   flag-extension  = "\" atom
1974 ;;                       ; Future expansion.  Client implementations
1975 ;;                       ; MUST accept flag-extension flags.  Server
1976 ;;                       ; implementations MUST NOT generate
1977 ;;                       ; flag-extension flags except as defined by
1978 ;;                       ; future standard or standards-track
1979 ;;                       ; revisions of this specification.
1980 ;;
1981 ;;   flag-keyword    = atom
1982 ;;
1983 ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
1984
1985 (defun imap-parse-resp-text-code ()
1986   ;; xxx next line for stalker communigate pro 3.3.1 bug
1987   (when (looking-at " \\[")
1988     (imap-forward))
1989   (when (eq (char-after) ?\[)
1990     (imap-forward)
1991     (cond ((search-forward "PERMANENTFLAGS " nil t)
1992            (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
1993           ((search-forward "UIDNEXT " nil t)
1994            (imap-mailbox-put 'uidnext (read (current-buffer))))
1995           ((search-forward "UNSEEN " nil t)
1996            (imap-mailbox-put 'unseen (read (current-buffer))))
1997           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1998            (imap-mailbox-put 'uidvalidity (match-string 1)))
1999           ((search-forward "READ-ONLY" nil t)
2000            (imap-mailbox-put 'read-only t))
2001           ((search-forward "NEWNAME " nil t)
2002            (let (oldname newname)
2003              (setq oldname (imap-parse-string))
2004              (imap-forward)
2005              (setq newname (imap-parse-string))
2006              (imap-mailbox-put 'newname newname oldname)))
2007           ((search-forward "TRYCREATE" nil t)
2008            (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2009           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2010            (imap-mailbox-put 'appenduid
2011                              (list (match-string 1)
2012                                    (string-to-number (match-string 2)))
2013                              imap-current-target-mailbox))
2014           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2015            (imap-mailbox-put 'copyuid (list (match-string 1)
2016                                             (match-string 2)
2017                                             (match-string 3))
2018                              imap-current-target-mailbox))
2019           ((search-forward "ALERT] " nil t)
2020            (message "Imap server %s information: %s" imap-server
2021                     (buffer-substring (point) (point-max)))))))
2022
2023 ;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
2024 ;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2025 ;;
2026 ;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
2027 ;;                     *(SP mbx-list-oflag) /
2028 ;;                     mbx-list-oflag *(SP mbx-list-oflag)
2029 ;;
2030 ;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
2031 ;;                       ; Other flags; multiple possible per LIST response
2032 ;;
2033 ;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
2034 ;;                       ; Selectability flags; only one per LIST response
2035 ;;
2036 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
2037 ;;                     "\" quoted-specials
2038 ;;
2039 ;;   quoted-specials = DQUOTE / "\"
2040
2041 (defun imap-parse-data-list (type)
2042   (let (flags delimiter mailbox)
2043     (setq flags (imap-parse-flag-list))
2044     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2045       (setq delimiter (match-string 1))
2046       (goto-char (1+ (match-end 0)))
2047       (when (setq mailbox (imap-parse-mailbox))
2048         (imap-mailbox-put type t mailbox)
2049         (imap-mailbox-put 'list-flags flags mailbox)
2050         (imap-mailbox-put 'delimiter delimiter mailbox)))))
2051
2052 ;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
2053 ;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2054 ;;                      "INTERNALDATE" SPACE date_time /
2055 ;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2056 ;;                      "RFC822.SIZE" SPACE number /
2057 ;;                      "BODY" ["STRUCTURE"] SPACE body /
2058 ;;                      "BODY" section ["<" number ">"] SPACE nstring /
2059 ;;                      "UID" SPACE uniqueid) ")"
2060 ;;
2061 ;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
2062 ;;                      SPACE time SPACE zone <">
2063 ;;
2064 ;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
2065 ;;                      ["." (section_text / "MIME")])] "]"
2066 ;;
2067 ;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2068 ;;                      SPACE header_list / "TEXT"
2069 ;;
2070 ;;  header_fld_name ::= astring
2071 ;;
2072 ;;  header_list     ::= "(" 1#header_fld_name ")"
2073
2074 (defsubst imap-parse-header-list ()
2075   (when (eq (char-after) ?\()
2076     (let (strlist)
2077       (while (not (eq (char-after) ?\)))
2078         (imap-forward)
2079         (push (imap-parse-astring) strlist))
2080       (imap-forward)
2081       (nreverse strlist))))
2082
2083 (defsubst imap-parse-fetch-body-section ()
2084   (let ((section
2085          (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2086     (if (eq (char-before) ? )
2087         (prog1
2088             (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2089           (search-forward "]" nil t))
2090       section)))
2091
2092 (defun imap-parse-fetch (response)
2093   (when (eq (char-after) ?\()
2094     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2095               rfc822size body bodydetail bodystructure)
2096       (while (not (eq (char-after) ?\)))
2097         (imap-forward)
2098         (let ((token (read (current-buffer))))
2099           (imap-forward)
2100           (cond ((eq token 'UID)
2101                  (setq uid (ignore-errors (read (current-buffer)))))
2102                 ((eq token 'FLAGS)
2103                  (setq flags (imap-parse-flag-list)))
2104                 ((eq token 'ENVELOPE)
2105                  (setq envelope (imap-parse-envelope)))
2106                 ((eq token 'INTERNALDATE)
2107                  (setq internaldate (imap-parse-string)))
2108                 ((eq token 'RFC822)
2109                  (setq rfc822 (imap-parse-nstring)))
2110                 ((eq token 'RFC822.HEADER)
2111                  (setq rfc822header (imap-parse-nstring)))
2112                 ((eq token 'RFC822.TEXT)
2113                  (setq rfc822text (imap-parse-nstring)))
2114                 ((eq token 'RFC822.SIZE)
2115                  (setq rfc822size (read (current-buffer))))
2116                 ((eq token 'BODY)
2117                  (if (eq (char-before) ?\[)
2118                      (push (list
2119                             (upcase (imap-parse-fetch-body-section))
2120                             (and (eq (char-after) ?<)
2121                                  (buffer-substring (1+ (point))
2122                                                    (search-forward ">" nil t)))
2123                             (progn (imap-forward)
2124                                    (imap-parse-nstring)))
2125                            bodydetail)
2126                    (setq body (imap-parse-body))))
2127                 ((eq token 'BODYSTRUCTURE)
2128                  (setq bodystructure (imap-parse-body))))))
2129       (when uid
2130         (setq imap-current-message uid)
2131         (imap-message-put uid 'UID uid)
2132         (and flags (imap-message-put uid 'FLAGS flags))
2133         (and envelope (imap-message-put uid 'ENVELOPE envelope))
2134         (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2135         (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2136         (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2137         (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2138         (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2139         (and body (imap-message-put uid 'BODY body))
2140         (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2141         (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2142         (run-hooks 'imap-fetch-data-hook)))))
2143
2144 ;;   mailbox-data    =  ...
2145 ;;                      "STATUS" SP mailbox SP "("
2146 ;;                            [status-att SP number
2147 ;;                            *(SP status-att SP number)] ")"
2148 ;;                      ...
2149 ;;
2150 ;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2151 ;;                     "UNSEEN"
2152
2153 (defun imap-parse-status ()
2154   (let ((mailbox (imap-parse-mailbox)))
2155     (when (and mailbox (search-forward "(" nil t))
2156       (while (not (eq (char-after) ?\)))
2157         (let ((token (read (current-buffer))))
2158           (cond ((eq token 'MESSAGES)
2159                  (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2160                 ((eq token 'RECENT)
2161                  (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2162                 ((eq token 'UIDNEXT)
2163                  (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox))
2164                 ((eq token 'UIDVALIDITY)
2165                  (and (looking-at " \\([0-9]+\\)")
2166                       (imap-mailbox-put 'uidvalidity (match-string 1) mailbox)
2167                       (goto-char (match-end 1))))
2168                 ((eq token 'UNSEEN)
2169                  (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2170                 (t
2171                  (message "Unknown status data %s in mailbox %s ignored"
2172                           token mailbox))))))))
2173
2174 ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2175 ;;                        rights)
2176 ;;
2177 ;;   identifier      ::= astring
2178 ;;
2179 ;;   rights          ::= astring
2180
2181 (defun imap-parse-acl ()
2182   (let ((mailbox (imap-parse-mailbox))
2183         identifier rights acl)
2184     (while (eq (char-after) ?\ )
2185       (imap-forward)
2186       (setq identifier (imap-parse-astring))
2187       (imap-forward)
2188       (setq rights (imap-parse-astring))
2189       (setq acl (append acl (list (cons identifier rights)))))
2190     (imap-mailbox-put 'acl acl mailbox)))
2191
2192 ;;   flag-list       = "(" [flag *(SP flag)] ")"
2193 ;;
2194 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2195 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2196 ;;                       ; Does not include "\Recent"
2197 ;;
2198 ;;   flag-keyword    = atom
2199 ;;
2200 ;;   flag-extension  = "\" atom
2201 ;;                       ; Future expansion.  Client implementations
2202 ;;                       ; MUST accept flag-extension flags.  Server
2203 ;;                       ; implementations MUST NOT generate
2204 ;;                       ; flag-extension flags except as defined by
2205 ;;                       ; future standard or standards-track
2206 ;;                       ; revisions of this specification.
2207
2208 (defun imap-parse-flag-list ()
2209   (let (flag-list start)
2210     (assert (eq (char-after) ?\())
2211     (while (and (not (eq (char-after) ?\)))
2212                 (setq start (progn (imap-forward) (point)))
2213                 (> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0))
2214       (push (buffer-substring start (point)) flag-list))
2215     (assert (eq (char-after) ?\)))
2216     (imap-forward)
2217     (nreverse flag-list)))
2218
2219 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2220 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2221 ;;                     env-in-reply-to SP env-message-id ")"
2222 ;;
2223 ;;   env-bcc         = "(" 1*address ")" / nil
2224 ;;
2225 ;;   env-cc          = "(" 1*address ")" / nil
2226 ;;
2227 ;;   env-date        = nstring
2228 ;;
2229 ;;   env-from        = "(" 1*address ")" / nil
2230 ;;
2231 ;;   env-in-reply-to = nstring
2232 ;;
2233 ;;   env-message-id  = nstring
2234 ;;
2235 ;;   env-reply-to    = "(" 1*address ")" / nil
2236 ;;
2237 ;;   env-sender      = "(" 1*address ")" / nil
2238 ;;
2239 ;;   env-subject     = nstring
2240 ;;
2241 ;;   env-to          = "(" 1*address ")" / nil
2242
2243 (defun imap-parse-envelope ()
2244   (when (eq (char-after) ?\()
2245     (imap-forward)
2246     (vector (prog1 (imap-parse-nstring);; date
2247               (imap-forward))
2248             (prog1 (imap-parse-nstring);; subject
2249               (imap-forward))
2250             (prog1 (imap-parse-address-list);; from
2251               (imap-forward))
2252             (prog1 (imap-parse-address-list);; sender
2253               (imap-forward))
2254             (prog1 (imap-parse-address-list);; reply-to
2255               (imap-forward))
2256             (prog1 (imap-parse-address-list);; to
2257               (imap-forward))
2258             (prog1 (imap-parse-address-list);; cc
2259               (imap-forward))
2260             (prog1 (imap-parse-address-list);; bcc
2261               (imap-forward))
2262             (prog1 (imap-parse-nstring);; in-reply-to
2263               (imap-forward))
2264             (prog1 (imap-parse-nstring);; message-id
2265               (imap-forward)))))
2266
2267 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2268
2269 (defsubst imap-parse-string-list ()
2270   (cond ((eq (char-after) ?\();; body-fld-param
2271          (let (strlist str)
2272            (imap-forward)
2273            (while (setq str (imap-parse-string))
2274              (push str strlist)
2275              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2276              ;; between body-fld-param's sometimes
2277              (or (eq (char-after) ?\")
2278                  (imap-forward)))
2279            (nreverse strlist)))
2280         ((imap-parse-nil)
2281          nil)))
2282
2283 ;;   body-extension  = nstring / number /
2284 ;;                      "(" body-extension *(SP body-extension) ")"
2285 ;;                       ; Future expansion.  Client implementations
2286 ;;                       ; MUST accept body-extension fields.  Server
2287 ;;                       ; implementations MUST NOT generate
2288 ;;                       ; body-extension fields except as defined by
2289 ;;                       ; future standard or standards-track
2290 ;;                       ; revisions of this specification.
2291
2292 (defun imap-parse-body-extension ()
2293   (if (eq (char-after) ?\()
2294       (let (b-e)
2295         (imap-forward)
2296         (push (imap-parse-body-extension) b-e)
2297         (while (eq (char-after) ?\ )
2298           (imap-forward)
2299           (push (imap-parse-body-extension) b-e))
2300         (assert (eq (char-after) ?\)))
2301         (imap-forward)
2302         (nreverse b-e))
2303     (or (imap-parse-number)
2304         (imap-parse-nstring))))
2305
2306 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2307 ;;                     *(SP body-extension)]]
2308 ;;                       ; MUST NOT be returned on non-extensible
2309 ;;                       ; "BODY" fetch
2310 ;;
2311 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2312 ;;                     *(SP body-extension)]]
2313 ;;                       ; MUST NOT be returned on non-extensible
2314 ;;                       ; "BODY" fetch
2315
2316 (defsubst imap-parse-body-ext ()
2317   (let (ext)
2318     (when (eq (char-after) ?\ );; body-fld-dsp
2319       (imap-forward)
2320       (let (dsp)
2321         (if (eq (char-after) ?\()
2322             (progn
2323               (imap-forward)
2324               (push (imap-parse-string) dsp)
2325               (imap-forward)
2326               (push (imap-parse-string-list) dsp)
2327               (imap-forward))
2328           (assert (imap-parse-nil)))
2329         (push (nreverse dsp) ext))
2330       (when (eq (char-after) ?\ );; body-fld-lang
2331         (imap-forward)
2332         (if (eq (char-after) ?\()
2333             (push (imap-parse-string-list) ext)
2334           (push (imap-parse-nstring) ext))
2335         (while (eq (char-after) ?\ );; body-extension
2336           (imap-forward)
2337           (setq ext (append (imap-parse-body-extension) ext)))))
2338     ext))
2339
2340 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2341 ;;
2342 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2343 ;;                     *(SP body-extension)]]
2344 ;;                       ; MUST NOT be returned on non-extensible
2345 ;;                       ; "BODY" fetch
2346 ;;
2347 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2348 ;;                     *(SP body-extension)]]
2349 ;;                       ; MUST NOT be returned on non-extensible
2350 ;;                       ; "BODY" fetch
2351 ;;
2352 ;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2353 ;;                     body-fld-enc SP body-fld-octets
2354 ;;
2355 ;;   body-fld-desc   = nstring
2356 ;;
2357 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2358 ;;
2359 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2360 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2361 ;;
2362 ;;   body-fld-id     = nstring
2363 ;;
2364 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2365 ;;
2366 ;;   body-fld-lines  = number
2367 ;;
2368 ;;   body-fld-md5    = nstring
2369 ;;
2370 ;;   body-fld-octets = number
2371 ;;
2372 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2373 ;;
2374 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2375 ;;                     [SP body-ext-1part]
2376 ;;
2377 ;;   body-type-basic = media-basic SP body-fields
2378 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2379 ;;
2380 ;;   body-type-msg   = media-message SP body-fields SP envelope
2381 ;;                     SP body SP body-fld-lines
2382 ;;
2383 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2384 ;;
2385 ;;   body-type-mpart = 1*body SP media-subtype
2386 ;;                     [SP body-ext-mpart]
2387 ;;
2388 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2389 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2390 ;;                       ; Defined in [MIME-IMT]
2391 ;;
2392 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2393 ;;                      ; Defined in [MIME-IMT]
2394 ;;
2395 ;;   media-subtype   = string
2396 ;;                       ; Defined in [MIME-IMT]
2397 ;;
2398 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2399 ;;                       ; Defined in [MIME-IMT]
2400
2401 (defun imap-parse-body ()
2402   (let (body)
2403     (when (eq (char-after) ?\()
2404       (imap-forward)
2405       (if (eq (char-after) ?\()
2406           (let (subbody)
2407             (while (and (eq (char-after) ?\()
2408                         (setq subbody (imap-parse-body)))
2409               ;; buggy stalker communigate pro 3.0 insert a SPC between
2410               ;; parts in multiparts
2411               (when (and (eq (char-after) ?\ )
2412                          (eq (char-after (1+ (point))) ?\())
2413                 (imap-forward))
2414               (push subbody body))
2415             (imap-forward)
2416             (push (imap-parse-string) body);; media-subtype
2417             (when (eq (char-after) ?\ );; body-ext-mpart:
2418               (imap-forward)
2419               (if (eq (char-after) ?\();; body-fld-param
2420                   (push (imap-parse-string-list) body)
2421                 (push (and (imap-parse-nil) nil) body))
2422               (setq body
2423                     (append (imap-parse-body-ext) body)));; body-ext-...
2424             (assert (eq (char-after) ?\)))
2425             (imap-forward)
2426             (nreverse body))
2427
2428         (push (imap-parse-string) body);; media-type
2429         (imap-forward)
2430         (push (imap-parse-string) body);; media-subtype
2431         (imap-forward)
2432         ;; next line for Sun SIMS bug
2433         (and (eq (char-after) ? ) (imap-forward))
2434         (if (eq (char-after) ?\();; body-fld-param
2435             (push (imap-parse-string-list) body)
2436           (push (and (imap-parse-nil) nil) body))
2437         (imap-forward)
2438         (push (imap-parse-nstring) body);; body-fld-id
2439         (imap-forward)
2440         (push (imap-parse-nstring) body);; body-fld-desc
2441         (imap-forward)
2442         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2443         ;; nstring and return NIL instead of defaulting back to 7BIT
2444         ;; as the standard says.
2445         (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc
2446         (imap-forward)
2447         (push (imap-parse-number) body);; body-fld-octets
2448
2449         ;; ok, we're done parsing the required parts, what comes now is one
2450         ;; of three things:
2451         ;;
2452         ;; envelope       (then we're parsing body-type-msg)
2453         ;; body-fld-lines (then we're parsing body-type-text)
2454         ;; body-ext-1part (then we're parsing body-type-basic)
2455         ;;
2456         ;; the problem is that the two first are in turn optionally followed
2457         ;; by the third.  So we parse the first two here (if there are any)...
2458
2459         (when (eq (char-after) ?\ )
2460           (imap-forward)
2461           (let (lines)
2462             (cond ((eq (char-after) ?\();; body-type-msg:
2463                    (push (imap-parse-envelope) body);; envelope
2464                    (imap-forward)
2465                    (push (imap-parse-body) body);; body
2466                    ;; buggy stalker communigate pro 3.0 doesn't print
2467                    ;; number of lines in message/rfc822 attachment
2468                    (if (eq (char-after) ?\))
2469                        (push 0 body)
2470                      (imap-forward)
2471                      (push (imap-parse-number) body))) ;; body-fld-lines
2472                   ((setq lines (imap-parse-number))    ;; body-type-text:
2473                    (push lines body))                  ;; body-fld-lines
2474                   (t
2475                    (backward-char)))))                 ;; no match...
2476
2477         ;; ...and then parse the third one here...
2478
2479         (when (eq (char-after) ?\ );; body-ext-1part:
2480           (imap-forward)
2481           (push (imap-parse-nstring) body);; body-fld-md5
2482           (setq body (append (imap-parse-body-ext) body)));; body-ext-1part..
2483
2484         (assert (eq (char-after) ?\)))
2485         (imap-forward)
2486         (nreverse body)))))
2487
2488 (when imap-debug                        ; (untrace-all)
2489   (require 'trace)
2490   (buffer-disable-undo (get-buffer-create imap-debug))
2491   (mapcar (lambda (f) (trace-function-background f imap-debug))
2492           '(
2493             imap-read-passwd
2494             imap-utf7-encode
2495             imap-utf7-decode
2496             imap-error-text
2497             imap-kerberos4s-p
2498             imap-kerberos4-open
2499             imap-ssl-p
2500             imap-ssl-open
2501             imap-network-p
2502             imap-network-open
2503             imap-interactive-login
2504             imap-kerberos4a-p
2505             imap-kerberos4-auth
2506             imap-cram-md5-p
2507             imap-cram-md5-auth
2508             imap-login-p
2509             imap-login-auth
2510             imap-anonymous-p
2511             imap-anonymous-auth
2512             imap-open-1
2513             imap-open
2514             imap-opened
2515             imap-authenticate
2516             imap-close
2517             imap-capability
2518             imap-namespace
2519             imap-send-command-wait
2520             imap-mailbox-put
2521             imap-mailbox-get
2522             imap-mailbox-map-1
2523             imap-mailbox-map
2524             imap-current-mailbox
2525             imap-current-mailbox-p-1
2526             imap-current-mailbox-p
2527             imap-mailbox-select-1
2528             imap-mailbox-select
2529             imap-mailbox-examine-1
2530             imap-mailbox-examine
2531             imap-mailbox-unselect
2532             imap-mailbox-expunge
2533             imap-mailbox-close
2534             imap-mailbox-create-1
2535             imap-mailbox-create
2536             imap-mailbox-delete
2537             imap-mailbox-rename
2538             imap-mailbox-lsub
2539             imap-mailbox-list
2540             imap-mailbox-subscribe
2541             imap-mailbox-unsubscribe
2542             imap-mailbox-status
2543             imap-mailbox-acl-get
2544             imap-mailbox-acl-set
2545             imap-mailbox-acl-delete
2546             imap-current-message
2547             imap-list-to-message-set
2548             imap-fetch-asynch
2549             imap-fetch
2550             imap-message-put
2551             imap-message-get
2552             imap-message-map
2553             imap-search
2554             imap-message-flag-permanent-p
2555             imap-message-flags-set
2556             imap-message-flags-del
2557             imap-message-flags-add
2558             imap-message-copyuid-1
2559             imap-message-copyuid
2560             imap-message-copy
2561             imap-message-appenduid-1
2562             imap-message-appenduid
2563             imap-message-append
2564             imap-body-lines
2565             imap-envelope-from
2566             imap-send-command-1
2567             imap-send-command
2568             imap-wait-for-tag
2569             imap-sentinel
2570             imap-find-next-line
2571             imap-arrival-filter
2572             imap-parse-greeting
2573             imap-parse-response
2574             imap-parse-resp-text
2575             imap-parse-resp-text-code
2576             imap-parse-data-list
2577             imap-parse-fetch
2578             imap-parse-status
2579             imap-parse-acl
2580             imap-parse-flag-list
2581             imap-parse-envelope
2582             imap-parse-body-extension
2583             imap-parse-body
2584             )))
2585
2586 (provide 'imap)
2587
2588 ;;; imap.el ends here