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

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