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