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