[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/gnus/imap.el [gnus-5_10-branch]
|
From: |
Andreas Schwab |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/gnus/imap.el [gnus-5_10-branch] |
|
Date: |
Thu, 22 Jul 2004 13:13:47 -0400 |
Index: emacs/lisp/gnus/imap.el
diff -c /dev/null emacs/lisp/gnus/imap.el:1.12.2.1
*** /dev/null Thu Jul 22 16:46:50 2004
--- emacs/lisp/gnus/imap.el Thu Jul 22 16:45:49 2004
***************
*** 0 ****
--- 1,2803 ----
+ ;;; imap.el --- imap library
+ ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+ ;; Free Software Foundation, Inc.
+
+ ;; Author: Simon Josefsson <address@hidden>
+ ;; Keywords: mail
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software; you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation; either version 2, or (at your option)
+ ;; any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs; see the file COPYING. If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, USA.
+
+ ;;; Commentary:
+
+ ;; imap.el is a elisp library providing an interface for talking to
+ ;; IMAP servers.
+ ;;
+ ;; imap.el is roughly divided in two parts, one that parses IMAP
+ ;; responses from the server and storing data into buffer-local
+ ;; variables, and one for utility functions which send commands to
+ ;; server, waits for an answer, and return information. The latter
+ ;; part is layered on top of the previous.
+ ;;
+ ;; The imap.el API consist of the following functions, other functions
+ ;; in this file should not be called directly and the result of doing
+ ;; so are at best undefined.
+ ;;
+ ;; Global commands:
+ ;;
+ ;; imap-open, imap-opened, imap-authenticate, imap-close,
+ ;; imap-capability, imap-namespace, imap-error-text
+ ;;
+ ;; Mailbox commands:
+ ;;
+ ;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
+ ;; imap-current-mailbox-p, imap-search, imap-mailbox-select,
+ ;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge
+ ;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete
+ ;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list
+ ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
+ ;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete
+ ;;
+ ;; Message commands:
+ ;;
+ ;; imap-fetch-asynch, imap-fetch,
+ ;; imap-current-message, imap-list-to-message-set,
+ ;; imap-message-get, imap-message-map
+ ;; imap-message-envelope-date, imap-message-envelope-subject,
+ ;; imap-message-envelope-from, imap-message-envelope-sender,
+ ;; imap-message-envelope-reply-to, imap-message-envelope-to,
+ ;; imap-message-envelope-cc, imap-message-envelope-bcc
+ ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
+ ;; imap-message-body, imap-message-flag-permanent-p
+ ;; imap-message-flags-set, imap-message-flags-del
+ ;; imap-message-flags-add, imap-message-copyuid
+ ;; imap-message-copy, imap-message-appenduid
+ ;; imap-message-append, imap-envelope-from
+ ;; imap-body-lines
+ ;;
+ ;; It is my hope that theese commands should be pretty self
+ ;; explanatory for someone that know IMAP. All functions have
+ ;; additional documentation on how to invoke them.
+ ;;
+ ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
+ ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
+ ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
+ ;; LOGINDISABLED) (with use of external library starttls.el and
+ ;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
+ ;; (with use of external program `imtest'). It also take advantage
+ ;; the UNSELECT extension in Cyrus IMAPD.
+ ;;
+ ;; Without the work of John McClary Prevost and Jim Radford this library
+ ;; would not have seen the light of day. Many thanks.
+ ;;
+ ;; This is a transcript of short interactive session for demonstration
+ ;; purposes.
+ ;;
+ ;; (imap-open "my.mail.server")
+ ;; => " *imap* my.mail.server:0"
+ ;;
+ ;; The rest are invoked with current buffer as the buffer returned by
+ ;; `imap-open'. It is possible to do all without this, but it would
+ ;; look ugly here since `buffer' is always the last argument for all
+ ;; imap.el API functions.
+ ;;
+ ;; (imap-authenticate "myusername" "mypassword")
+ ;; => auth
+ ;;
+ ;; (imap-mailbox-lsub "*")
+ ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
+ ;;
+ ;; (imap-mailbox-list "INBOX.n%")
+ ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
+ ;;
+ ;; (imap-mailbox-select "INBOX.nnimap")
+ ;; => "INBOX.nnimap"
+ ;;
+ ;; (imap-mailbox-get 'exists)
+ ;; => 166
+ ;;
+ ;; (imap-mailbox-get 'uidvalidity)
+ ;; => "908992622"
+ ;;
+ ;; (imap-search "FLAGGED SINCE 18-DEC-98")
+ ;; => (235 236)
+ ;;
+ ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
+ ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <address@hidden>^M\r...."
+ ;;
+ ;; Todo:
+ ;;
+ ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
+ ;; o Don't use `read' at all (important places already fixed)
+ ;; o Accept list of articles instead of message set string in most
+ ;; imap-message-* functions.
+ ;; o Send strings as literal if they contain, e.g., ".
+ ;;
+ ;; Revision history:
+ ;;
+ ;; - 19991218 added starttls/digest-md5 patch,
+ ;; by Daiki Ueno <address@hidden>
+ ;; NB! you need SLIM for starttls.el and digest-md5.el
+ ;; - 19991023 commited to pgnus
+ ;;
+
+ ;;; Code:
+
+ (eval-when-compile (require 'cl))
+ (eval-and-compile
+ (autoload 'base64-decode-string "base64")
+ (autoload 'base64-encode-string "base64")
+ (autoload 'starttls-open-stream "starttls")
+ (autoload 'starttls-negotiate "starttls")
+ (autoload 'digest-md5-parse-digest-challenge "digest-md5")
+ (autoload 'digest-md5-digest-response "digest-md5")
+ (autoload 'digest-md5-digest-uri "digest-md5")
+ (autoload 'digest-md5-challenge "digest-md5")
+ (autoload 'rfc2104-hash "rfc2104")
+ (autoload 'md5 "md5")
+ (autoload 'utf7-encode "utf7")
+ (autoload 'utf7-decode "utf7")
+ (autoload 'format-spec "format-spec")
+ (autoload 'format-spec-make "format-spec")
+ (autoload 'open-tls-stream "tls")
+ ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These
+ ;; days we have point-at-eol anyhow.
+ (if (fboundp 'point-at-eol)
+ (defalias 'imap-point-at-eol 'point-at-eol)
+ (defun imap-point-at-eol ()
+ (save-excursion
+ (end-of-line)
+ (point)))))
+
+ ;; User variables.
+
+ (defgroup imap nil
+ "Low-level IMAP issues."
+ :version "21.1"
+ :group 'mail)
+
+ (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
+ "imtest -kp %s %p")
+ "List of strings containing commands for Kerberos 4 authentication.
+ %s is replaced with server hostname, %p with port to connect to, and
+ %l with the value of `imap-default-user'. The program should accept
+ IMAP commands on stdin and return responses to stdout. Each entry in
+ the list is tried until a successful connection is made."
+ :group 'imap
+ :type '(repeat string))
+
+ (defcustom imap-gssapi-program (list
+ (concat "gsasl --client --connect %s:%p "
+ "--imap --application-data "
+ "--mechanism GSSAPI "
+ "--authentication-id %l")
+ "imtest -m gssapi -u %l -p %p %s")
+ "List of strings containing commands for GSSAPI (krb5) authentication.
+ %s is replaced with server hostname, %p with port to connect to, and
+ %l with the value of `imap-default-user'. The program should accept
+ IMAP commands on stdin and return responses to stdout. Each entry in
+ the list is tried until a successful connection is made."
+ :group 'imap
+ :type '(repeat string))
+
+ (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
+ "openssl s_client -quiet -ssl2 -connect %s:%p"
+ "s_client -quiet -ssl3 -connect %s:%p"
+ "s_client -quiet -ssl2 -connect %s:%p")
+ "A string, or list of strings, containing commands for SSL connections.
+ Within a string, %s is replaced with the server address and %p with
+ port number on server. The program should accept IMAP commands on
+ stdin and return responses to stdout. Each entry in the list is tried
+ until a successful connection is made."
+ :group 'imap
+ :type '(choice string
+ (repeat string)))
+
+ (defcustom imap-shell-program '("ssh %s imapd"
+ "rsh %s imapd"
+ "ssh %g ssh %s imapd"
+ "rsh %g rsh %s imapd")
+ "A list of strings, containing commands for IMAP connection.
+ Within a string, %s is replaced with the server address, %p with port
+ number on server, %g with `imap-shell-host', and %l with
+ `imap-default-user'. The program should read IMAP commands from stdin
+ and write IMAP response to stdout. Each entry in the list is tried
+ until a successful connection is made."
+ :group 'imap
+ :type '(repeat string))
+
+ (defcustom imap-process-connection-type nil
+ "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
+ The `process-connection-type' variable control type of device
+ used to communicate with subprocesses. Values are nil to use a
+ pipe, or t or `pty' to use a pty. The value has no effect if the
+ system has no ptys or if all ptys are busy: then a pipe is used
+ in any case. The value takes effect when a IMAP server is
+ opened, changing it after that has no effect.."
+ :group 'imap
+ :type 'boolean)
+
+ (defcustom imap-use-utf7 t
+ "If non-nil, do utf7 encoding/decoding of mailbox names.
+ Since the UTF7 decoding currently only decodes into ISO-8859-1
+ characters, you may disable this decoding if you need to access UTF7
+ encoded mailboxes which doesn't translate into ISO-8859-1."
+ :group 'imap
+ :type 'boolean)
+
+ (defcustom imap-log nil
+ "If non-nil, a imap session trace is placed in *imap-log* buffer."
+ :group 'imap
+ :type 'boolean)
+
+ (defcustom imap-debug nil
+ "If non-nil, random debug spews are placed in *imap-debug* buffer."
+ :group 'imap
+ :type 'boolean)
+
+ (defcustom imap-shell-host "gateway"
+ "Hostname of rlogin proxy."
+ :group 'imap
+ :type 'string)
+
+ (defcustom imap-default-user (user-login-name)
+ "Default username to use."
+ :group 'imap
+ :type 'string)
+
+ (defcustom imap-read-timeout (if (string-match
+ "windows-nt\\|os/2\\|emx\\|cygwin"
+ (symbol-name system-type))
+ 1.0
+ 0.1)
+ "*How long to wait between checking for the end of output.
+ Shorter values mean quicker response, but is more CPU intensive."
+ :type 'number
+ :group 'imap)
+
+ ;; Various variables.
+
+ (defvar imap-fetch-data-hook nil
+ "Hooks called after receiving each FETCH response.")
+
+ (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
+ "Priority of streams to consider when opening connection to server.")
+
+ (defvar imap-stream-alist
+ '((gssapi imap-gssapi-stream-p imap-gssapi-open)
+ (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
+ (tls imap-tls-p imap-tls-open)
+ (ssl imap-ssl-p imap-ssl-open)
+ (network imap-network-p imap-network-open)
+ (shell imap-shell-p imap-shell-open)
+ (starttls imap-starttls-p imap-starttls-open))
+ "Definition of network streams.
+
+ \(NAME CHECK OPEN)
+
+ NAME names the stream, CHECK is a function returning non-nil if the
+ server support the stream and OPEN is a function for opening the
+ stream.")
+
+ (defvar imap-authenticators '(gssapi
+ kerberos4
+ digest-md5
+ cram-md5
+ login
+ anonymous)
+ "Priority of authenticators to consider when authenticating to server.")
+
+ (defvar imap-authenticator-alist
+ '((gssapi imap-gssapi-auth-p imap-gssapi-auth)
+ (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth)
+ (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
+ (login imap-login-p imap-login-auth)
+ (anonymous imap-anonymous-p imap-anonymous-auth)
+ (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
+ "Definition of authenticators.
+
+ \(NAME CHECK AUTHENTICATE)
+
+ NAME names the authenticator. CHECK is a function returning non-nil if
+ the server support the authenticator and AUTHENTICATE is a function
+ for doing the actual authentication.")
+
+ (defvar imap-error nil
+ "Error codes from the last command.")
+
+ ;; Internal constants. Change theese and die.
+
+ (defconst imap-default-port 143)
+ (defconst imap-default-ssl-port 993)
+ (defconst imap-default-tls-port 993)
+ (defconst imap-default-stream 'network)
+ (defconst imap-coding-system-for-read 'binary)
+ (defconst imap-coding-system-for-write 'binary)
+ (defconst imap-local-variables '(imap-server
+ imap-port
+ imap-client-eol
+ imap-server-eol
+ imap-auth
+ imap-stream
+ imap-username
+ imap-password
+ imap-current-mailbox
+ imap-current-target-mailbox
+ imap-message-data
+ imap-capability
+ imap-namespace
+ imap-state
+ imap-reached-tag
+ imap-failed-tags
+ imap-tag
+ imap-process
+ imap-calculate-literal-size-first
+ imap-mailbox-data))
+ (defconst imap-log-buffer "*imap-log*")
+ (defconst imap-debug-buffer "*imap-debug*")
+
+ ;; Internal variables.
+
+ (defvar imap-stream nil)
+ (defvar imap-auth nil)
+ (defvar imap-server nil)
+ (defvar imap-port nil)
+ (defvar imap-username nil)
+ (defvar imap-password nil)
+ (defvar imap-calculate-literal-size-first nil)
+ (defvar imap-state 'closed
+ "IMAP state.
+ Valid states are `closed', `initial', `nonauth', `auth', `selected'
+ and `examine'.")
+
+ (defvar imap-server-eol "\r\n"
+ "The EOL string sent from the server.")
+
+ (defvar imap-client-eol "\r\n"
+ "The EOL string we send to the server.")
+
+ (defvar imap-current-mailbox nil
+ "Current mailbox name.")
+
+ (defvar imap-current-target-mailbox nil
+ "Current target mailbox for COPY and APPEND commands.")
+
+ (defvar imap-mailbox-data nil
+ "Obarray with mailbox data.")
+
+ (defvar imap-mailbox-prime 997
+ "Length of imap-mailbox-data.")
+
+ (defvar imap-current-message nil
+ "Current message number.")
+
+ (defvar imap-message-data nil
+ "Obarray with message data.")
+
+ (defvar imap-message-prime 997
+ "Length of imap-message-data.")
+
+ (defvar imap-capability nil
+ "Capability for server.")
+
+ (defvar imap-namespace nil
+ "Namespace for current server.")
+
+ (defvar imap-reached-tag 0
+ "Lower limit on command tags that have been parsed.")
+
+ (defvar imap-failed-tags nil
+ "Alist of tags that failed.
+ Each element is a list with four elements; tag (a integer), response
+ state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
+ human readable response text (a string).")
+
+ (defvar imap-tag 0
+ "Command tag number.")
+
+ (defvar imap-process nil
+ "Process.")
+
+ (defvar imap-continuation nil
+ "Non-nil indicates that the server emitted a continuation request.
+ The actual value is really the text on the continuation line.")
+
+ (defvar imap-callbacks nil
+ "List of response tags and callbacks, on the form `(number . function)'.
+ The function should take two arguments, the first the IMAP tag and the
+ second the status (OK, NO, BAD etc) of the command.")
+
+
+ ;; Utility functions:
+
+ (defun imap-remassoc (key alist)
+ "Delete by side effect any elements of LIST whose car is `equal' to KEY.
+ The modified LIST is returned. If the first member
+ of LIST has a car that is `equal' to KEY, there is no way to remove it
+ by side effect; therefore, write `(setq foo (remassoc key foo))' to be
+ sure of changing the value of `foo'."
+ (when alist
+ (if (equal key (caar alist))
+ (cdr alist)
+ (setcdr alist (imap-remassoc key (cdr alist)))
+ alist)))
+
+ (defsubst imap-disable-multibyte ()
+ "Enable multibyte in the current buffer."
+ (when (fboundp 'set-buffer-multibyte)
+ (set-buffer-multibyte nil)))
+
+ (defsubst imap-utf7-encode (string)
+ (if imap-use-utf7
+ (and string
+ (condition-case ()
+ (utf7-encode string t)
+ (error (message
+ "imap: Could not UTF7 encode `%s', using it unencoded..."
+ string)
+ string)))
+ string))
+
+ (defsubst imap-utf7-decode (string)
+ (if imap-use-utf7
+ (and string
+ (condition-case ()
+ (utf7-decode string t)
+ (error (message
+ "imap: Could not UTF7 decode `%s', using it undecoded..."
+ string)
+ string)))
+ string))
+
+ (defsubst imap-ok-p (status)
+ (if (eq status 'OK)
+ t
+ (setq imap-error status)
+ nil))
+
+ (defun imap-error-text (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (nth 3 (car imap-failed-tags))))
+
+
+ ;; Server functions; stream stuff:
+
+ (defun imap-kerberos4-stream-p (buffer)
+ (imap-capability 'AUTH=KERBEROS_V4 buffer))
+
+ (defun imap-kerberos4-open (name buffer server port)
+ (let ((cmds imap-kerberos4-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
+ (erase-buffer)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process-connection-type imap-process-connection-type)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n"
+ imap-calculate-literal-size-first t)
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ ;; Athena IMTEST can output SSL verify errors
+ (or (while (looking-at "^verify error:num=")
+ (forward-line))
+ t)
+ (or (while (looking-at "^TLS connection established")
+ (forward-line))
+ t)
+ ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+ (or (while (looking-at "^C:")
+ (forward-line))
+ t)
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest < 1.6:
+ (or (re-search-forward
+ "^__\\(.*\\)__\n" nil t)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ "^\\(Authenticat.*\\)" nil t))
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
+ (if response (concat "done, " response) "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+
+ (defun imap-gssapi-stream-p (buffer)
+ (imap-capability 'AUTH=GSSAPI buffer))
+
+ (defun imap-gssapi-open (name buffer server port)
+ (let ((cmds imap-gssapi-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
+ (erase-buffer)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process-connection-type imap-process-connection-type)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n"
+ imap-calculate-literal-size-first t)
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+ (or (while (looking-at "^C:")
+ (forward-line))
+ t)
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ (concat "^\\(\\(Authenticat.*\\)\\|\\("
+ "Client authentication "
+ "finished.*\\)\\)")
+ nil t)
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "GSSAPI IMAP connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+
+ (defun imap-ssl-p (buffer)
+ nil)
+
+ (defun imap-ssl-open (name buffer server port)
+ "Open a SSL connection to server."
+ (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
+ (list imap-ssl-program)))
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "imap: Opening SSL connection with `%s'..." cmd)
+ (erase-buffer)
+ (let* ((port (or port imap-default-ssl-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process-connection-type nil)
+ process)
+ (when (progn
+ (setq process (start-process
+ name buffer shell-file-name
+ shell-command-switch
+ (format-spec cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)))))
+ (process-kill-without-query process)
+ process)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (when (memq (process-status process) '(open run))
+ (setq done process))))))
+ (if done
+ (progn
+ (message "imap: Opening SSL connection with `%s'...done" cmd)
+ done)
+ (message "imap: Opening SSL connection with `%s'...failed" cmd)
+ nil)))
+
+ (defun imap-tls-p (buffer)
+ nil)
+
+ (defun imap-tls-open (name buffer server port)
+ (let* ((port (or port imap-default-tls-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (open-tls-stream name buffer server port)))
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (when (memq (process-status process) '(open run))
+ process))))
+
+ (defun imap-network-p (buffer)
+ t)
+
+ (defun imap-network-open (name buffer server port)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (open-network-stream name buffer server port)))
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (when (memq (process-status process) '(open run))
+ process))))
+
+ (defun imap-shell-p (buffer)
+ nil)
+
+ (defun imap-shell-open (name buffer server port)
+ (let ((cmds (if (listp imap-shell-program) imap-shell-program
+ (list imap-shell-program)))
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "imap: Opening IMAP connection with `%s'..." cmd)
+ (setq imap-client-eol "\n")
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?g imap-shell-host
+ ?p (number-to-string port)
+ ?l imap-default-user)))))
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (when (memq (process-status process) '(open run))
+ (setq done process)))))
+ (if done
+ (progn
+ (message "imap: Opening IMAP connection with `%s'...done" cmd)
+ done)
+ (message "imap: Opening IMAP connection with `%s'...failed" cmd)
+ nil)))
+
+ (defun imap-starttls-p (buffer)
+ (imap-capability 'STARTTLS buffer))
+
+ (defun imap-starttls-open (name buffer server port)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (starttls-open-stream name buffer server port))
+ done tls-info)
+ (message "imap: Connecting with STARTTLS...")
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (imap-send-command "STARTTLS")
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (when (and (setq tls-info (starttls-negotiate process))
+ (memq (process-status process) '(open run)))
+ (setq done process)))
+ (if (stringp tls-info)
+ (message "imap: STARTTLS info: %s" tls-info))
+ (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
+ done))
+
+ ;; Server functions; authenticator stuff:
+
+ (defun imap-interactive-login (buffer loginfunc)
+ "Login to server in BUFFER.
+ LOGINFUNC is passed a username and a password, it should return t if
+ it where successful authenticating itself to the server, nil otherwise.
+ Returns t if login was successful, nil otherwise."
+ (with-current-buffer buffer
+ (make-local-variable 'imap-username)
+ (make-local-variable 'imap-password)
+ (let (user passwd ret)
+ ;; (condition-case ()
+ (while (or (not user) (not passwd))
+ (setq user (or imap-username
+ (read-from-minibuffer
+ (concat "IMAP username for " imap-server
+ " (using stream `" (symbol-name imap-stream)
+ "'): ")
+ (or user imap-default-user))))
+ (setq passwd (or imap-password
+ (read-passwd
+ (concat "IMAP password for " user "@"
+ imap-server " (using authenticator `"
+ (symbol-name imap-auth) "'): "))))
+ (when (and user passwd)
+ (if (funcall loginfunc user passwd)
+ (progn
+ (setq ret t
+ imap-username user)
+ (if (and (not imap-password)
+ (y-or-n-p "Store password for this session? "))
+ (setq imap-password passwd)))
+ (message "Login failed...")
+ (setq passwd nil)
+ (setq imap-password nil)
+ (sit-for 1))))
+ ;; (quit (with-current-buffer buffer
+ ;; (setq user nil
+ ;; passwd nil)))
+ ;; (error (with-current-buffer buffer
+ ;; (setq user nil
+ ;; passwd nil))))
+ ret)))
+
+ (defun imap-gssapi-auth-p (buffer)
+ (eq imap-stream 'gssapi))
+
+ (defun imap-gssapi-auth (buffer)
+ (message "imap: Authenticating using GSSAPI...%s"
+ (if (eq imap-stream 'gssapi) "done" "failed"))
+ (eq imap-stream 'gssapi))
+
+ (defun imap-kerberos4-auth-p (buffer)
+ (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
+ (eq imap-stream 'kerberos4)))
+
+ (defun imap-kerberos4-auth (buffer)
+ (message "imap: Authenticating using Kerberos 4...%s"
+ (if (eq imap-stream 'kerberos4) "done" "failed"))
+ (eq imap-stream 'kerberos4))
+
+ (defun imap-cram-md5-p (buffer)
+ (imap-capability 'AUTH=CRAM-MD5 buffer))
+
+ (defun imap-cram-md5-auth (buffer)
+ "Login to server using the AUTH CRAM-MD5 method."
+ (message "imap: Authenticating using CRAM-MD5...")
+ (let ((done (imap-interactive-login
+ buffer
+ (lambda (user passwd)
+ (imap-ok-p
+ (imap-send-command-wait
+ (list
+ "AUTHENTICATE CRAM-MD5"
+ (lambda (challenge)
+ (let* ((decoded (base64-decode-string challenge))
+ (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+ (response (concat user " " hash))
+ (encoded (base64-encode-string response)))
+ encoded)))))))))
+ (if done
+ (message "imap: Authenticating using CRAM-MD5...done")
+ (message "imap: Authenticating using CRAM-MD5...failed"))))
+
+ (defun imap-login-p (buffer)
+ (and (not (imap-capability 'LOGINDISABLED buffer))
+ (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
+
+ (defun imap-login-auth (buffer)
+ "Login to server using the LOGIN command."
+ (message "imap: Plaintext authentication...")
+ (imap-interactive-login buffer
+ (lambda (user passwd)
+ (imap-ok-p (imap-send-command-wait
+ (concat "LOGIN \"" user "\" \""
+ passwd "\""))))))
+
+ (defun imap-anonymous-p (buffer)
+ t)
+
+ (defun imap-anonymous-auth (buffer)
+ (message "imap: Logging in anonymously...")
+ (with-current-buffer buffer
+ (imap-ok-p (imap-send-command-wait
+ (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
+ (system-name)) "\"")))))
+
+ (defun imap-digest-md5-p (buffer)
+ (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
+ (condition-case ()
+ (require 'digest-md5)
+ (error nil))))
+
+ (defun imap-digest-md5-auth (buffer)
+ "Login to server using the AUTH DIGEST-MD5 method."
+ (message "imap: Authenticating using DIGEST-MD5...")
+ (imap-interactive-login
+ buffer
+ (lambda (user passwd)
+ (let ((tag
+ (imap-send-command
+ (list
+ "AUTHENTICATE DIGEST-MD5"
+ (lambda (challenge)
+ (digest-md5-parse-digest-challenge
+ (base64-decode-string challenge))
+ (let* ((digest-uri
+ (digest-md5-digest-uri
+ "imap" (digest-md5-challenge 'realm)))
+ (response
+ (digest-md5-digest-response
+ user passwd digest-uri)))
+ (base64-encode-string response 'no-line-break))))
+ )))
+ (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+ nil
+ (setq imap-continuation nil)
+ (imap-send-command-1 "")
+ (imap-ok-p (imap-wait-for-tag tag)))))))
+
+ ;; Server functions:
+
+ (defun imap-open-1 (buffer)
+ (with-current-buffer buffer
+ (erase-buffer)
+ (setq imap-current-mailbox nil
+ imap-current-message nil
+ imap-state 'initial
+ imap-process (condition-case ()
+ (funcall (nth 2 (assq imap-stream
+ imap-stream-alist))
+ "imap" buffer imap-server imap-port)
+ ((error quit) nil)))
+ (when imap-process
+ (set-process-filter imap-process 'imap-arrival-filter)
+ (set-process-sentinel imap-process 'imap-sentinel)
+ (while (and (eq imap-state 'initial)
+ (memq (process-status imap-process) '(open run)))
+ (message "Waiting for response from %s..." imap-server)
+ (accept-process-output imap-process 1))
+ (message "Waiting for response from %s...done" imap-server)
+ (and (memq (process-status imap-process) '(open run))
+ imap-process))))
+
+ (defun imap-open (server &optional port stream auth buffer)
+ "Open a IMAP connection to host SERVER at PORT returning a buffer.
+ If PORT is unspecified, a default value is used (143 except
+ for SSL which use 993).
+ STREAM indicates the stream to use, see `imap-streams' for available
+ streams. If nil, it choices the best stream the server is capable of.
+ AUTH indicates authenticator to use, see `imap-authenticators' for
+ available authenticators. If nil, it choices the best stream the
+ server is capable of.
+ BUFFER can be a buffer or a name of a buffer, which is created if
+ necessary. If nil, the buffer name is generated."
+ (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
+ (with-current-buffer (get-buffer-create buffer)
+ (if (imap-opened buffer)
+ (imap-close buffer))
+ (mapcar 'make-local-variable imap-local-variables)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (setq imap-server (or server imap-server))
+ (setq imap-port (or port imap-port))
+ (setq imap-auth (or auth imap-auth))
+ (setq imap-stream (or stream imap-stream))
+ (message "imap: Connecting to %s..." imap-server)
+ (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
+ (imap-open-1 buffer)))
+ (progn
+ (message "imap: Connecting to %s...failed" imap-server)
+ nil)
+ (when (null imap-stream)
+ ;; Need to choose stream.
+ (let ((streams imap-streams))
+ (while (setq stream (pop streams))
+ ;; OK to use this stream?
+ (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
+ ;; Stream changed?
+ (if (not (eq imap-default-stream stream))
+ (with-current-buffer (get-buffer-create
+ (generate-new-buffer-name " *temp*"))
+ (mapcar 'make-local-variable imap-local-variables)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (setq imap-server (or server imap-server))
+ (setq imap-port (or port imap-port))
+ (setq imap-auth (or auth imap-auth))
+ (message "imap: Reconnecting with stream `%s'..." stream)
+ (if (null (let ((imap-stream stream))
+ (imap-open-1 (current-buffer))))
+ (progn
+ (kill-buffer (current-buffer))
+ (message
+ "imap: Reconnecting with stream `%s'...failed"
+ stream))
+ ;; We're done, kill the first connection
+ (imap-close buffer)
+ (kill-buffer buffer)
+ (rename-buffer buffer)
+ (message "imap: Reconnecting with stream `%s'...done"
+ stream)
+ (setq imap-stream stream)
+ (setq imap-capability nil)
+ (setq streams nil)))
+ ;; We're done
+ (message "imap: Connecting to %s...done" imap-server)
+ (setq imap-stream stream)
+ (setq imap-capability nil)
+ (setq streams nil))))))
+ (when (imap-opened buffer)
+ (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+ (when imap-stream
+ buffer))))
+
+ (defun imap-opened (&optional buffer)
+ "Return non-nil if connection to imap server in BUFFER is open.
+ If BUFFER is nil then the current buffer is used."
+ (and (setq buffer (get-buffer (or buffer (current-buffer))))
+ (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (and imap-process
+ (memq (process-status imap-process) '(open run))))))
+
+ (defun imap-authenticate (&optional user passwd buffer)
+ "Authenticate to server in BUFFER, using current buffer if nil.
+ It uses the authenticator specified when opening the server. If the
+ authenticator requires username/passwords, they are queried from the
+ user and optionally stored in the buffer. If USER and/or PASSWD is
+ specified, the user will not be questioned and the username and/or
+ password is remembered in the buffer."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (not (eq imap-state 'nonauth))
+ (or (eq imap-state 'auth)
+ (eq imap-state 'select)
+ (eq imap-state 'examine))
+ (make-local-variable 'imap-username)
+ (make-local-variable 'imap-password)
+ (if user (setq imap-username user))
+ (if passwd (setq imap-password passwd))
+ (if imap-auth
+ (and (funcall (nth 2 (assq imap-auth
+ imap-authenticator-alist)) buffer)
+ (setq imap-state 'auth))
+ ;; Choose authenticator.
+ (let ((auths imap-authenticators)
+ auth)
+ (while (setq auth (pop auths))
+ ;; OK to use authenticator?
+ (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
+ (message "imap: Authenticating to `%s' using `%s'..."
+ imap-server auth)
+ (setq imap-auth auth)
+ (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
+ (progn
+ (message "imap: Authenticating to `%s' using `%s'...done"
+ imap-server auth)
+ (setq auths nil))
+ (message "imap: Authenticating to `%s' using `%s'...failed"
+ imap-server auth)))))
+ imap-state))))
+
+ (defun imap-close (&optional buffer)
+ "Close connection to server in BUFFER.
+ If BUFFER is nil, the current buffer is used."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-opened)
+ (condition-case nil
+ (imap-send-command-wait "LOGOUT")
+ (quit nil)))
+ (when (and imap-process
+ (memq (process-status imap-process) '(open run)))
+ (delete-process imap-process))
+ (setq imap-current-mailbox nil
+ imap-current-message nil
+ imap-process nil)
+ (erase-buffer)
+ t))
+
+ (defun imap-capability (&optional identifier buffer)
+ "Return a list of identifiers which server in BUFFER support.
+ If IDENTIFIER, return non-nil if it's among the servers capabilities.
+ If BUFFER is nil, the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (unless imap-capability
+ (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
+ (setq imap-capability '(IMAP2))))
+ (if identifier
+ (memq (intern (upcase (symbol-name identifier))) imap-capability)
+ imap-capability)))
+
+ (defun imap-namespace (&optional buffer)
+ "Return a namespace hierarchy at server in BUFFER.
+ If BUFFER is nil, the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (unless imap-namespace
+ (when (imap-capability 'NAMESPACE)
+ (imap-send-command-wait "NAMESPACE")))
+ imap-namespace))
+
+ (defun imap-send-command-wait (command &optional buffer)
+ (imap-wait-for-tag (imap-send-command command buffer) buffer))
+
+
+ ;; Mailbox functions:
+
+ (defun imap-mailbox-put (propname value &optional mailbox buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if imap-mailbox-data
+ (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
+ propname value)
+ (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
+ propname value mailbox (current-buffer)))
+ t))
+
+ (defsubst imap-mailbox-get-1 (propname &optional mailbox)
+ (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
+ propname))
+
+ (defun imap-mailbox-get (propname &optional mailbox buffer)
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
+
+ (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (if mailbox-decoder
+ (funcall mailbox-decoder (symbol-name s))
+ (symbol-name s))) result))
+ imap-mailbox-data)
+ result)))
+
+ (defun imap-mailbox-map (func &optional buffer)
+ "Map a function across each mailbox in `imap-mailbox-data', returning a
list.
+ Function should take a mailbox name (a string) as
+ the only argument."
+ (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
+
+ (defun imap-current-mailbox (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-utf7-decode imap-current-mailbox)))
+
+ (defun imap-current-mailbox-p-1 (mailbox &optional examine)
+ (and (string= mailbox imap-current-mailbox)
+ (or (and examine
+ (eq imap-state 'examine))
+ (and (not examine)
+ (eq imap-state 'selected)))))
+
+ (defun imap-current-mailbox-p (mailbox &optional examine buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
+
+ (defun imap-mailbox-select-1 (mailbox &optional examine)
+ "Select MAILBOX on server in BUFFER.
+ If EXAMINE is non-nil, do a read-only select."
+ (if (imap-current-mailbox-p-1 mailbox examine)
+ imap-current-mailbox
+ (setq imap-current-mailbox mailbox)
+ (if (imap-ok-p (imap-send-command-wait
+ (concat (if examine "EXAMINE" "SELECT") " \""
+ mailbox "\"")))
+ (progn
+ (setq imap-message-data (make-vector imap-message-prime 0)
+ imap-state (if examine 'examine 'selected))
+ imap-current-mailbox)
+ ;; Failed SELECT/EXAMINE unselects current mailbox
+ (setq imap-current-mailbox nil))))
+
+ (defun imap-mailbox-select (mailbox &optional examine buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-utf7-decode
+ (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
+
+ (defun imap-mailbox-examine-1 (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-select-1 mailbox 'examine)))
+
+ (defun imap-mailbox-examine (mailbox &optional buffer)
+ "Examine MAILBOX on server in BUFFER."
+ (imap-mailbox-select mailbox 'examine buffer))
+
+ (defun imap-mailbox-unselect (&optional buffer)
+ "Close current folder in BUFFER, without expunging articles."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (or (eq imap-state 'auth)
+ (and (imap-capability 'UNSELECT)
+ (imap-ok-p (imap-send-command-wait "UNSELECT")))
+ (and (imap-ok-p
+ (imap-send-command-wait (concat "EXAMINE \""
+ imap-current-mailbox
+ "\"")))
+ (imap-ok-p (imap-send-command-wait "CLOSE"))))
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth)
+ t)))
+
+ (defun imap-mailbox-expunge (&optional asynch buffer)
+ "Expunge articles in current folder in BUFFER.
+ If ASYNCH, do not wait for succesful completion of the command.
+ If BUFFER is nil the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (and imap-current-mailbox (not (eq imap-state 'examine)))
+ (if asynch
+ (imap-send-command "EXPUNGE")
+ (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
+
+ (defun imap-mailbox-close (&optional asynch buffer)
+ "Expunge articles and close current folder in BUFFER.
+ If ASYNCH, do not wait for succesful completion of the command.
+ If BUFFER is nil the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (when imap-current-mailbox
+ (if asynch
+ (imap-add-callback (imap-send-command "CLOSE")
+ `(lambda (tag status)
+ (message "IMAP mailbox `%s' closed... %s"
+ imap-current-mailbox status)
+ (when (eq ,imap-current-mailbox
+ imap-current-mailbox)
+ ;; Don't wipe out data if another mailbox
+ ;; was selected...
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth))))
+ (when (imap-ok-p (imap-send-command-wait "CLOSE"))
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth)))
+ t)))
+
+ (defun imap-mailbox-create-1 (mailbox)
+ (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
+
+ (defun imap-mailbox-create (mailbox &optional buffer)
+ "Create MAILBOX on server in BUFFER.
+ If BUFFER is nil the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
+
+ (defun imap-mailbox-delete (mailbox &optional buffer)
+ "Delete MAILBOX on server in BUFFER.
+ If BUFFER is nil the current buffer is assumed."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
+
+ (defun imap-mailbox-rename (oldname newname &optional buffer)
+ "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
+ If BUFFER is nil the current buffer is assumed."
+ (let ((oldname (imap-utf7-encode oldname))
+ (newname (imap-utf7-encode newname)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "RENAME \"" oldname "\" "
+ "\"" newname "\""))))))
+
+ (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
+ "Return a list of subscribed mailboxes on server in BUFFER.
+ If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
+ non-nil, a hierarchy delimiter is added to root. REFERENCE is a
+ implementation-specific string that has to be passed to lsub command."
+ (with-current-buffer (or buffer (current-buffer))
+ ;; Make sure we know the hierarchy separator for root's hierarchy
+ (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+ (imap-send-command-wait (concat "LIST \"" reference "\" \""
+ (imap-utf7-encode root) "\"")))
+ ;; clear list data (NB not delimiter and other stuff)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (imap-mailbox-put 'lsub nil mailbox)))
+ (when (imap-ok-p
+ (imap-send-command-wait
+ (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
+ (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+ "%\"")))
+ (let (out)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (when (imap-mailbox-get-1 'lsub mailbox)
+ (push (imap-utf7-decode mailbox) out))))
+ (nreverse out)))))
+
+ (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
+ "Return a list of mailboxes matching ROOT on server in BUFFER.
+ If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
+ root. REFERENCE is a implementation-specific string that has to be
+ passed to list command."
+ (with-current-buffer (or buffer (current-buffer))
+ ;; Make sure we know the hierarchy separator for root's hierarchy
+ (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+ (imap-send-command-wait (concat "LIST \"" reference "\" \""
+ (imap-utf7-encode root) "\"")))
+ ;; clear list data (NB not delimiter and other stuff)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (imap-mailbox-put 'list nil mailbox)))
+ (when (imap-ok-p
+ (imap-send-command-wait
+ (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
+ (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+ "%\"")))
+ (let (out)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (when (imap-mailbox-get-1 'list mailbox)
+ (push (imap-utf7-decode mailbox) out))))
+ (nreverse out)))))
+
+ (defun imap-mailbox-subscribe (mailbox &optional buffer)
+ "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
+ Returns non-nil if successful."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
+ (imap-utf7-encode mailbox)
+ "\"")))))
+
+ (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
+ "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
+ Returns non-nil if successful."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
+ (imap-utf7-encode mailbox)
+ "\"")))))
+
+ (defun imap-mailbox-status (mailbox items &optional buffer)
+ "Get status items ITEM in MAILBOX from server in BUFFER.
+ ITEMS can be a symbol or a list of symbols, valid symbols are one of
+ the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
+ or 'unseen. If ITEMS is a list of symbols, a list of values is
+ returned, if ITEMS is a symbol only its value is returned."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p
+ (imap-send-command-wait (list "STATUS \""
+ (imap-utf7-encode mailbox)
+ "\" "
+ (upcase
+ (format "%s"
+ (if (listp items)
+ items
+ (list items)))))))
+ (if (listp items)
+ (mapcar (lambda (item)
+ (imap-mailbox-get item mailbox))
+ items)
+ (imap-mailbox-get items mailbox)))))
+
+ (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
+ "Send status item request ITEM on MAILBOX to server in BUFFER.
+ ITEMS can be a symbol or a list of symbols, valid symbols are one of
+ the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
+ or 'unseen. The IMAP command tag is returned."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-send-command (list "STATUS \""
+ (imap-utf7-encode mailbox)
+ "\" "
+ (format "%s"
+ (if (listp items)
+ items
+ (list items)))))))
+
+ (defun imap-mailbox-acl-get (&optional mailbox buffer)
+ "Get ACL on mailbox from server in BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p
+ (imap-send-command-wait (list "GETACL \""
+ (or mailbox imap-current-mailbox)
+ "\"")))
+ (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
+
+ (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
+ "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "SETACL \""
+ (or mailbox imap-current-mailbox)
+ "\" "
+ identifier
+ " "
+ rights))))))
+
+ (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
+ "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server
in BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "DELETEACL \""
+ (or mailbox imap-current-mailbox)
+ "\" "
+ identifier))))))
+
+
+ ;; Message functions:
+
+ (defun imap-current-message (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ imap-current-message))
+
+ (defun imap-list-to-message-set (list)
+ (mapconcat (lambda (item)
+ (number-to-string item))
+ (if (listp list)
+ list
+ (list list))
+ ","))
+
+ (defun imap-range-to-message-set (range)
+ (mapconcat
+ (lambda (item)
+ (if (consp item)
+ (format "%d:%d"
+ (car item) (cdr item))
+ (format "%d" item)))
+ (if (and (listp range) (not (listp (cdr range))))
+ (list range) ;; make (1 . 2) into ((1 . 2))
+ range)
+ ","))
+
+ (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+ (if (listp uids)
+ (imap-list-to-message-set uids)
+ uids)
+ props))))
+
+ (defun imap-fetch (uids props &optional receive nouidfetch buffer)
+ "Fetch properties PROPS from message set UIDS from server in BUFFER.
+ UIDS can be a string, number or a list of numbers. If RECEIVE
+ is non-nil return theese properties."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p (imap-send-command-wait
+ (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+ (if (listp uids)
+ (imap-list-to-message-set uids)
+ uids)
+ props)))
+ (if (or (null receive) (stringp uids))
+ t
+ (if (listp uids)
+ (mapcar (lambda (uid)
+ (if (listp receive)
+ (mapcar (lambda (prop)
+ (imap-message-get uid prop))
+ receive)
+ (imap-message-get uid receive)))
+ uids)
+ (imap-message-get uids receive))))))
+
+ (defun imap-message-put (uid propname value &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if imap-message-data
+ (put (intern (number-to-string uid) imap-message-data)
+ propname value)
+ (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
+ uid propname value (current-buffer)))
+ t))
+
+ (defun imap-message-get (uid propname &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (get (intern-soft (number-to-string uid) imap-message-data)
+ propname)))
+
+ (defun imap-message-map (func propname &optional buffer)
+ "Map a function across each mailbox in `imap-message-data', returning a
list."
+ (with-current-buffer (or buffer (current-buffer))
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (get s 'UID) (get s propname)) result))
+ imap-message-data)
+ result)))
+
+ (defmacro imap-message-envelope-date (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 0)))
+
+ (defmacro imap-message-envelope-subject (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 1)))
+
+ (defmacro imap-message-envelope-from (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 2)))
+
+ (defmacro imap-message-envelope-sender (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 3)))
+
+ (defmacro imap-message-envelope-reply-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 4)))
+
+ (defmacro imap-message-envelope-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 5)))
+
+ (defmacro imap-message-envelope-cc (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 6)))
+
+ (defmacro imap-message-envelope-bcc (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 7)))
+
+ (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 8)))
+
+ (defmacro imap-message-envelope-message-id (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 9)))
+
+ (defmacro imap-message-body (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (imap-message-get ,uid 'BODY)))
+
+ (defun imap-search (predicate &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-put 'search 'dummy)
+ (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH "
predicate)))
+ (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
+ (progn
+ (message "Missing SEARCH response to a SEARCH command (server not
RFC compliant)...")
+ nil)
+ (imap-mailbox-get-1 'search imap-current-mailbox)))))
+
+ (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
+ "Return t iff FLAG can be permanently (between IMAP sessions) saved on
articles, in MAILBOX on server in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
+ (member flag (imap-mailbox-get 'permanentflags mailbox)))))
+
+ (defun imap-message-flags-set (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+ (defun imap-message-flags-del (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+ (defun imap-message-flags-add (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+ (defun imap-message-copyuid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
+ (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine-1 mailbox)
+ (prog1
+ (and (imap-fetch "*" "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+ (defun imap-message-copyuid (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
+
+ (defun imap-message-copy (articles mailbox
+ &optional dont-create no-copyuid buffer)
+ "Copy ARTICLES (a string message set) to MAILBOX on server in
+ BUFFER, creating mailbox if it doesn't exist. If dont-create is
+ non-nil, it will not create a mailbox. On success, return a list with
+ the UIDVALIDITY of the mailbox the article(s) was copied to as the
+ first element, rest of list contain the saved articles' UIDs."
+ (when articles
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
+ (imap-current-target-mailbox mailbox))
+ (if (imap-ok-p (imap-send-command-wait cmd))
+ t
+ (when (and (not dont-create)
+ ;; removed because of buggy Oracle server
+ ;; that doesn't send TRYCREATE tags (which
+ ;; is a MUST according to specifications):
+ ;;(imap-mailbox-get-1 'trycreate mailbox)
+ (imap-mailbox-create-1 mailbox))
+ (imap-ok-p (imap-send-command-wait cmd)))))
+ (or no-copyuid
+ (imap-message-copyuid-1 mailbox)))))))
+
+ (defun imap-message-appenduid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (imap-mailbox-get-1 'appenduid mailbox)
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine-1 mailbox)
+ (prog1
+ (and (imap-fetch "*" "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+ (defun imap-message-appenduid (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
+
+ (defun imap-message-append (mailbox article &optional flags date-time buffer)
+ "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
+ FLAGS and DATE-TIME is currently not used. Return a cons holding
+ uidvalidity of MAILBOX and UID the newly created article got, or nil
+ on failure."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (and (let ((imap-current-target-mailbox mailbox))
+ (imap-ok-p
+ (imap-send-command-wait
+ (list "APPEND \"" mailbox "\" " article))))
+ (imap-message-appenduid-1 mailbox)))))
+
+ (defun imap-body-lines (body)
+ "Return number of lines in article by looking at the mime bodystructure
BODY."
+ (if (listp body)
+ (if (stringp (car body))
+ (cond ((and (string= (upcase (car body)) "TEXT")
+ (numberp (nth 7 body)))
+ (nth 7 body))
+ ((and (string= (upcase (car body)) "MESSAGE")
+ (numberp (nth 9 body)))
+ (nth 9 body))
+ (t 0))
+ (apply '+ (mapcar 'imap-body-lines body)))
+ 0))
+
+ (defun imap-envelope-from (from)
+ "Return a from string line."
+ (and from
+ (concat (aref from 0)
+ (if (aref from 0) " <")
+ (aref from 2)
+ "@"
+ (aref from 3)
+ (if (aref from 0) ">"))))
+
+
+ ;; Internal functions.
+
+ (defun imap-add-callback (tag func)
+ (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
+
+ (defun imap-send-command-1 (cmdstr)
+ (setq cmdstr (concat cmdstr imap-client-eol))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert cmdstr)))
+ (process-send-string imap-process cmdstr))
+
+ (defun imap-send-command (command &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if (not (listp command)) (setq command (list command)))
+ (let ((tag (setq imap-tag (1+ imap-tag)))
+ cmd cmdstr)
+ (setq cmdstr (concat (number-to-string imap-tag) " "))
+ (while (setq cmd (pop command))
+ (cond ((stringp cmd)
+ (setq cmdstr (concat cmdstr cmd)))
+ ((bufferp cmd)
+ (let ((eol imap-client-eol)
+ (calcfirst imap-calculate-literal-size-first)
+ size)
+ (with-current-buffer cmd
+ (if calcfirst
+ (setq size (buffer-size)))
+ (when (not (equal eol "\r\n"))
+ ;; XXX modifies buffer!
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match eol)))
+ (if (not calcfirst)
+ (setq size (buffer-size))))
+ (setq cmdstr
+ (concat cmdstr (format "{%d}" size))))
+ (unwind-protect
+ (progn
+ (imap-send-command-1 cmdstr)
+ (setq cmdstr nil)
+ (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+ (setq command nil) ;; abort command if no cont-req
+ (let ((process imap-process)
+ (stream imap-stream)
+ (eol imap-client-eol))
+ (with-current-buffer cmd
+ (and imap-log
+ (with-current-buffer (get-buffer-create
+ imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring cmd)))
+ (process-send-region process (point-min)
+ (point-max)))
+ (process-send-string process imap-client-eol))))
+ (setq imap-continuation nil)))
+ ((functionp cmd)
+ (imap-send-command-1 cmdstr)
+ (setq cmdstr nil)
+ (unwind-protect
+ (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+ (setq command nil) ;; abort command if no cont-req
+ (setq command (cons (funcall cmd imap-continuation)
+ command)))
+ (setq imap-continuation nil)))
+ (t
+ (error "Unknown command type"))))
+ (if cmdstr
+ (imap-send-command-1 cmdstr))
+ tag)))
+
+ (defun imap-wait-for-tag (tag &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (let (imap-have-messaged)
+ (while (and (null imap-continuation)
+ (memq (process-status imap-process) '(open run))
+ (< imap-reached-tag tag))
+ (let ((len (/ (point-max) 1024))
+ message-log-max)
+ (unless (< len 10)
+ (setq imap-have-messaged t)
+ (message "imap read: %dk" len))
+ (accept-process-output imap-process
+ (truncate imap-read-timeout)
+ (truncate (* (- imap-read-timeout
+ (truncate imap-read-timeout))
+ 1000)))))
+ ;; A process can die _before_ we have processed everything it
+ ;; has to say. Moreover, this can happen in between the call to
+ ;; accept-process-output and the call to process-status in an
+ ;; iteration of the loop above.
+ (when (and (null imap-continuation)
+ (< imap-reached-tag tag))
+ (accept-process-output imap-process 0 0))
+ (when imap-have-messaged
+ (message ""))
+ (and (memq (process-status imap-process) '(open run))
+ (or (assq tag imap-failed-tags)
+ (if imap-continuation
+ 'INCOMPLETE
+ 'OK))))))
+
+ (defun imap-sentinel (process string)
+ (delete-process process))
+
+ (defun imap-find-next-line ()
+ "Return point at end of current line, taking into account literals.
+ Return nil if no complete line has arrived."
+ (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
+ imap-server-eol)
+ nil t)
+ (if (match-string 1)
+ (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
+ nil
+ (goto-char (+ (point) (string-to-number (match-string 1))))
+ (imap-find-next-line))
+ (point))))
+
+ (defun imap-arrival-filter (proc string)
+ "IMAP process filter."
+ ;; Sometimes, we are called even though the process has died.
+ ;; Better abstain from doing stuff in that case.
+ (when (buffer-name (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-max))
+ (insert string)
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert string)))
+ (let (end)
+ (goto-char (point-min))
+ (while (setq end (imap-find-next-line))
+ (save-restriction
+ (narrow-to-region (point-min) end)
+ (delete-backward-char (length imap-server-eol))
+ (goto-char (point-min))
+ (unwind-protect
+ (cond ((eq imap-state 'initial)
+ (imap-parse-greeting))
+ ((or (eq imap-state 'auth)
+ (eq imap-state 'nonauth)
+ (eq imap-state 'selected)
+ (eq imap-state 'examine))
+ (imap-parse-response))
+ (t
+ (message "Unknown state %s in arrival filter"
+ imap-state)))
+ (delete-region (point-min) (point-max)))))))))
+
+
+ ;; Imap parser.
+
+ (defsubst imap-forward ()
+ (or (eobp) (forward-char)))
+
+ ;; number = 1*DIGIT
+ ;; ; Unsigned 32-bit integer
+ ;; ; (0 <= n < 4,294,967,296)
+
+ (defsubst imap-parse-number ()
+ (when (looking-at "[0-9]+")
+ (prog1
+ (string-to-number (match-string 0))
+ (goto-char (match-end 0)))))
+
+ ;; literal = "{" number "}" CRLF *CHAR8
+ ;; ; Number represents the number of CHAR8s
+
+ (defsubst imap-parse-literal ()
+ (when (looking-at "{\\([0-9]+\\)}\r\n")
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring pos (+ pos len))))))
+
+ ;; string = quoted / literal
+ ;;
+ ;; quoted = DQUOTE *QUOTED-CHAR DQUOTE
+ ;;
+ ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
+ ;; "\" quoted-specials
+ ;;
+ ;; quoted-specials = DQUOTE / "\"
+ ;;
+ ;; TEXT-CHAR = <any CHAR except CR and LF>
+
+ (defsubst imap-parse-string ()
+ (cond ((eq (char-after) ?\")
+ (forward-char 1)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^\"\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^\"\\\\")
+ (setq name (concat name (buffer-substring p (point)))))
+ (forward-char 1)
+ name))
+ ((eq (char-after) ?{)
+ (imap-parse-literal))))
+
+ ;; nil = "NIL"
+
+ (defsubst imap-parse-nil ()
+ (if (looking-at "NIL")
+ (goto-char (match-end 0))))
+
+ ;; nstring = string / nil
+
+ (defsubst imap-parse-nstring ()
+ (or (imap-parse-string)
+ (and (imap-parse-nil)
+ nil)))
+
+ ;; astring = atom / string
+ ;;
+ ;; atom = 1*ATOM-CHAR
+ ;;
+ ;; ATOM-CHAR = <any CHAR except atom-specials>
+ ;;
+ ;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards /
+ ;; quoted-specials
+ ;;
+ ;; list-wildcards = "%" / "*"
+ ;;
+ ;; quoted-specials = DQUOTE / "\"
+
+ (defsubst imap-parse-astring ()
+ (or (imap-parse-string)
+ (buffer-substring (point)
+ (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
+ (goto-char (1- (match-end 0)))
+ (end-of-line)
+ (point)))))
+
+ ;; address = "(" addr-name SP addr-adl SP addr-mailbox SP
+ ;; addr-host ")"
+ ;;
+ ;; addr-adl = nstring
+ ;; ; Holds route from [RFC-822] route-addr if
+ ;; ; non-nil
+ ;;
+ ;; addr-host = nstring
+ ;; ; nil indicates [RFC-822] group syntax.
+ ;; ; Otherwise, holds [RFC-822] domain name
+ ;;
+ ;; addr-mailbox = nstring
+ ;; ; nil indicates end of [RFC-822] group; if
+ ;; ; non-nil and addr-host is nil, holds
+ ;; ; [RFC-822] group name.
+ ;; ; Otherwise, holds [RFC-822] local-part
+ ;; ; after removing [RFC-822] quoting
+ ;;
+ ;; addr-name = nstring
+ ;; ; If non-nil, holds phrase from [RFC-822]
+ ;; ; mailbox after removing [RFC-822] quoting
+ ;;
+
+ (defsubst imap-parse-address ()
+ (let (address)
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (setq address (vector (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (imap-parse-nstring)))
+ (when (eq (char-after) ?\))
+ (imap-forward)
+ address))))
+
+ ;; address-list = "(" 1*address ")" / nil
+ ;;
+ ;; nil = "NIL"
+
+ (defsubst imap-parse-address-list ()
+ (if (eq (char-after) ?\()
+ (let (address addresses)
+ (imap-forward)
+ (while (and (not (eq (char-after) ?\)))
+ ;; next line for MS Exchange bug
+ (progn (and (eq (char-after) ? ) (imap-forward)) t)
+ (setq address (imap-parse-address)))
+ (setq addresses (cons address addresses)))
+ (when (eq (char-after) ?\))
+ (imap-forward)
+ (nreverse addresses)))
+ (assert (imap-parse-nil) t "In imap-parse-address-list")))
+
+ ;; mailbox = "INBOX" / astring
+ ;; ; INBOX is case-insensitive. All case variants of
+ ;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
+ ;; ; not as an astring. An astring which consists of
+ ;; ; the case-insensitive sequence "I" "N" "B" "O" "X"
+ ;; ; is considered to be INBOX and not an astring.
+ ;; ; Refer to section 5.1 for further
+ ;; ; semantic details of mailbox names.
+
+ (defsubst imap-parse-mailbox ()
+ (let ((mailbox (imap-parse-astring)))
+ (if (string-equal "INBOX" (upcase mailbox))
+ "INBOX"
+ mailbox)))
+
+ ;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
+ ;;
+ ;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text
+ ;; ; Authentication condition
+ ;;
+ ;; resp-cond-bye = "BYE" SP resp-text
+
+ (defun imap-parse-greeting ()
+ "Parse a IMAP greeting."
+ (cond ((looking-at "\\* OK ")
+ (setq imap-state 'nonauth))
+ ((looking-at "\\* PREAUTH ")
+ (setq imap-state 'auth))
+ ((looking-at "\\* BYE ")
+ (setq imap-state 'closed))))
+
+ ;; response = *(continue-req / response-data) response-done
+ ;;
+ ;; continue-req = "+" SP (resp-text / base64) CRLF
+ ;;
+ ;; response-data = "*" SP (resp-cond-state / resp-cond-bye /
+ ;; mailbox-data / message-data / capability-data) CRLF
+ ;;
+ ;; response-done = response-tagged / response-fatal
+ ;;
+ ;; response-fatal = "*" SP resp-cond-bye CRLF
+ ;; ; Server closes connection immediately
+ ;;
+ ;; response-tagged = tag SP resp-cond-state CRLF
+ ;;
+ ;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
+ ;; ; Status condition
+ ;;
+ ;; resp-cond-bye = "BYE" SP resp-text
+ ;;
+ ;; mailbox-data = "FLAGS" SP flag-list /
+ ;; "LIST" SP mailbox-list /
+ ;; "LSUB" SP mailbox-list /
+ ;; "SEARCH" *(SP nz-number) /
+ ;; "STATUS" SP mailbox SP "("
+ ;; [status-att SP number *(SP status-att SP number)]
")" /
+ ;; number SP "EXISTS" /
+ ;; number SP "RECENT"
+ ;;
+ ;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
+ ;;
+ ;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
+ ;; *(SP capability)
+ ;; ; IMAP4rev1 servers which offer RFC 1730
+ ;; ; compatibility MUST list "IMAP4" as the first
+ ;; ; capability.
+
+ (defun imap-parse-response ()
+ "Parse a IMAP command response."
+ (let (token)
+ (case (setq token (read (current-buffer)))
+ (+ (setq imap-continuation
+ (or (buffer-substring (min (point-max) (1+ (point)))
+ (point-max))
+ t)))
+ (* (case (prog1 (setq token (read (current-buffer)))
+ (imap-forward))
+ (OK (imap-parse-resp-text))
+ (NO (imap-parse-resp-text))
+ (BAD (imap-parse-resp-text))
+ (BYE (imap-parse-resp-text))
+ (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
+ (LIST (imap-parse-data-list 'list))
+ (LSUB (imap-parse-data-list 'lsub))
+ (SEARCH (imap-mailbox-put
+ 'search
+ (read (concat "(" (buffer-substring (point)
(point-max)) ")"))))
+ (STATUS (imap-parse-status))
+ (CAPABILITY (setq imap-capability
+ (read (concat "(" (upcase (buffer-substring
+ (point) (point-max)))
+ ")"))))
+ (ACL (imap-parse-acl))
+ (t (case (prog1 (read (current-buffer))
+ (imap-forward))
+ (EXISTS (imap-mailbox-put 'exists token))
+ (RECENT (imap-mailbox-put 'recent token))
+ (EXPUNGE t)
+ (FETCH (imap-parse-fetch token))
+ (t (message "Garbage: %s" (buffer-string)))))))
+ (t (let (status)
+ (if (not (integerp token))
+ (message "Garbage: %s" (buffer-string))
+ (case (prog1 (setq status (read (current-buffer)))
+ (imap-forward))
+ (OK (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (imap-parse-resp-text)))
+ (NO (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text)
+ imap-failed-tags))))
+ (BAD (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text) imap-failed-tags)
+ (error "Internal error, tag %s status %s code %s text
%s"
+ token status code text))))
+ (t (message "Garbage: %s" (buffer-string))))
+ (when (assq token imap-callbacks)
+ (funcall (cdr (assq token imap-callbacks)) token status)
+ (setq imap-callbacks
+ (imap-remassoc token imap-callbacks)))))))))
+
+ ;; resp-text = ["[" resp-text-code "]" SP] text
+ ;;
+ ;; text = 1*TEXT-CHAR
+ ;;
+ ;; TEXT-CHAR = <any CHAR except CR and LF>
+
+ (defun imap-parse-resp-text ()
+ (imap-parse-resp-text-code))
+
+ ;; resp-text-code = "ALERT" /
+ ;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
+ ;; "NEWNAME" SP string SP string /
+ ;; "PARSE" /
+ ;; "PERMANENTFLAGS" SP "("
+ ;; [flag-perm *(SP flag-perm)] ")" /
+ ;; "READ-ONLY" /
+ ;; "READ-WRITE" /
+ ;; "TRYCREATE" /
+ ;; "UIDNEXT" SP nz-number /
+ ;; "UIDVALIDITY" SP nz-number /
+ ;; "UNSEEN" SP nz-number /
+ ;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
+ ;;
+ ;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid
+ ;;
+ ;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set
+ ;;
+ ;; set = sequence-num / (sequence-num ":" sequence-num) /
+ ;; (set "," set)
+ ;; ; Identifies a set of messages. For message
+ ;; ; sequence numbers, these are consecutive
+ ;; ; numbers from 1 to the number of messages in
+ ;; ; the mailbox
+ ;; ; Comma delimits individual numbers, colon
+ ;; ; delimits between two numbers inclusive.
+ ;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
+ ;; ; 14,15 for a mailbox with 15 messages.
+ ;;
+ ;; sequence-num = nz-number / "*"
+ ;; ; * is the largest number in use. For message
+ ;; ; sequence numbers, it is the number of messages
+ ;; ; in the mailbox. For unique identifiers, it is
+ ;; ; the unique identifier of the last message in
+ ;; ; the mailbox.
+ ;;
+ ;; flag-perm = flag / "\*"
+ ;;
+ ;; flag = "\Answered" / "\Flagged" / "\Deleted" /
+ ;; "\Seen" / "\Draft" / flag-keyword / flag-extension
+ ;; ; Does not include "\Recent"
+ ;;
+ ;; flag-extension = "\" atom
+ ;; ; Future expansion. Client implementations
+ ;; ; MUST accept flag-extension flags. Server
+ ;; ; implementations MUST NOT generate
+ ;; ; flag-extension flags except as defined by
+ ;; ; future standard or standards-track
+ ;; ; revisions of this specification.
+ ;;
+ ;; flag-keyword = atom
+ ;;
+ ;; resp-text-atom = 1*<any ATOM-CHAR except "]">
+
+ (defun imap-parse-resp-text-code ()
+ ;; xxx next line for stalker communigate pro 3.3.1 bug
+ (when (looking-at " \\[")
+ (imap-forward))
+ (when (eq (char-after) ?\[)
+ (imap-forward)
+ (cond ((search-forward "PERMANENTFLAGS " nil t)
+ (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
+ ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
+ (imap-mailbox-put 'uidnext (match-string 1)))
+ ((search-forward "UNSEEN " nil t)
+ (imap-mailbox-put 'first-unseen (read (current-buffer))))
+ ((looking-at "UIDVALIDITY \\([0-9]+\\)")
+ (imap-mailbox-put 'uidvalidity (match-string 1)))
+ ((search-forward "READ-ONLY" nil t)
+ (imap-mailbox-put 'read-only t))
+ ((search-forward "NEWNAME " nil t)
+ (let (oldname newname)
+ (setq oldname (imap-parse-string))
+ (imap-forward)
+ (setq newname (imap-parse-string))
+ (imap-mailbox-put 'newname newname oldname)))
+ ((search-forward "TRYCREATE" nil t)
+ (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
+ ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
+ (imap-mailbox-put 'appenduid
+ (list (match-string 1)
+ (string-to-number (match-string 2)))
+ imap-current-target-mailbox))
+ ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
+ (imap-mailbox-put 'copyuid (list (match-string 1)
+ (match-string 2)
+ (match-string 3))
+ imap-current-target-mailbox))
+ ((search-forward "ALERT] " nil t)
+ (message "Imap server %s information: %s" imap-server
+ (buffer-substring (point) (point-max)))))))
+
+ ;; mailbox-list = "(" [mbx-list-flags] ")" SP
+ ;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
+ ;;
+ ;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag
+ ;; *(SP mbx-list-oflag) /
+ ;; mbx-list-oflag *(SP mbx-list-oflag)
+ ;;
+ ;; mbx-list-oflag = "\Noinferiors" / flag-extension
+ ;; ; Other flags; multiple possible per LIST response
+ ;;
+ ;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked"
+ ;; ; Selectability flags; only one per LIST response
+ ;;
+ ;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
+ ;; "\" quoted-specials
+ ;;
+ ;; quoted-specials = DQUOTE / "\"
+
+ (defun imap-parse-data-list (type)
+ (let (flags delimiter mailbox)
+ (setq flags (imap-parse-flag-list))
+ (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
+ (setq delimiter (match-string 1))
+ (goto-char (1+ (match-end 0)))
+ (when (setq mailbox (imap-parse-mailbox))
+ (imap-mailbox-put type t mailbox)
+ (imap-mailbox-put 'list-flags flags mailbox)
+ (imap-mailbox-put 'delimiter delimiter mailbox)))))
+
+ ;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope /
+ ;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
+ ;; "INTERNALDATE" SPACE date_time /
+ ;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
+ ;; "RFC822.SIZE" SPACE number /
+ ;; "BODY" ["STRUCTURE"] SPACE body /
+ ;; "BODY" section ["<" number ">"] SPACE nstring /
+ ;; "UID" SPACE uniqueid) ")"
+ ;;
+ ;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
+ ;; SPACE time SPACE zone <">
+ ;;
+ ;; section ::= "[" [section_text / (nz_number *["." nz_number]
+ ;; ["." (section_text / "MIME")])] "]"
+ ;;
+ ;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
+ ;; SPACE header_list / "TEXT"
+ ;;
+ ;; header_fld_name ::= astring
+ ;;
+ ;; header_list ::= "(" 1#header_fld_name ")"
+
+ (defsubst imap-parse-header-list ()
+ (when (eq (char-after) ?\()
+ (let (strlist)
+ (while (not (eq (char-after) ?\)))
+ (imap-forward)
+ (push (imap-parse-astring) strlist))
+ (imap-forward)
+ (nreverse strlist))))
+
+ (defsubst imap-parse-fetch-body-section ()
+ (let ((section
+ (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
+ (if (eq (char-before) ? )
+ (prog1
+ (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
+ (search-forward "]" nil t))
+ section)))
+
+ (defun imap-parse-fetch (response)
+ (when (eq (char-after) ?\()
+ (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
+ rfc822size body bodydetail bodystructure flags-empty)
+ (while (not (eq (char-after) ?\)))
+ (imap-forward)
+ (let ((token (read (current-buffer))))
+ (imap-forward)
+ (cond ((eq token 'UID)
+ (setq uid (condition-case ()
+ (read (current-buffer))
+ (error))))
+ ((eq token 'FLAGS)
+ (setq flags (imap-parse-flag-list))
+ (if (not flags)
+ (setq flags-empty 't)))
+ ((eq token 'ENVELOPE)
+ (setq envelope (imap-parse-envelope)))
+ ((eq token 'INTERNALDATE)
+ (setq internaldate (imap-parse-string)))
+ ((eq token 'RFC822)
+ (setq rfc822 (imap-parse-nstring)))
+ ((eq token 'RFC822.HEADER)
+ (setq rfc822header (imap-parse-nstring)))
+ ((eq token 'RFC822.TEXT)
+ (setq rfc822text (imap-parse-nstring)))
+ ((eq token 'RFC822.SIZE)
+ (setq rfc822size (read (current-buffer))))
+ ((eq token 'BODY)
+ (if (eq (char-before) ?\[)
+ (push (list
+ (upcase (imap-parse-fetch-body-section))
+ (and (eq (char-after) ?<)
+ (buffer-substring (1+ (point))
+ (search-forward ">" nil t)))
+ (progn (imap-forward)
+ (imap-parse-nstring)))
+ bodydetail)
+ (setq body (imap-parse-body))))
+ ((eq token 'BODYSTRUCTURE)
+ (setq bodystructure (imap-parse-body))))))
+ (when uid
+ (setq imap-current-message uid)
+ (imap-message-put uid 'UID uid)
+ (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
+ (and envelope (imap-message-put uid 'ENVELOPE envelope))
+ (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
+ (and rfc822 (imap-message-put uid 'RFC822 rfc822))
+ (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
+ (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
+ (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
+ (and body (imap-message-put uid 'BODY body))
+ (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
+ (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
+ (run-hooks 'imap-fetch-data-hook)))))
+
+ ;; mailbox-data = ...
+ ;; "STATUS" SP mailbox SP "("
+ ;; [status-att SP number
+ ;; *(SP status-att SP number)] ")"
+ ;; ...
+ ;;
+ ;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
+ ;; "UNSEEN"
+
+ (defun imap-parse-status ()
+ (let ((mailbox (imap-parse-mailbox)))
+ (if (eq (char-after) ? )
+ (forward-char))
+ (when (and mailbox (eq (char-after) ?\())
+ (while (and (not (eq (char-after) ?\)))
+ (or (forward-char) t)
+ (looking-at "\\([A-Za-z]+\\) "))
+ (let ((token (match-string 1)))
+ (goto-char (match-end 0))
+ (cond ((string= token "MESSAGES")
+ (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
+ ((string= token "RECENT")
+ (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
+ ((string= token "UIDNEXT")
+ (and (looking-at "[0-9]+")
+ (imap-mailbox-put 'uidnext (match-string 0) mailbox)
+ (goto-char (match-end 0))))
+ ((string= token "UIDVALIDITY")
+ (and (looking-at "[0-9]+")
+ (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
+ (goto-char (match-end 0))))
+ ((string= token "UNSEEN")
+ (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
+ (t
+ (message "Unknown status data %s in mailbox %s ignored"
+ token mailbox)
+ (read (current-buffer)))))))))
+
+ ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
+ ;; rights)
+ ;;
+ ;; identifier ::= astring
+ ;;
+ ;; rights ::= astring
+
+ (defun imap-parse-acl ()
+ (let ((mailbox (imap-parse-mailbox))
+ identifier rights acl)
+ (while (eq (char-after) ?\ )
+ (imap-forward)
+ (setq identifier (imap-parse-astring))
+ (imap-forward)
+ (setq rights (imap-parse-astring))
+ (setq acl (append acl (list (cons identifier rights)))))
+ (imap-mailbox-put 'acl acl mailbox)))
+
+ ;; flag-list = "(" [flag *(SP flag)] ")"
+ ;;
+ ;; flag = "\Answered" / "\Flagged" / "\Deleted" /
+ ;; "\Seen" / "\Draft" / flag-keyword / flag-extension
+ ;; ; Does not include "\Recent"
+ ;;
+ ;; flag-keyword = atom
+ ;;
+ ;; flag-extension = "\" atom
+ ;; ; Future expansion. Client implementations
+ ;; ; MUST accept flag-extension flags. Server
+ ;; ; implementations MUST NOT generate
+ ;; ; flag-extension flags except as defined by
+ ;; ; future standard or standards-track
+ ;; ; revisions of this specification.
+
+ (defun imap-parse-flag-list ()
+ (let (flag-list start)
+ (assert (eq (char-after) ?\() t "In imap-parse-flag-list")
+ (while (and (not (eq (char-after) ?\)))
+ (setq start (progn
+ (imap-forward)
+ ;; next line for Courier IMAP bug.
+ (skip-chars-forward " ")
+ (point)))
+ (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
+ (push (buffer-substring start (point)) flag-list))
+ (assert (eq (char-after) ?\)) t "In imap-parse-flag-list")
+ (imap-forward)
+ (nreverse flag-list)))
+
+ ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender
SP
+ ;; env-reply-to SP env-to SP env-cc SP env-bcc SP
+ ;; env-in-reply-to SP env-message-id ")"
+ ;;
+ ;; env-bcc = "(" 1*address ")" / nil
+ ;;
+ ;; env-cc = "(" 1*address ")" / nil
+ ;;
+ ;; env-date = nstring
+ ;;
+ ;; env-from = "(" 1*address ")" / nil
+ ;;
+ ;; env-in-reply-to = nstring
+ ;;
+ ;; env-message-id = nstring
+ ;;
+ ;; env-reply-to = "(" 1*address ")" / nil
+ ;;
+ ;; env-sender = "(" 1*address ")" / nil
+ ;;
+ ;; env-subject = nstring
+ ;;
+ ;; env-to = "(" 1*address ")" / nil
+
+ (defun imap-parse-envelope ()
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (vector (prog1 (imap-parse-nstring) ;; date
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; subject
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; from
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; sender
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; reply-to
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; to
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; cc
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; bcc
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; in-reply-to
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; message-id
+ (imap-forward)))))
+
+ ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
+
+ (defsubst imap-parse-string-list ()
+ (cond ((eq (char-after) ?\() ;; body-fld-param
+ (let (strlist str)
+ (imap-forward)
+ (while (setq str (imap-parse-string))
+ (push str strlist)
+ ;; buggy stalker communigate pro 3.0 doesn't print SPC
+ ;; between body-fld-param's sometimes
+ (or (eq (char-after) ?\")
+ (imap-forward)))
+ (nreverse strlist)))
+ ((imap-parse-nil)
+ nil)))
+
+ ;; body-extension = nstring / number /
+ ;; "(" body-extension *(SP body-extension) ")"
+ ;; ; Future expansion. Client implementations
+ ;; ; MUST accept body-extension fields. Server
+ ;; ; implementations MUST NOT generate
+ ;; ; body-extension fields except as defined by
+ ;; ; future standard or standards-track
+ ;; ; revisions of this specification.
+
+ (defun imap-parse-body-extension ()
+ (if (eq (char-after) ?\()
+ (let (b-e)
+ (imap-forward)
+ (push (imap-parse-body-extension) b-e)
+ (while (eq (char-after) ?\ )
+ (imap-forward)
+ (push (imap-parse-body-extension) b-e))
+ (assert (eq (char-after) ?\)) t "In imap-parse-body-extension")
+ (imap-forward)
+ (nreverse b-e))
+ (or (imap-parse-number)
+ (imap-parse-nstring))))
+
+ ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+ ;; *(SP body-extension)]]
+ ;; ; MUST NOT be returned on non-extensible
+ ;; ; "BODY" fetch
+ ;;
+ ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+ ;; *(SP body-extension)]]
+ ;; ; MUST NOT be returned on non-extensible
+ ;; ; "BODY" fetch
+
+ (defsubst imap-parse-body-ext ()
+ (let (ext)
+ (when (eq (char-after) ?\ ) ;; body-fld-dsp
+ (imap-forward)
+ (let (dsp)
+ (if (eq (char-after) ?\()
+ (progn
+ (imap-forward)
+ (push (imap-parse-string) dsp)
+ (imap-forward)
+ (push (imap-parse-string-list) dsp)
+ (imap-forward))
+ (assert (imap-parse-nil) t "In imap-parse-body-ext"))
+ (push (nreverse dsp) ext))
+ (when (eq (char-after) ?\ ) ;; body-fld-lang
+ (imap-forward)
+ (if (eq (char-after) ?\()
+ (push (imap-parse-string-list) ext)
+ (push (imap-parse-nstring) ext))
+ (while (eq (char-after) ?\ ) ;; body-extension
+ (imap-forward)
+ (setq ext (append (imap-parse-body-extension) ext)))))
+ ext))
+
+ ;; body = "(" body-type-1part / body-type-mpart ")"
+ ;;
+ ;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+ ;; *(SP body-extension)]]
+ ;; ; MUST NOT be returned on non-extensible
+ ;; ; "BODY" fetch
+ ;;
+ ;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+ ;; *(SP body-extension)]]
+ ;; ; MUST NOT be returned on non-extensible
+ ;; ; "BODY" fetch
+ ;;
+ ;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP
+ ;; body-fld-enc SP body-fld-octets
+ ;;
+ ;; body-fld-desc = nstring
+ ;;
+ ;; body-fld-dsp = "(" string SP body-fld-param ")" / nil
+ ;;
+ ;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
+ ;; "QUOTED-PRINTABLE") DQUOTE) / string
+ ;;
+ ;; body-fld-id = nstring
+ ;;
+ ;; body-fld-lang = nstring / "(" string *(SP string) ")"
+ ;;
+ ;; body-fld-lines = number
+ ;;
+ ;; body-fld-md5 = nstring
+ ;;
+ ;; body-fld-octets = number
+ ;;
+ ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
+ ;;
+ ;; body-type-1part = (body-type-basic / body-type-msg / body-type-text)
+ ;; [SP body-ext-1part]
+ ;;
+ ;; body-type-basic = media-basic SP body-fields
+ ;; ; MESSAGE subtype MUST NOT be "RFC822"
+ ;;
+ ;; body-type-msg = media-message SP body-fields SP envelope
+ ;; SP body SP body-fld-lines
+ ;;
+ ;; body-type-text = media-text SP body-fields SP body-fld-lines
+ ;;
+ ;; body-type-mpart = 1*body SP media-subtype
+ ;; [SP body-ext-mpart]
+ ;;
+ ;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
+ ;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
+ ;; ; Defined in [MIME-IMT]
+ ;;
+ ;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
+ ;; ; Defined in [MIME-IMT]
+ ;;
+ ;; media-subtype = string
+ ;; ; Defined in [MIME-IMT]
+ ;;
+ ;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype
+ ;; ; Defined in [MIME-IMT]
+
+ (defun imap-parse-body ()
+ (let (body)
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (if (eq (char-after) ?\()
+ (let (subbody)
+ (while (and (eq (char-after) ?\()
+ (setq subbody (imap-parse-body)))
+ ;; buggy stalker communigate pro 3.0 insert a SPC between
+ ;; parts in multiparts
+ (when (and (eq (char-after) ?\ )
+ (eq (char-after (1+ (point))) ?\())
+ (imap-forward))
+ (push subbody body))
+ (imap-forward)
+ (push (imap-parse-string) body) ;; media-subtype
+ (when (eq (char-after) ?\ ) ;; body-ext-mpart:
+ (imap-forward)
+ (if (eq (char-after) ?\() ;; body-fld-param
+ (push (imap-parse-string-list) body)
+ (push (and (imap-parse-nil) nil) body))
+ (setq body
+ (append (imap-parse-body-ext) body))) ;; body-ext-...
+ (assert (eq (char-after) ?\)) t "In imap-parse-body")
+ (imap-forward)
+ (nreverse body))
+
+ (push (imap-parse-string) body) ;; media-type
+ (imap-forward)
+ (push (imap-parse-string) body) ;; media-subtype
+ (imap-forward)
+ ;; next line for Sun SIMS bug
+ (and (eq (char-after) ? ) (imap-forward))
+ (if (eq (char-after) ?\() ;; body-fld-param
+ (push (imap-parse-string-list) body)
+ (push (and (imap-parse-nil) nil) body))
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-id
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-desc
+ (imap-forward)
+ ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
+ ;; nstring and return nil instead of defaulting back to 7BIT
+ ;; as the standard says.
+ (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
+ (imap-forward)
+ (push (imap-parse-number) body) ;; body-fld-octets
+
+ ;; ok, we're done parsing the required parts, what comes now is one
+ ;; of three things:
+ ;;
+ ;; envelope (then we're parsing body-type-msg)
+ ;; body-fld-lines (then we're parsing body-type-text)
+ ;; body-ext-1part (then we're parsing body-type-basic)
+ ;;
+ ;; the problem is that the two first are in turn optionally followed
+ ;; by the third. So we parse the first two here (if there are any)...
+
+ (when (eq (char-after) ?\ )
+ (imap-forward)
+ (let (lines)
+ (cond ((eq (char-after) ?\() ;; body-type-msg:
+ (push (imap-parse-envelope) body) ;; envelope
+ (imap-forward)
+ (push (imap-parse-body) body) ;; body
+ ;; buggy stalker communigate pro 3.0 doesn't print
+ ;; number of lines in message/rfc822 attachment
+ (if (eq (char-after) ?\))
+ (push 0 body)
+ (imap-forward)
+ (push (imap-parse-number) body))) ;; body-fld-lines
+ ((setq lines (imap-parse-number)) ;; body-type-text:
+ (push lines body)) ;; body-fld-lines
+ (t
+ (backward-char))))) ;; no match...
+
+ ;; ...and then parse the third one here...
+
+ (when (eq (char-after) ?\ ) ;; body-ext-1part:
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-md5
+ (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
+
+ (assert (eq (char-after) ?\)) t "In imap-parse-body 2")
+ (imap-forward)
+ (nreverse body)))))
+
+ (when imap-debug ; (untrace-all)
+ (require 'trace)
+ (buffer-disable-undo (get-buffer-create imap-debug-buffer))
+ (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
+ '(
+ imap-utf7-encode
+ imap-utf7-decode
+ imap-error-text
+ imap-kerberos4s-p
+ imap-kerberos4-open
+ imap-ssl-p
+ imap-ssl-open
+ imap-network-p
+ imap-network-open
+ imap-interactive-login
+ imap-kerberos4a-p
+ imap-kerberos4-auth
+ imap-cram-md5-p
+ imap-cram-md5-auth
+ imap-login-p
+ imap-login-auth
+ imap-anonymous-p
+ imap-anonymous-auth
+ imap-open-1
+ imap-open
+ imap-opened
+ imap-authenticate
+ imap-close
+ imap-capability
+ imap-namespace
+ imap-send-command-wait
+ imap-mailbox-put
+ imap-mailbox-get
+ imap-mailbox-map-1
+ imap-mailbox-map
+ imap-current-mailbox
+ imap-current-mailbox-p-1
+ imap-current-mailbox-p
+ imap-mailbox-select-1
+ imap-mailbox-select
+ imap-mailbox-examine-1
+ imap-mailbox-examine
+ imap-mailbox-unselect
+ imap-mailbox-expunge
+ imap-mailbox-close
+ imap-mailbox-create-1
+ imap-mailbox-create
+ imap-mailbox-delete
+ imap-mailbox-rename
+ imap-mailbox-lsub
+ imap-mailbox-list
+ imap-mailbox-subscribe
+ imap-mailbox-unsubscribe
+ imap-mailbox-status
+ imap-mailbox-acl-get
+ imap-mailbox-acl-set
+ imap-mailbox-acl-delete
+ imap-current-message
+ imap-list-to-message-set
+ imap-fetch-asynch
+ imap-fetch
+ imap-message-put
+ imap-message-get
+ imap-message-map
+ imap-search
+ imap-message-flag-permanent-p
+ imap-message-flags-set
+ imap-message-flags-del
+ imap-message-flags-add
+ imap-message-copyuid-1
+ imap-message-copyuid
+ imap-message-copy
+ imap-message-appenduid-1
+ imap-message-appenduid
+ imap-message-append
+ imap-body-lines
+ imap-envelope-from
+ imap-send-command-1
+ imap-send-command
+ imap-wait-for-tag
+ imap-sentinel
+ imap-find-next-line
+ imap-arrival-filter
+ imap-parse-greeting
+ imap-parse-response
+ imap-parse-resp-text
+ imap-parse-resp-text-code
+ imap-parse-data-list
+ imap-parse-fetch
+ imap-parse-status
+ imap-parse-acl
+ imap-parse-flag-list
+ imap-parse-envelope
+ imap-parse-body-extension
+ imap-parse-body
+ )))
+
+ (provide 'imap)
+
+ ;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
+ ;;; imap.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to emacs/lisp/gnus/imap.el [gnus-5_10-branch],
Andreas Schwab <=