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