cgit.sxemacs.org Git - gnus/blob - lisp/imap.el

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