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

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