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

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