[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
nnimap 0.3.25 released
Mostly cosmetic changes and documentation additions.
The file imap4rev1.el has been renamed to imap.el which makes for the
ugly patch. I'd suggest getting the tarball and remove the old code.
Get it from http://vic20.dzp.se/gnus-imap/nnimap.tar.gz.
/s
1998-08-23 14:18:51 Simon Josefsson <jas@pdc.kth.se>
* nnimap 0.3.25 released.
1998-08-23 14:16:36 Simon Josefsson <jas@pdc.kth.se>
* manual.html: Stuff added.
1998-08-23 13:31:13 Simon Josefsson <jas@pdc.kth.se>
* hmac.el: Require 'hexl.
1998-08-23 13:28:41 Simon Josefsson <jas@pdc.kth.se>
* Makefile: Clean up.
1998-08-23 13:13:26 Simon Josefsson <jas@pdc.kth.se>
* nnimap.el (nnimap-request-article):
(nnimap-request-body): PEEK articles and have close-group set
flags.
1998-08-21 23:22:25 Simon Josefsson <jas@pdc.kth.se>
* Makefile (all): Changed target for imap.el.
1998-08-21 Jim Radford <radford@robby.caltech.edu>
* imap.el: renamed file from imap4rev1.el.
* nnimap.el: Fix the Lotus bug fix: Since they return
the 1 from 1,* we just have to ask for * instead of
every article 1:*. This should work, but since the
server is buggy, maybe it wont.
Index: nnimap/ChangeLog
diff -c nnimap/ChangeLog:1.49 nnimap/ChangeLog:1.55
*** nnimap/ChangeLog:1.49 Thu Aug 20 13:54:06 1998
--- nnimap/ChangeLog Sun Aug 23 05:20:39 1998
***************
*** 1,3 ****
--- 1,38 ----
+ 1998-08-23 14:18:51 Simon Josefsson <jas@pdc.kth.se>
+
+ * nnimap 0.3.25 released.
+
+ 1998-08-23 14:16:36 Simon Josefsson <jas@pdc.kth.se>
+
+ * manual.html: Stuff added.
+
+ 1998-08-23 13:31:13 Simon Josefsson <jas@pdc.kth.se>
+
+ * hmac.el: Require 'hexl.
+
+ 1998-08-23 13:28:41 Simon Josefsson <jas@pdc.kth.se>
+
+ * Makefile: Clean up.
+
+ 1998-08-23 13:13:26 Simon Josefsson <jas@pdc.kth.se>
+
+ * nnimap.el (nnimap-request-article):
+ (nnimap-request-body): PEEK articles and have close-group set
+ flags.
+
+ 1998-08-21 23:22:25 Simon Josefsson <jas@pdc.kth.se>
+
+ * Makefile (all): Changed target for imap.el.
+
+ 1998-08-21 Jim Radford <radford@robby.caltech.edu>
+
+ * imap.el: renamed file from imap4rev1.el.
+
+ * nnimap.el: Fix the Lotus bug fix: Since they return
+ the 1 from 1,* we just have to ask for * instead of
+ every article 1:*. This should work, but since the
+ server is buggy, maybe it wont.
+
1998-08-20 22:52:12 Simon Josefsson <jas@pdc.kth.se>
* nnimap 0.3.24 released.
Index: nnimap/Makefile
diff -c nnimap/Makefile:1.8 nnimap/Makefile:1.11
*** nnimap/Makefile:1.8 Sat Aug 15 07:04:13 1998
--- nnimap/Makefile Sun Aug 23 04:31:12 1998
***************
*** 1,19 ****
EMACS=emacs
VERSION=`date +%y%m%d-%H%M`
! all: imap4rev1.elc nnimap.elc hmac.elc
hmac.elc: hmac.el
! $(EMACS) -batch -q -no-site-file -f batch-byte-compile hmac.el
! imap4rev1.elc: imap4rev1.el
! $(EMACS) -batch -q -no-site-file -f batch-byte-compile imap4rev1.el
! nnimap.elc: imap4rev1.elc hmac.el nnimap.el
! $(EMACS) -batch -q -no-site-file -l imap4rev1.el -f batch-byte-compile nnimap.el
clean:
! rm -f imap4rev1.elc nnimap.elc hmac.elc
tar:
cvs export -D now -d nnimap-$(VERSION) nnimap
--- 1,20 ----
EMACS=emacs
+ ELCC=$(EMACS) -batch -q -no-site-file
VERSION=`date +%y%m%d-%H%M`
! all: imap.elc nnimap.elc hmac.elc
hmac.elc: hmac.el
! $(ELCC) -f batch-byte-compile hmac.el
! imap.elc: imap.el
! $(ELCC) -l hmac.el -f batch-byte-compile imap.el
! nnimap.elc: imap.elc hmac.el nnimap.el
! $(ELCC) -l imap.el -f batch-byte-compile nnimap.el
clean:
! rm -f imap.elc nnimap.elc hmac.elc
tar:
cvs export -D now -d nnimap-$(VERSION) nnimap
Index: nnimap/hmac.el
diff -c nnimap/hmac.el:1.13 nnimap/hmac.el:1.14
*** nnimap/hmac.el:1.13 Mon Aug 17 03:21:35 1998
--- nnimap/hmac.el Sun Aug 23 04:33:19 1998
***************
*** 39,44 ****
--- 39,45 ----
;;; 1998-08-17 use append instead of char-list-to-string
(require 'cl)
+ (require 'hexl)
;; Magic character for inner HMAC round. 0x36 == 54 == '6'
(defconst hmac-ipad ?\x36)
***************
*** 48,57 ****
;; Not so magic character for padding the key. 0x00
(defconst hmac-zero ?\x00)
-
- (if (not (fboundp 'hexl-hex-string-to-integer))
- (defun hexl-hex-string-to-integer (string)
- (string-to-number string 16)))
(defun hmac (hash block-length hash-length key text)
(let* (;; if key is longer than B, reset it to HASH(key)
--- 49,54 ----
Index: nnimap/imap.el
diff -c /dev/null nnimap/imap.el:1.27
*** /dev/null Sun Aug 23 05:22:16 1998
--- nnimap/imap.el Fri Aug 21 14:04:20 1998
***************
*** 0 ****
--- 1,915 ----
+ ;;; imap.el --- IMAP library for emacs
+
+ ;;; Copyright (C) 1998 Simon Josefsson
+ ;;; Copyright (C) 1998 Jim Radford
+ ;;; Copyright (C) 1997 John McClary Prevost
+
+ ;;; This program 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 of the License, or
+ ;;; (at your option) any later version.
+
+ ;;; This program 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 this program; if not, write to the Free Software
+ ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ ;;; Commentary:
+
+ ;;; This file provides a low level interface to an IMAP server.
+ ;;; It provides functions to send commands and wait for responses.
+ ;;; The results are parsed into lisp expressions and returned.
+ ;;; IMAP untagged responses are stuffed in to obarrays based on
+ ;;; the current group. All the parameter variables become local
+ ;;; to the IMAP process buffer.
+
+ ;;; Todo:
+ ;;; On expunge, remove messages from message-data. Note it doesn't
+ ;;; return UIDs. Ouch.
+
+ (eval-when-compile (require 'cl))
+
+ (eval-and-compile
+ (autoload 'open-ssl-stream "ssl")
+ (unless (fboundp 'open-network-stream)
+ (require 'tcp)))
+
+ ;;; External variables
+
+ (defvar imap-default-port 143
+ "*Default port number to be used for IMAP connections. This should
+ probably be \"imap\", but a lot of machines lack the services entry.
+
+ This can be overrided by the server definition imap-port, and is the
+ prefered way of specifying this.")
+
+ (defvar imap-convenient-group-prime 2999
+ "*A convenient prime which will be used to set the size of the group hash.
+ We have a lot of groups at CMU, so this should probably be adjusted down.")
+
+ (defvar imap-convenient-folder-prime 997
+ "*A convenient prime which will be used to set the size of the folder
+ (message) hash.")
+
+ (defvar imap-open-stream nil
+ "*The name of a function to use for opening an imap stream. Defaults on
+ nil to open a networked stream to the server.
+
+ Examples; imap-open-imtest-stream, imap-open-ssl-stream.
+
+ This can be overrided by the server definition imap-open-stram, and
+ this is the prefered way of specifying this.")
+
+ (defvar imap-auth-method nil
+ "*The name of a function to use for loging on to the server. Defaults on
+ nil to plain text logins using the LOGIN command.
+
+ Examples; imap-authenticate-cram-md5.
+
+ This can be overried by the server definition imap-auth-method, and
+ this is the prefered way of specifying this.")
+
+ (defvar imap-eol "\r\n"
+ "*The string sent to end a command.")
+
+ ;; remove?
+ (defvar imap-default-name nil
+ "*Your name, should you choose to accept it.")
+
+ (defvar imap-last-status nil
+ "*Status returned by last IMAP command")
+
+ (defvar imap-timeout 20
+ "*Timeout in seconds to wait for server response.")
+
+ (defvar imap-username nil
+ "Username for server. ")
+
+ (defvar imap-password nil
+ "Password for server.")
+
+ ;;; Internal variables
+
+ (defvar imap-authinfo nil
+ "Buffer local variable which contains (user . password) for server.")
+
+ (defvar imap-process nil
+ "The active process for the current IMAP buffer.")
+
+ (defvar imap-data-capability nil
+ "Current server's capability list")
+
+ (defvar imap-data-folder nil
+ "Obarray which contains group information.")
+
+ (defvar imap-cb-finished-tags '()
+ "Alist of tags which are completed but not yet handled.")
+
+ (defvar imap-message-data nil
+ "Obarray which contains current message cache.")
+
+ (defvar imap-current-folder nil
+ "Name of the current folder")
+
+ (defvar imap-current-message nil
+ "Symbol of current message.")
+
+ (defvar imap-current-server nil
+ "Name of current server machine.")
+
+ (defvar imap-tag-num 0
+ "Number for tag increment.")
+
+ (defvar imap-tag-char ?A
+ "Unique tag char per connection.")
+
+ (defvar imap-connection-number 0
+ "Unique tag char per connection.")
+
+ (defvar imap-do-login t
+ "Wheter imap-authenticate should try to log in or not.
+
+ This is normally only turned off by a `imap-open-stream' that does
+ it's own authentication.")
+
+ (defvar imap-cb-function-alist '((OK . imap-cb-response)
+ (NO . imap-cb-response)
+ (BAD . imap-cb-response)
+ (PREAUTH . imap-cb-response)
+ (BYE . imap-cb-bye)
+ (EXISTS . imap-cb-numbered)
+ (EXPUNGE . imap-cb-numbered)
+ (RECENT . imap-cb-numbered)
+ (CAPABILITY . imap-cb-capability)
+ (LIST . imap-cb-list)
+ (LSUB . imap-cb-list)
+ (FLAGS . imap-cb-flags)
+ (FETCH . imap-cb-fetch)
+ (SEARCH . imap-cb-search)
+ (STATUS . imap-cb-status)
+ (ACL . imap-cb-acl)
+ (default . imap-cb-default))
+ "Alist of IMAP code to function callbacks.")
+
+ (defvar imap-cb-tag-alist '()
+ "Alist of tags to callbacks for tagged responses.")
+
+ (defvar imap-locals '(imap-cb-finished-tags
+ imap-cb-tag-alist
+ imap-current-folder
+ imap-current-message
+ imap-current-server
+ imap-data-capability
+ imap-data-folder
+ imap-open-stream
+ imap-auth-method
+ imap-do-login
+ imap-message-data
+ imap-default-name
+ imap-authinfo
+ imap-last-status
+ imap-process
+ imap-tag-num
+ imap-tag-char
+ imap-eol)
+ "A list the variables that define an individual imap connection.
+ They are reset from their `default-value's . You can pass values for
+ any of these to `imap-open-server'.")
+
+
+ ;; If non nil these hold the name of a buffer to put debug into
+ (defvar imap-log "*imap-log*") ; imap session trace
+ (defvar imap-last "*imap-last*") ; last line we attempted to parse
+ (defvar imap-debug "*imap-debug*") ; random debug spew
+
+ (when imap-debug ; (untrace-all)
+ (require 'trace)
+ (buffer-disable-undo (get-buffer-create imap-debug))
+ (mapc (lambda (f) (trace-function-background f imap-debug))
+ '(imap-open-server
+ imap-close-server
+ imap-server-opened
+ imap-select-mailbox
+ imap-send-command
+ imap-send-command-wait
+ imap-send-commands-wait
+ ; imap-ok-p
+ imap-wait-for-tag
+ imap-capability-get
+ imap-authinfo-get
+ imap-folder-set
+ imap-folder-get
+ imap-folder-plist
+ imap-dispatch
+ imap-authenticate
+ imap-authenticate-login
+ imap-authenticate-cram-md5
+ imap-message-set
+ imap-message-get
+ imap-message-map
+ imap-message-plist
+ imap-cb-response
+ imap-cb-bye
+ imap-cb-numbered
+ imap-cb-capability
+ imap-cb-list
+ imap-cb-flags
+ imap-cb-fetch
+ imap-cb-search
+ imap-cb-status
+ imap-cb-default)))
+
+ ;;; Compatibility
+
+ (or (fboundp 'char-int)
+ (fset 'char-int (symbol-function 'identity)))
+
+ (or (fboundp 'int-char)
+ (fset 'int-char (symbol-function 'identity)))
+
+ (if (not (fboundp 'remassoc))
+ (defun 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 (remassoc key (cdr alist)))
+ alist))))
+
+ (if (not (fboundp 'save-current-buffer))
+ (defmacro save-current-buffer (&rest body)
+ "Save the current buffer; execute BODY; restore the current buffer.
+ Executes BODY just like `progn'."
+ (` (let ((orig-buffer (current-buffer)))
+ (unwind-protect
+ (progn (,@ body))
+ (set-buffer orig-buffer))))))
+
+ (if (not (fboundp 'with-current-buffer))
+ (defmacro with-current-buffer (buffer &rest body)
+ "Execute the forms in BODY with BUFFER as the current buffer.
+ The value returned is the value of the last form in BODY.
+ See also `with-temp-buffer'."
+ `(save-current-buffer
+ (set-buffer ,buffer)
+ ,@body)))
+
+ (if (not (fboundp 'destructive-plist-to-alist)) ;; From XEmacs subr.el
+ (defun destructive-plist-to-alist (plist)
+ "Convert property list PLIST into the equivalent association-list form.
+ The alist is returned. This converts from
+
+ \(a 1 b 2 c 3)
+
+ into
+
+ \((a . 1) (b . 2) (c . 3))
+
+ The original plist is destroyed in the process of constructing the alist.
+ See also `plist-to-alist'."
+ (let ((head plist)
+ next)
+ (while plist
+ ;; remember the next plist pair.
+ (setq next (cddr plist))
+ ;; make the cons holding the property value into the alist element.
+ (setcdr (cdr plist) (cadr plist))
+ (setcar (cdr plist) (car plist))
+ ;; reattach into alist form.
+ (setcar plist (cdr plist))
+ (setcdr plist next)
+ (setq plist next))
+ head)))
+
+ ;;; Interface functions
+
+ (defun imap-server-opened (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (and imap-process
+ (member (process-status imap-process) '(open run)))))
+
+ (defun imap-close-server (&optional buffer autologout)
+ "Logout if needed and close down the process. Clean out buffer.
+ Ensure all `imap-locals' are local and reset them to their default
+ values such that the buffer will be suitable for opening a new server."
+ ;; What is this for???
+ (setq buffer (get-buffer (or buffer (current-buffer))))
+ (when buffer
+ (with-current-buffer buffer
+ (mapc 'make-variable-buffer-local imap-locals) ; just in case
+ (when imap-process
+ (and (member (process-status imap-process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process imap-process))
+ (mapc (lambda (local) (set local (default-value local))) imap-locals)
+ (erase-buffer)
+ t)))
+
+ (defun imap-current-server (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ imap-current-server))
+
+ (defun imap-authenticate-login (server &optional buffer)
+ "Login to server using the LOGIN command."
+ (with-current-buffer (or buffer (current-buffer))
+ (and (imap-authinfo-get server)
+ (imap-ok-p (imap-send-command-wait
+ (concat "LOGIN " (car imap-authinfo)
+ " " (cdr imap-authinfo)))))))
+
+ (defun imap-authenticate-cram-md5 (server &optional buffer)
+ "Login to server using the AUTH CRAM-MD5 method."
+ (require 'mel-b) ;; from TM/FLIM
+ (require 'hmac)
+ (require 'md5)
+ (with-current-buffer (or buffer (current-buffer))
+ (and (imap-authinfo-get server)
+ (or (imap-capability-get) (imap-send-command-wait "CAPABILITY"))
+ (memq 'AUTH=CRAM-MD5 (imap-capability-get))
+ (imap-ok-p
+ (imap-send-command-wait
+ (list
+ "AUTHENTICATE CRAM-MD5"
+ (lambda (challenge)
+ (let* ((decoded (base64-decode-string challenge))
+ (hmaced (hmac 'md5 64 16 (cdr imap-authinfo) decoded))
+ (response (concat (car imap-authinfo) " " hmaced))
+ (encoded (base64-encode-string response)))
+ encoded))))))))
+
+ (defun imap-authenticate (server &optional buffer)
+ (when imap-do-login
+ (with-current-buffer (or buffer (current-buffer))
+ (if imap-auth-method
+ (funcall imap-auth-method server buffer)
+ (imap-authenticate-login server buffer)))))
+
+ (defun imap-open-server (server &optional port buffer local-defs)
+ (with-current-buffer (get-buffer-create (or buffer (current-buffer)))
+ (buffer-disable-undo)
+ (imap-close-server) ; makes vars local, sets them to their defaults, erases
+ (mapc (lambda (ld) (set (car ld) (cdr ld))) local-defs)
+ (when (setq imap-process
+ (imap-open-stream "imap" (current-buffer)
+ server (or port imap-default-port)))
+ (set-marker (process-mark imap-process) (point-min))
+ (set-process-filter imap-process 'imap-arrival-filter)
+ (setq imap-current-server server)
+ ;; Give each connection a more or less unique letter just so the log
+ ;; is easy to read
+ (setq imap-tag-char (int-char (+ (char-int ?A)
+ (% imap-connection-number 26))))
+ (setq imap-connection-number (1+ imap-connection-number))
+ ; I really don't get this. Is it needed. If it is, does it really save
+ ; all that much time and/or effort.
+ ; (setq imap-data-folder
+ ; (make-vector imap-convenient-group-prime 0))
+ (current-buffer))))
+
+ ;; If there is a need for sending commands without a callback, then
+ ;; have `imap-send-command-wait'ing commands pass
+ ;; `imap-cb-tag-default' itself. Maybe `imap-wait-for-tag' should
+ ;; be internal. It currently doesn't accept a buffer (nor set one).
+ ;; I guess until then this is an internal command also. Use
+ ;; `imap-send-command-wait' instead.
+
+ (defun imap-send-command (command &optional buffer callback)
+ "Send a COMMAND to the server for BUFFER returning the command's TAG. If
+ BUFFER is omitted or is nil the current buffer is used. You can
+ then call `imap-wait-for-tag'. If CALLBACK is provided, then you cannot
+ call `imap-wait-for-tag'.
+
+ COMMAND may be a list of strings, buffers and/or functions which should
+ be `concat'ed together. The buffers are sent as IMAP string literals.
+ The functions accept one argument and are called with a server challenge and
+ should return the client response or \"*\" to give up."
+ (with-current-buffer (or buffer (current-buffer))
+ (setq imap-last-status nil) ; Yuck
+ (let* ((tag (format "%c%d" imap-tag-char (setq imap-tag-num (1+ imap-tag-num))))
+ (commands (append (list tag " ")
+ (if (listp command) command (list command))
+ (list imap-eol)))
+ (strings))
+ (setq imap-cb-tag-alist ;; removed by `imap-dispatch'
+ (cons (cons tag (or callback 'imap-cb-tag-default))
+ imap-cb-tag-alist))
+ (while commands
+ (while (stringp (car commands)) ; This should be easier
+ (push (car commands) strings) ; How to append without reversing???
+ (pop commands))
+ (when commands ; buffer or function
+ (cond
+ ((bufferp (car commands))
+ (push (format "{%d}%s" (with-current-buffer (car commands)
+ (buffer-size))
+ imap-eol)
+ strings))
+ ((functionp (car commands))
+ (push imap-eol strings)))
+ (setq imap-cb-tag-alist ;; removed by `imap-dispatch'
+ (cons (cons "+" 'imap-cb-tag-default) imap-cb-tag-alist)))
+ (setq strings (apply 'concat (nreverse strings)))
+ (and imap-log (with-current-buffer (get-buffer-create imap-log)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert strings)))
+ (process-send-string nil strings)
+ (setq strings nil)
+ (when commands ; buffer or function
+ ;; Waiting for "+" and bail out if we get tag.
+ (let ((data (imap-wait-for-tag "+" tag)))
+ (if (not data)
+ (setq commands nil) ; Don't bother sending the rest
+ (cond
+ ((bufferp (car commands)) ; buffer
+ (and imap-log (with-current-buffer (get-buffer-create imap-log)
+ (goto-char (point-max))
+ (insert-buffer-substring (car commands))))
+ (let ((process imap-process))
+ (with-current-buffer (car commands)
+ (process-send-region process (point-min) (point-max))))
+ (pop commands))
+ ((functionp (car commands)) ; function
+ ;; Assume function comes at the end.
+ ;; Send result of function call by prepending it to
+ ;; the list of command strings.
+ ;; The function gets removed only after the end
+ ;; of the exchange (by an `imap-wait-for-tag' bailout).
+ (setq commands
+ (cons (funcall (car commands) (car data))
+ commands))))))))
+ tag)))
+
+ (defun imap-send-command-wait (command &optional buffer)
+ "Send a COMMAND to the server for BUFFER with a new TAG, and wait for
+ the command to complete on the IMAP server before returning. If buffer is
+ omitted, the current buffer is used.
+
+ COMMAND may be a list of strings and buffers which should
+ be `concat'ed together. The buffers are sent as IMAP string literals."
+ (interactive "sCommand: ")
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-wait-for-tag (imap-send-command command))))
+
+ (defun imap-send-commands-wait (command-list &optional buffer)
+ "Send a list of commands and wait for results. Results are returned
+ in order. See `imap-send-command-wait'."
+ (with-current-buffer (or buffer (current-buffer))
+ (mapcar 'imap-wait-for-tag
+ (mapcar 'imap-send-command command-list))))
+
+ (defun imap-ok-p (status)
+ (when (and status
+ (eq 'OK (car status)))
+ (setq imap-last-status nil)
+ t))
+
+ ;;; Variable setters and getters
+
+ (defun imap-capability-get (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ imap-data-capability))
+
+ (defun imap-folder-plist (&optional folder buffer)
+ "Set PROP to VALUE for FOLDER in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (object-plist (intern (or folder
+ imap-current-folder)
+ imap-data-folder))))
+
+ (defun imap-folder-set (prop value &optional folder buffer)
+ "Set PROP to VALUE for FOLDER in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (put (intern (or folder
+ imap-current-folder)
+ imap-data-folder) prop value)))
+
+ (defun imap-folder-get (prop &optional folder buffer)
+ "Get PROP for FOLDER or the current folder in BUFFER"
+ (with-current-buffer (or buffer (current-buffer))
+ (get (intern (or folder
+ imap-current-folder) imap-data-folder) prop)))
+
+ ;;; Internal functions
+
+ (defun imap-read-passwd (prompt &rest args)
+ "Read a password using PROMPT.
+ If ARGS, PROMPT is used as an argument to `format'."
+ (let ((prompt (if args
+ (apply 'format prompt args)
+ prompt)))
+ (funcall (if (load "passwd" t)
+ 'read-passwd
+ (unless (fboundp 'ange-ftp-read-passwd)
+ (autoload 'ange-ftp-read-passwd "ange-ftp"))
+ 'ange-ftp-read-passwd) prompt)))
+
+ (defun imap-authinfo-get (server &optional buffer)
+ "Get user authentication information. Uses imap-username and/or
+ imap-password. Asks the user if necessery. If successful, sets
+ imap-authinfo to (username . password)."
+ (with-current-buffer (or buffer (current-buffer))
+ (let (user passwd)
+ (setq user (or imap-username
+ (read-from-minibuffer (concat "IMAP Name for " server
+ ": ")
+ imap-default-name)))
+ (setq passwd (or imap-password
+ (imap-read-passwd (concat "IMAP Password for " user "@"
+ server ": "))))
+ (if (and user passwd)
+ (progn
+ (setq imap-authinfo (cons user passwd))
+ t)
+ (setq imap-authinfo nil)))))
+
+ (defun imap-open-stream (name buffer host &optional port)
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (if imap-open-stream
+ (funcall imap-open-stream name buffer host port)
+ (imap-open-network-stream name buffer host port))))
+
+ (defun imap-open-network-stream (name buffer host &optional port)
+ (open-network-stream name buffer host port))
+
+ (defun imap-open-ssl-stream (name buffer host &optional port)
+ (let ((ssl-program-arguments '("-connect" (concat host ":" service)))
+ (proc (open-ssl-stream name buffer host port)))
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char (point-min))
+ (while (not (re-search-forward "^\r*\* OK" nil t))
+ (accept-process-output proc imap-timeout)
+ (goto-char (point-min)))
+ (beginning-of-line)
+ (delete-region (point-min) (point))
+ proc)))
+
+ (defun imap-open-imtest-stream (name buffer host &optional port)
+ (let ((process (start-process name (or buffer (current-buffer))
+ "imtest" "-kp" host "imap")))
+ (with-current-buffer (process-buffer process)
+ (setq imap-eol "\n")
+ (setq imap-do-login nil) ;; don't login even if kerberos auth fails
+ (when process
+ (message "Opening Kerberized IMAP connection...")
+ ;; Result of authentication is a string: __Full privacy protection__
+ (while (not (or
+ ;; if everything is ok, this will match...
+ (re-search-backward "__\\(.*\\)__\n" nil t)
+ ;; ...errors will match this
+ (re-search-backward
+ "\\. \\([^OA][^KU][^T][^H].*\\)\r\n" nil t)))
+ (accept-process-output process 5)) ; Yes, this is an oo loop
+ (let ((response (match-string 1)))
+ (erase-buffer)
+ (message "Kerberized IMAP connection: %s" response)
+ ;; If the __string__ contains "failed" authentication failed
+ ;; (imtest will bug out if you try to login the usual way, so
+ ;; close connection with an error)
+ (when (string-match "failed\\|NO\\|BAD" response)
+ (mapc 'make-variable-buffer-local imap-locals) ; just in case
+ ;; XXX logout here (can't use send-command since we don't
+ ;; have the server opened..)
+ (delete-process imap-process)
+ (mapc (lambda (local) (set local (default-value local))) imap-locals)
+ (erase-buffer)
+ (error "imtest: %s" response))))
+ process)))
+
+ (defun imap-arrival-filter (proc string)
+ "Process filter for imap process. Stow the string, then call the routines
+ to try to handle any input. We need this because we're not guaranteed to
+ receive the whole thing at once."
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-max))
+ (insert string)
+ ;; Keep a log of server tranactions in `imap-log'
+ (when imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (goto-char (point-max))
+ (insert string)))
+ (let (end)
+ ;; Find compete server line
+ (while (setq end (imap-find-next-line))
+ (save-restriction
+ ;; Restrict to it
+ (narrow-to-region (point-min) end)
+ ;; Parse and then dispatch
+ (unwind-protect (apply 'imap-dispatch (imap-parse-line))
+ ;; Delete it ensuring that the parser doesn't get out of
+ ;; sync on errors by leaving half parsed stuff around
+ (delete-region (point-min) (point-max))))))))
+
+ ;;; Callback dispatching
+
+ (defun imap-get-cb (name)
+ "Get the callback associated with the given result type, or use the default."
+ (cdr (or (assoc name imap-cb-function-alist)
+ (assoc 'default imap-cb-function-alist))))
+
+ (defun imap-dispatch (tag response &rest data)
+ "Take the parsed IMAP sludge and figure out who can deal with it. When
+ the guy is found, send it to him to process."; Tag Response Data
+ (unless (eq tag '+)
+ (apply (imap-get-cb (if (numberp response) ; Ex: * 3 EXISTS
+ (car data) ; Ex: A25 OK LOGIN
+ response)) ; Ex: * SEARCH 1 2 3
+ (cons response data))) ; allow callee to decide the number of args
+ (if (not (eq tag '*))
+ (let ((fn (assoc (symbol-name tag) imap-cb-tag-alist)))
+ (setq imap-last-status data) ; Yuck
+ (if (not fn)
+ (error "No callback for %s" (symbol-name tag))
+ (funcall (cdr fn) tag response data)
+ ;; (apply (cdr fn) (list tag response data))
+ (setq imap-cb-tag-alist
+ (remassoc (symbol-name tag) imap-cb-tag-alist))))))
+
+ ;;; IMAP Notes:
+ ;;; o RESPONSE is one of (OK NO BAD PREAUTH BYE)
+ ;;; o TAG is a unique identifier for COMMAND
+ ;;; o Response to TAG/COMMAND has matching TAG/COMMAND
+ ;;; o TEXT is an unquoted human readable string
+ ;;; o DATA is parenthesized list of lists of space separated literals or
+ ;;; quoted strings
+ ;;; o quoted strings are either {LENGTH}\r\nUNQUOTED_DATA
+ ;;; or a "" string with with '\' quoting.
+ ;;; We assume that if something need quoting the server would use {} not ""
+ ;;; o literals have no spaces and can contain '\'s.
+ ;;; o CODE is one of (TRYCREATE READ-ONLY ALERT ...)
+
+ ;;; Grammar (condensed)
+ ;;; IMAP command
+ ;;; TAG COMMAND DATA*
+ ;;; IMAP responses
+ ;;; + TEXT
+ ;;; TAG RESPONSE [CODE DATA?] COMMAND TEXT
+ ;;; * RESPONSE [CODE DATA?] TEXT
+ ;;; * WORD DATA*
+ ;;; * NUMBER WORD
+
+
+
+ ;;; Basic tokenizing and parsing
+ ;;; Well--not really. Listen up, this is sort of gross. What we do is
+ ;;; scan across the input, munching as we go. We convert anything
+ ;;; unfriendly to something friendlier (usually \ it), then use (read)
+ ;;; to gobble up the input.
+ ;;; I told you it was gross.
+
+ (defun imap-find-next-line ()
+ "Find the next available input into the buffer. This is similar to the
+ actual scanning code, except that it doesn't munch or read anything. All
+ it does is verify that there's a complete response in the buffer, and return
+ the position of the end of the response. If there is no complete response,
+ this returns nil."
+ (goto-char (point-min))
+ (let ((finished nil)
+ (jump-amount nil)
+ (return-val nil))
+ ;; We're looking for three things--
+ ;; {num} is a string literal--skip it.
+ ;; "..." is a string--skip it, too.
+ ;; CRLF is what we see (not in a string) when we're done.
+ (while (and (not finished)
+ (re-search-forward
+ "\"[^\"]*\"\\|\r\n\\|{\\([^}]+\\)}" nil t))
+ (and (match-string 1)
+ (setq jump-amount (string-to-number (match-string 1))))
+ (cond ((eq (preceding-char) ?\n)
+ (setq finished t)
+ (setq return-val (point)))
+ ((eq (preceding-char) ?\})
+ (if (< (point-max)
+ (+ (point) jump-amount 2))
+ (setq finished t)
+ (goto-char (+ (point) jump-amount 2))))))
+ return-val))
+
+ (defun imap-parse-line ()
+
+ ;; Parse one server response. We do translations to buffer so we
+ ;; can use `read'. We quote the UIDVALIDITY number to avoid 28-bit
+ ;; integer limitations. Quotes [] into {} so that things like
+ ;; BODY[HEADER] are one symbol, backslashify things, turn CRLF into
+ ;; LF. Call this at the start of the block to suck in, narrowed to
+ ;; the entirety of the block (you should know the end of it...).
+
+ ;; The only place we could have a problem is in the arbitrary TEXT
+ ;; following a status response. So we quote that first.
+
+ (let ((leave-brackets 0))
+ (goto-char (point-min))
+ (insert "(")
+ (when (re-search-forward
+ "\\=\\(\\(\\+\\)\\|[^ ]+ +\\(OK\\|NO\\|BAD\\|PREAUTH\\|BYE\\)\\( +\\[.*?\\]\\)?\\) *"
+ nil t)
+ (unless (or (match-string 2) (match-string 4))
+ (insert "[] "))
+ (setq leave-brackets (if (match-string 3) (point-marker) (point-min-marker)))
+ (save-restriction
+ (narrow-to-region (point) (- (point-max) 2))
+ (insert "\"")
+ (while (re-search-forward "\\\\\\|\"" nil 00)
+ (replace-match "\\\\\\&"))
+ (insert "\""))
+ (goto-char (point-min)))
+ (goto-char (- (point-max) 2))
+ (insert ")")
+ (goto-char (point-min))
+ (let ((finished nil)
+ (jump-amount nil))
+ (while (and (not finished)
+ (re-search-forward
+ (mapconcat 'identity
+ '("\"[^\"]*\"" ; quoted strings
+ "\\[\\|\\]" ; [] characters
+ "\\(UIDVALIDITY\\|COPYUID\\|APPENDUID\\) \\([0123456789]+\\)"
+ "\\." ; . characters
+ "\\#" ; # characters
+ "\\\\" ; \ characters
+ "\r\n" ; CRLF
+ "{\\([^}]+\\)}") ; string literals
+ "\\|") nil t)) ; regexp or
+ (and (match-string 3)
+ (setq jump-amount (string-to-number (match-string 3))))
+ (let ((pc (preceding-char)))
+ (cond ((eq pc ?\n)
+ (setq finished t))
+ ((member pc '(?\\ ?. ?#))
+ (backward-char)
+ (insert "\\")
+ (forward-char))
+ ((and (eq pc ?\[) (> (point) leave-brackets))
+ (replace-match "{"))
+ ((and (eq pc ?\]) (> (point) leave-brackets))
+ (replace-match "}"))
+ ((and (>= pc ?0)
+ (<= pc ?9))
+ ;; replace numbers too big for emacs with strings
+ (replace-match "\\1 \"\\2\""))
+ ((eq pc ?\})
+ (delete-region (match-beginning 0) (match-end 0))
+ (delete-char 2)
+ (save-restriction;; save-res is good; we change buffer size.
+ (narrow-to-region (point) (+ (point) jump-amount))
+ (insert "\"")
+ (while (re-search-forward "\\\\\\|\"" nil 00)
+ (replace-match "\\\\\\&"))
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil 00)
+ (replace-match "\n" nil t))
+ (insert "\"")))))))
+ (goto-char (point-min))
+
+ (and imap-last
+ (let ((buffer (current-buffer)))
+ (with-current-buffer (get-buffer-create imap-last)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (insert-buffer-substring buffer))))
+
+ (read (current-buffer))))
+
+ (defun imap-cb-default (&rest a)
+ (error "Default Callback Called %s" a))
+
+ (defun imap-cb-list (code taglist delim name-symbol-or-string)
+ (let ((name (if (symbolp name-symbol-or-string)
+ (symbol-name name-symbol-or-string)
+ name-symbol-or-string)))
+ (imap-folder-set 'flags taglist name)
+ (imap-folder-set 'delimiter delim name)
+ (when (eq code 'LSUB)
+ (imap-folder-set 'subbed t name))))
+
+ (defun imap-cb-flags (code flags)
+ (imap-folder-set 'list-flags flags))
+
+ (defun imap-message-to-string (message)
+ (if (numberp message)
+ (format "\\%s" message)
+ message))
+
+ (defun imap-message-plist (id &optional buffer)
+ "Set PROP to VALUE for message ID in buffer."
+ (with-current-buffer (or buffer (current-buffer))
+ (object-plist (intern (imap-message-plist id) imap-message-data))))
+
+ (defun imap-message-map (func prop &optional buffer)
+ "Call (func UID VALUE) for each message in `imap-message-data'.
+ VALUE is the value of PROP for each message."
+ (with-current-buffer (or buffer (current-buffer))
+ (mapatoms
+ (lambda (s)
+ (funcall func (get s 'UID) (get s prop)))
+ imap-message-data)))
+
+ (defun imap-message-set (id prop value &optional buffer)
+ "Set PROP to VALUE for message ID in buffer."
+ (with-current-buffer (or buffer (current-buffer))
+ (put (intern (imap-message-to-string id) imap-message-data) prop value)))
+
+ (defun imap-message-get (id prop &optional buffer)
+ "Get PROP for message ID in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (get (intern (imap-message-to-string id) imap-message-data) prop)))
+
+ ; Fetches MUST include (UID) otherwise we can't store the results.
+ ; NUM is always the logical message number not the UID. We ignore it.
+ (defun imap-cb-fetch (num fetch data)
+ "Set `imap-current-message', Set all of the prop/value pairs
+ in `imap-message-data'."
+ ; (check-valid-plist data) ; Remove me when you have confidence???
+ (setq data (destructive-plist-to-alist data))
+ ;; All fetches should have used UID FETCH so UID should exist.
+ ;; UID STORE will not have a UID in the data, in this case the UID is num
+ (setq imap-current-message (or (cdr (assoc 'UID data)) num))
+ (mapc (lambda (c) (imap-message-set imap-current-message (car c) (cdr c)))
+ data))
+
+ (defun imap-cb-search (search &rest found)
+ ;; For some reason found doesn't have parens so we need the &rest
+ (imap-folder-set 'search found))
+
+ (defun imap-cb-capability (code &rest capabilities)
+ (setq imap-data-capability capabilities))
+
+ (defun imap-cb-acl (code group &rest acls)
+ (imap-folder-set 'acl acls (symbol-name group)))
+
+ (defun imap-cb-status (code folder statuses)
+ ; (check-valid-plist statuses)
+ (mapc (lambda (c) (imap-folder-set (car c) (cdr c) (symbol-name folder)))
+ (destructive-plist-to-alist statuses)))
+
+ (defun imap-cb-numbered (number code) ; These are just numbers not UIDs
+ (cond ((eq 'EXISTS code)
+ (imap-folder-set 'EXISTS number))
+ ((eq 'RECENT code)
+ (imap-folder-set 'RECENT number))))
+
+ (defun imap-cb-bye (bye nothing string)
+ "Called on BYE. This is most likely an autologout. Clean up."
+ ;; Do something here???
+ )
+
+ (defun imap-cb-response (response code string)
+ (setq code (append code '()))
+ (let ((var (car code))
+ (value (cadr code)))
+ ;; missing NEWNAME, PARSE
+ (when var
+ (cond ((equal var 'ALERT)
+ (y-or-n-p (concat "IMAP: ALERT! " string)))
+ ((equal var 'APPENDUID)
+ (imap-folder-set 'appenduid (cons value (caddr code))))
+ ((equal var 'PERMANENTFLAGS)
+ (imap-folder-set 'permanentflags (mapcar 'symbol-name value)))
+ ((equal var 'READ-ONLY)
+ (imap-folder-set 'writable nil))
+ ((equal var 'READ-WRITE)
+ (imap-folder-set 'writable t))
+ ((equal var 'TRYCREATE)
+ (message "IMAP: %s %s" code string))
+ ((equal var 'UIDNEXT)
+ (imap-folder-set 'uidnext value))
+ ((equal var 'UNSEEN)
+ (imap-folder-set 'unseen value))
+ ((equal var 'UIDVALIDITY) ; We should wipe cache clean here only???
+ (imap-folder-set 'uidvalidity value))
+ ((equal var 'COPYUID)
+ (imap-folder-set 'copyuid value))
+ (t (error "IMAP: Unknown response code: %s %s" code string))))))
+
+ (defun imap-cb-tag-default (tag response data)
+ "This will put args on `imap-cb-finished-tags' for `imap-wait-for-tag'."
+ (let ((stats (list response data)))
+ (setq imap-cb-finished-tags (cons (cons (symbol-name tag) stats)
+ imap-cb-finished-tags))))
+
+ (defun imap-wait-for-tag (tag &optional bail)
+ "Wait for TAG to complete by calling `imap-cb-tag-default' and return
+ its args. Stop waiting if BAIL is seen"
+ (let (data bailed)
+ (while (when (not (or (setq data (assoc tag imap-cb-finished-tags))
+ (setq bailed (assoc bail imap-cb-finished-tags))))
+ ;; timeout after imap-timeout seconds with no data
+ (accept-process-output imap-process imap-timeout)))
+ (unless (or data bailed)
+ (message "IMAP: Timed out waiting for %s" tag))
+ (when (or data bailed)
+ (setq imap-cb-finished-tags (remassoc tag imap-cb-finished-tags))
+ (cdr data))))
+
+ (provide 'imap)
Index: nnimap/imap4rev1.el
diff -c nnimap/imap4rev1.el:1.26 nnimap/imap4rev1.el:removed
*** nnimap/imap4rev1.el:1.26 Thu Aug 20 03:29:06 1998
--- nnimap/imap4rev1.el Sun Aug 23 05:22:17 1998
***************
*** 1,915 ****
- ;;; imap.el --- IMAP library for emacs
-
- ;;; Copyright (C) 1998 Simon Josefsson
- ;;; Copyright (C) 1998 Jim Radford
- ;;; Copyright (C) 1997 John McClary Prevost
-
- ;;; This program 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 of the License, or
- ;;; (at your option) any later version.
-
- ;;; This program 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 this program; if not, write to the Free Software
- ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
- ;;; Commentary:
-
- ;;; This file provides a low level interface to an IMAP server.
- ;;; It provides functions to send commands and wait for responses.
- ;;; The results are parsed into lisp expressions and returned.
- ;;; IMAP untagged responses are stuffed in to obarrays based on
- ;;; the current group. All the parameter variables become local
- ;;; to the IMAP process buffer.
-
- ;;; Todo:
- ;;; On expunge, remove messages from message-data. Note it doesn't
- ;;; return UIDs. Ouch.
-
- (eval-when-compile (require 'cl))
-
- (eval-and-compile
- (autoload 'open-ssl-stream "ssl")
- (unless (fboundp 'open-network-stream)
- (require 'tcp)))
-
- ;;; External variables
-
- (defvar imap-default-port 143
- "*Default port number to be used for IMAP connections. This should
- probably be \"imap\", but a lot of machines lack the services entry.
-
- This can be overrided by the server definition imap-port, and is the
- prefered way of specifying this.")
-
- (defvar imap-convenient-group-prime 2999
- "*A convenient prime which will be used to set the size of the group hash.
- We have a lot of groups at CMU, so this should probably be adjusted down.")
-
- (defvar imap-convenient-folder-prime 997
- "*A convenient prime which will be used to set the size of the folder
- (message) hash.")
-
- (defvar imap-open-stream nil
- "*The name of a function to use for opening an imap stream. Defaults on
- nil to open a networked stream to the server.
-
- Examples; imap-open-imtest-stream, imap-open-ssl-stream.
-
- This can be overrided by the server definition imap-open-stram, and
- this is the prefered way of specifying this.")
-
- (defvar imap-auth-method nil
- "*The name of a function to use for loging on to the server. Defaults on
- nil to plain text logins using the LOGIN command.
-
- Examples; imap-authenticate-cram-md5.
-
- This can be overried by the server definition imap-auth-method, and
- this is the prefered way of specifying this.")
-
- (defvar imap-eol "\r\n"
- "*The string sent to end a command.")
-
- ;; remove?
- (defvar imap-default-name nil
- "*Your name, should you choose to accept it.")
-
- (defvar imap-last-status nil
- "*Status returned by last IMAP command")
-
- (defvar imap-timeout 20
- "*Timeout in seconds to wait for server response.")
-
- (defvar imap-username nil
- "Username for server. ")
-
- (defvar imap-password nil
- "Password for server.")
-
- ;;; Internal variables
-
- (defvar imap-authinfo nil
- "Buffer local variable which contains (user . password) for server.")
-
- (defvar imap-process nil
- "The active process for the current IMAP buffer.")
-
- (defvar imap-data-capability nil
- "Current server's capability list")
-
- (defvar imap-data-folder nil
- "Obarray which contains group information.")
-
- (defvar imap-cb-finished-tags '()
- "Alist of tags which are completed but not yet handled.")
-
- (defvar imap-message-data nil
- "Obarray which contains current message cache.")
-
- (defvar imap-current-folder nil
- "Name of the current folder")
-
- (defvar imap-current-message nil
- "Symbol of current message.")
-
- (defvar imap-current-server nil
- "Name of current server machine.")
-
- (defvar imap-tag-num 0
- "Number for tag increment.")
-
- (defvar imap-tag-char ?A
- "Unique tag char per connection.")
-
- (defvar imap-connection-number 0
- "Unique tag char per connection.")
-
- (defvar imap-do-login t
- "Wheter imap-authenticate should try to log in or not.
-
- This is normally only turned off by a `imap-open-stream' that does
- it's own authentication.")
-
- (defvar imap-cb-function-alist '((OK . imap-cb-response)
- (NO . imap-cb-response)
- (BAD . imap-cb-response)
- (PREAUTH . imap-cb-response)
- (BYE . imap-cb-bye)
- (EXISTS . imap-cb-numbered)
- (EXPUNGE . imap-cb-numbered)
- (RECENT . imap-cb-numbered)
- (CAPABILITY . imap-cb-capability)
- (LIST . imap-cb-list)
- (LSUB . imap-cb-list)
- (FLAGS . imap-cb-flags)
- (FETCH . imap-cb-fetch)
- (SEARCH . imap-cb-search)
- (STATUS . imap-cb-status)
- (ACL . imap-cb-acl)
- (default . imap-cb-default))
- "Alist of IMAP code to function callbacks.")
-
- (defvar imap-cb-tag-alist '()
- "Alist of tags to callbacks for tagged responses.")
-
- (defvar imap-locals '(imap-cb-finished-tags
- imap-cb-tag-alist
- imap-current-folder
- imap-current-message
- imap-current-server
- imap-data-capability
- imap-data-folder
- imap-open-stream
- imap-auth-method
- imap-do-login
- imap-message-data
- imap-default-name
- imap-authinfo
- imap-last-status
- imap-process
- imap-tag-num
- imap-tag-char
- imap-eol)
- "A list the variables that define an individual imap connection.
- They are reset from their `default-value's . You can pass values for
- any of these to `imap-open-server'.")
-
-
- ;; If non nil these hold the name of a buffer to put debug into
- (defvar imap-log "*imap-log*") ; imap session trace
- (defvar imap-last "*imap-last*") ; last line we attempted to parse
- (defvar imap-debug "*imap-debug*") ; random debug spew
-
- (when imap-debug ; (untrace-all)
- (require 'trace)
- (buffer-disable-undo (get-buffer-create imap-debug))
- (mapc (lambda (f) (trace-function-background f imap-debug))
- '(imap-open-server
- imap-close-server
- imap-server-opened
- imap-select-mailbox
- imap-send-command
- imap-send-command-wait
- imap-send-commands-wait
- ; imap-ok-p
- imap-wait-for-tag
- imap-capability-get
- imap-authinfo-get
- imap-folder-set
- imap-folder-get
- imap-folder-plist
- imap-dispatch
- imap-authenticate
- imap-authenticate-login
- imap-authenticate-cram-md5
- imap-message-set
- imap-message-get
- imap-message-map
- imap-message-plist
- imap-cb-response
- imap-cb-bye
- imap-cb-numbered
- imap-cb-capability
- imap-cb-list
- imap-cb-flags
- imap-cb-fetch
- imap-cb-search
- imap-cb-status
- imap-cb-default)))
-
- ;;; Compatibility
-
- (or (fboundp 'char-int)
- (fset 'char-int (symbol-function 'identity)))
-
- (or (fboundp 'int-char)
- (fset 'int-char (symbol-function 'identity)))
-
- (if (not (fboundp 'remassoc))
- (defun 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 (remassoc key (cdr alist)))
- alist))))
-
- (if (not (fboundp 'save-current-buffer))
- (defmacro save-current-buffer (&rest body)
- "Save the current buffer; execute BODY; restore the current buffer.
- Executes BODY just like `progn'."
- (` (let ((orig-buffer (current-buffer)))
- (unwind-protect
- (progn (,@ body))
- (set-buffer orig-buffer))))))
-
- (if (not (fboundp 'with-current-buffer))
- (defmacro with-current-buffer (buffer &rest body)
- "Execute the forms in BODY with BUFFER as the current buffer.
- The value returned is the value of the last form in BODY.
- See also `with-temp-buffer'."
- `(save-current-buffer
- (set-buffer ,buffer)
- ,@body)))
-
- (if (not (fboundp 'destructive-plist-to-alist)) ;; From XEmacs subr.el
- (defun destructive-plist-to-alist (plist)
- "Convert property list PLIST into the equivalent association-list form.
- The alist is returned. This converts from
-
- \(a 1 b 2 c 3)
-
- into
-
- \((a . 1) (b . 2) (c . 3))
-
- The original plist is destroyed in the process of constructing the alist.
- See also `plist-to-alist'."
- (let ((head plist)
- next)
- (while plist
- ;; remember the next plist pair.
- (setq next (cddr plist))
- ;; make the cons holding the property value into the alist element.
- (setcdr (cdr plist) (cadr plist))
- (setcar (cdr plist) (car plist))
- ;; reattach into alist form.
- (setcar plist (cdr plist))
- (setcdr plist next)
- (setq plist next))
- head)))
-
- ;;; Interface functions
-
- (defun imap-server-opened (&optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (and imap-process
- (member (process-status imap-process) '(open run)))))
-
- (defun imap-close-server (&optional buffer autologout)
- "Logout if needed and close down the process. Clean out buffer.
- Ensure all `imap-locals' are local and reset them to their default
- values such that the buffer will be suitable for opening a new server."
- ;; What is this for???
- (setq buffer (get-buffer (or buffer (current-buffer))))
- (when buffer
- (with-current-buffer buffer
- (mapc 'make-variable-buffer-local imap-locals) ; just in case
- (when imap-process
- (and (member (process-status imap-process) '(open run))
- (imap-send-command-wait "LOGOUT"))
- (delete-process imap-process))
- (mapc (lambda (local) (set local (default-value local))) imap-locals)
- (erase-buffer)
- t)))
-
- (defun imap-current-server (&optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- imap-current-server))
-
- (defun imap-authenticate-login (server &optional buffer)
- "Login to server using the LOGIN command."
- (with-current-buffer (or buffer (current-buffer))
- (and (imap-authinfo-get server)
- (imap-ok-p (imap-send-command-wait
- (concat "LOGIN " (car imap-authinfo)
- " " (cdr imap-authinfo)))))))
-
- (defun imap-authenticate-cram-md5 (server &optional buffer)
- "Login to server using the AUTH CRAM-MD5 method."
- (require 'mel-b) ;; from TM/FLIM
- (require 'hmac)
- (require 'md5)
- (with-current-buffer (or buffer (current-buffer))
- (and (imap-authinfo-get server)
- (or (imap-capability-get) (imap-send-command-wait "CAPABILITY"))
- (memq 'AUTH=CRAM-MD5 (imap-capability-get))
- (imap-ok-p
- (imap-send-command-wait
- (list
- "AUTHENTICATE CRAM-MD5"
- (lambda (challenge)
- (let* ((decoded (base64-decode-string challenge))
- (hmaced (hmac 'md5 64 16 (cdr imap-authinfo) decoded))
- (response (concat (car imap-authinfo) " " hmaced))
- (encoded (base64-encode-string response)))
- encoded))))))))
-
- (defun imap-authenticate (server &optional buffer)
- (when imap-do-login
- (with-current-buffer (or buffer (current-buffer))
- (if imap-auth-method
- (funcall imap-auth-method server buffer)
- (imap-authenticate-login server buffer)))))
-
- (defun imap-open-server (server &optional port buffer local-defs)
- (with-current-buffer (get-buffer-create (or buffer (current-buffer)))
- (buffer-disable-undo)
- (imap-close-server) ; makes vars local, sets them to their defaults, erases
- (mapc (lambda (ld) (set (car ld) (cdr ld))) local-defs)
- (when (setq imap-process
- (imap-open-stream "imap" (current-buffer)
- server (or port imap-default-port)))
- (set-marker (process-mark imap-process) (point-min))
- (set-process-filter imap-process 'imap-arrival-filter)
- (setq imap-current-server server)
- ;; Give each connection a more or less unique letter just so the log
- ;; is easy to read
- (setq imap-tag-char (int-char (+ (char-int ?A)
- (% imap-connection-number 26))))
- (setq imap-connection-number (1+ imap-connection-number))
- ; I really don't get this. Is it needed. If it is, does it really save
- ; all that much time and/or effort.
- ; (setq imap-data-folder
- ; (make-vector imap-convenient-group-prime 0))
- (current-buffer))))
-
- ;; If there is a need for sending commands without a callback, then
- ;; have `imap-send-command-wait'ing commands pass
- ;; `imap-cb-tag-default' itself. Maybe `imap-wait-for-tag' should
- ;; be internal. It currently doesn't accept a buffer (nor set one).
- ;; I guess until then this is an internal command also. Use
- ;; `imap-send-command-wait' instead.
-
- (defun imap-send-command (command &optional buffer callback)
- "Send a COMMAND to the server for BUFFER returning the command's TAG. If
- BUFFER is omitted or is nil the current buffer is used. You can
- then call `imap-wait-for-tag'. If CALLBACK is provided, then you cannot
- call `imap-wait-for-tag'.
-
- COMMAND may be a list of strings, buffers and/or functions which should
- be `concat'ed together. The buffers are sent as IMAP string literals.
- The functions accept one argument and are called with a server challenge and
- should return the client response or \"*\" to give up."
- (with-current-buffer (or buffer (current-buffer))
- (setq imap-last-status nil) ; Yuck
- (let* ((tag (format "%c%d" imap-tag-char (setq imap-tag-num (1+ imap-tag-num))))
- (commands (append (list tag " ")
- (if (listp command) command (list command))
- (list imap-eol)))
- (strings))
- (setq imap-cb-tag-alist ;; removed by `imap-dispatch'
- (cons (cons tag (or callback 'imap-cb-tag-default))
- imap-cb-tag-alist))
- (while commands
- (while (stringp (car commands)) ; This should be easier
- (push (car commands) strings) ; How to append without reversing???
- (pop commands))
- (when commands ; buffer or function
- (cond
- ((bufferp (car commands))
- (push (format "{%d}%s" (with-current-buffer (car commands)
- (buffer-size))
- imap-eol)
- strings))
- ((functionp (car commands))
- (push imap-eol strings)))
- (setq imap-cb-tag-alist ;; removed by `imap-dispatch'
- (cons (cons "+" 'imap-cb-tag-default) imap-cb-tag-alist)))
- (setq strings (apply 'concat (nreverse strings)))
- (and imap-log (with-current-buffer (get-buffer-create imap-log)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert strings)))
- (process-send-string nil strings)
- (setq strings nil)
- (when commands ; buffer or function
- ;; Waiting for "+" and bail out if we get tag.
- (let ((data (imap-wait-for-tag "+" tag)))
- (if (not data)
- (setq commands nil) ; Don't bother sending the rest
- (cond
- ((bufferp (car commands)) ; buffer
- (and imap-log (with-current-buffer (get-buffer-create imap-log)
- (goto-char (point-max))
- (insert-buffer-substring (car commands))))
- (let ((process imap-process))
- (with-current-buffer (car commands)
- (process-send-region process (point-min) (point-max))))
- (pop commands))
- ((functionp (car commands)) ; function
- ;; Assume function comes at the end.
- ;; Send result of function call by prepending it to
- ;; the list of command strings.
- ;; The function gets removed only after the end
- ;; of the exchange (by an `imap-wait-for-tag' bailout).
- (setq commands
- (cons (funcall (car commands) (car data))
- commands))))))))
- tag)))
-
- (defun imap-send-command-wait (command &optional buffer)
- "Send a COMMAND to the server for BUFFER with a new TAG, and wait for
- the command to complete on the IMAP server before returning. If buffer is
- omitted, the current buffer is used.
-
- COMMAND may be a list of strings and buffers which should
- be `concat'ed together. The buffers are sent as IMAP string literals."
- (interactive "sCommand: ")
- (with-current-buffer (or buffer (current-buffer))
- (imap-wait-for-tag (imap-send-command command))))
-
- (defun imap-send-commands-wait (command-list &optional buffer)
- "Send a list of commands and wait for results. Results are returned
- in order. See `imap-send-command-wait'."
- (with-current-buffer (or buffer (current-buffer))
- (mapcar 'imap-wait-for-tag
- (mapcar 'imap-send-command command-list))))
-
- (defun imap-ok-p (status)
- (when (and status
- (eq 'OK (car status)))
- (setq imap-last-status nil)
- t))
-
- ;;; Variable setters and getters
-
- (defun imap-capability-get (&optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- imap-data-capability))
-
- (defun imap-folder-plist (&optional folder buffer)
- "Set PROP to VALUE for FOLDER in BUFFER."
- (with-current-buffer (or buffer (current-buffer))
- (object-plist (intern (or folder
- imap-current-folder)
- imap-data-folder))))
-
- (defun imap-folder-set (prop value &optional folder buffer)
- "Set PROP to VALUE for FOLDER in BUFFER."
- (with-current-buffer (or buffer (current-buffer))
- (put (intern (or folder
- imap-current-folder)
- imap-data-folder) prop value)))
-
- (defun imap-folder-get (prop &optional folder buffer)
- "Get PROP for FOLDER or the current folder in BUFFER"
- (with-current-buffer (or buffer (current-buffer))
- (get (intern (or folder
- imap-current-folder) imap-data-folder) prop)))
-
- ;;; Internal functions
-
- (defun imap-read-passwd (prompt &rest args)
- "Read a password using PROMPT.
- If ARGS, PROMPT is used as an argument to `format'."
- (let ((prompt (if args
- (apply 'format prompt args)
- prompt)))
- (funcall (if (load "passwd" t)
- 'read-passwd
- (unless (fboundp 'ange-ftp-read-passwd)
- (autoload 'ange-ftp-read-passwd "ange-ftp"))
- 'ange-ftp-read-passwd) prompt)))
-
- (defun imap-authinfo-get (server &optional buffer)
- "Get user authentication information. Uses imap-username and/or
- imap-password. Asks the user if necessery. If successful, sets
- imap-authinfo to (username . password)."
- (with-current-buffer (or buffer (current-buffer))
- (let (user passwd)
- (setq user (or imap-username
- (read-from-minibuffer (concat "IMAP Name for " server
- ": ")
- imap-default-name)))
- (setq passwd (or imap-password
- (imap-read-passwd (concat "IMAP Password for " user "@"
- server ": "))))
- (if (and user passwd)
- (progn
- (setq imap-authinfo (cons user passwd))
- t)
- (setq imap-authinfo nil)))))
-
- (defun imap-open-stream (name buffer host &optional port)
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (if imap-open-stream
- (funcall imap-open-stream name buffer host port)
- (imap-open-network-stream name buffer host port))))
-
- (defun imap-open-network-stream (name buffer host &optional port)
- (open-network-stream name buffer host port))
-
- (defun imap-open-ssl-stream (name buffer host &optional port)
- (let ((ssl-program-arguments '("-connect" (concat host ":" service)))
- (proc (open-ssl-stream name buffer host port)))
- (save-excursion
- (set-buffer buffer)
- (goto-char (point-min))
- (while (not (re-search-forward "^\r*\* OK" nil t))
- (accept-process-output proc imap-timeout)
- (goto-char (point-min)))
- (beginning-of-line)
- (delete-region (point-min) (point))
- proc)))
-
- (defun imap-open-imtest-stream (name buffer host &optional port)
- (let ((process (start-process name (or buffer (current-buffer))
- "imtest" "-kp" host "imap")))
- (with-current-buffer (process-buffer process)
- (setq imap-eol "\n")
- (setq imap-do-login nil) ;; don't login even if kerberos auth fails
- (when process
- (message "Opening Kerberized IMAP connection...")
- ;; Result of authentication is a string: __Full privacy protection__
- (while (not (or
- ;; if everything is ok, this will match...
- (re-search-backward "__\\(.*\\)__\n" nil t)
- ;; ...errors will match this
- (re-search-backward
- "\\. \\([^OA][^KU][^T][^H].*\\)\r\n" nil t)))
- (accept-process-output process 5)) ; Yes, this is an oo loop
- (let ((response (match-string 1)))
- (erase-buffer)
- (message "Kerberized IMAP connection: %s" response)
- ;; If the __string__ contains "failed" authentication failed
- ;; (imtest will bug out if you try to login the usual way, so
- ;; close connection with an error)
- (when (string-match "failed\\|NO\\|BAD" response)
- (mapc 'make-variable-buffer-local imap-locals) ; just in case
- ;; XXX logout here (can't use send-command since we don't
- ;; have the server opened..)
- (delete-process imap-process)
- (mapc (lambda (local) (set local (default-value local))) imap-locals)
- (erase-buffer)
- (error "imtest: %s" response))))
- process)))
-
- (defun imap-arrival-filter (proc string)
- "Process filter for imap process. Stow the string, then call the routines
- to try to handle any input. We need this because we're not guaranteed to
- receive the whole thing at once."
- (with-current-buffer (process-buffer proc)
- (goto-char (point-max))
- (insert string)
- ;; Keep a log of server tranactions in `imap-log'
- (when imap-log
- (with-current-buffer (get-buffer-create imap-log)
- (goto-char (point-max))
- (insert string)))
- (let (end)
- ;; Find compete server line
- (while (setq end (imap-find-next-line))
- (save-restriction
- ;; Restrict to it
- (narrow-to-region (point-min) end)
- ;; Parse and then dispatch
- (unwind-protect (apply 'imap-dispatch (imap-parse-line))
- ;; Delete it ensuring that the parser doesn't get out of
- ;; sync on errors by leaving half parsed stuff around
- (delete-region (point-min) (point-max))))))))
-
- ;;; Callback dispatching
-
- (defun imap-get-cb (name)
- "Get the callback associated with the given result type, or use the default."
- (cdr (or (assoc name imap-cb-function-alist)
- (assoc 'default imap-cb-function-alist))))
-
- (defun imap-dispatch (tag response &rest data)
- "Take the parsed IMAP sludge and figure out who can deal with it. When
- the guy is found, send it to him to process."; Tag Response Data
- (unless (eq tag '+)
- (apply (imap-get-cb (if (numberp response) ; Ex: * 3 EXISTS
- (car data) ; Ex: A25 OK LOGIN
- response)) ; Ex: * SEARCH 1 2 3
- (cons response data))) ; allow callee to decide the number of args
- (if (not (eq tag '*))
- (let ((fn (assoc (symbol-name tag) imap-cb-tag-alist)))
- (setq imap-last-status data) ; Yuck
- (if (not fn)
- (error "No callback for %s" (symbol-name tag))
- (funcall (cdr fn) tag response data)
- ;; (apply (cdr fn) (list tag response data))
- (setq imap-cb-tag-alist
- (remassoc (symbol-name tag) imap-cb-tag-alist))))))
-
- ;;; IMAP Notes:
- ;;; o RESPONSE is one of (OK NO BAD PREAUTH BYE)
- ;;; o TAG is a unique identifier for COMMAND
- ;;; o Response to TAG/COMMAND has matching TAG/COMMAND
- ;;; o TEXT is an unquoted human readable string
- ;;; o DATA is parenthesized list of lists of space separated literals or
- ;;; quoted strings
- ;;; o quoted strings are either {LENGTH}\r\nUNQUOTED_DATA
- ;;; or a "" string with with '\' quoting.
- ;;; We assume that if something need quoting the server would use {} not ""
- ;;; o literals have no spaces and can contain '\'s.
- ;;; o CODE is one of (TRYCREATE READ-ONLY ALERT ...)
-
- ;;; Grammar (condensed)
- ;;; IMAP command
- ;;; TAG COMMAND DATA*
- ;;; IMAP responses
- ;;; + TEXT
- ;;; TAG RESPONSE [CODE DATA?] COMMAND TEXT
- ;;; * RESPONSE [CODE DATA?] TEXT
- ;;; * WORD DATA*
- ;;; * NUMBER WORD
-
-
-
- ;;; Basic tokenizing and parsing
- ;;; Well--not really. Listen up, this is sort of gross. What we do is
- ;;; scan across the input, munching as we go. We convert anything
- ;;; unfriendly to something friendlier (usually \ it), then use (read)
- ;;; to gobble up the input.
- ;;; I told you it was gross.
-
- (defun imap-find-next-line ()
- "Find the next available input into the buffer. This is similar to the
- actual scanning code, except that it doesn't munch or read anything. All
- it does is verify that there's a complete response in the buffer, and return
- the position of the end of the response. If there is no complete response,
- this returns nil."
- (goto-char (point-min))
- (let ((finished nil)
- (jump-amount nil)
- (return-val nil))
- ;; We're looking for three things--
- ;; {num} is a string literal--skip it.
- ;; "..." is a string--skip it, too.
- ;; CRLF is what we see (not in a string) when we're done.
- (while (and (not finished)
- (re-search-forward
- "\"[^\"]*\"\\|\r\n\\|{\\([^}]+\\)}" nil t))
- (and (match-string 1)
- (setq jump-amount (string-to-number (match-string 1))))
- (cond ((eq (preceding-char) ?\n)
- (setq finished t)
- (setq return-val (point)))
- ((eq (preceding-char) ?\})
- (if (< (point-max)
- (+ (point) jump-amount 2))
- (setq finished t)
- (goto-char (+ (point) jump-amount 2))))))
- return-val))
-
- (defun imap-parse-line ()
-
- ;; Parse one server response. We do translations to buffer so we
- ;; can use `read'. We quote the UIDVALIDITY number to avoid 28-bit
- ;; integer limitations. Quotes [] into {} so that things like
- ;; BODY[HEADER] are one symbol, backslashify things, turn CRLF into
- ;; LF. Call this at the start of the block to suck in, narrowed to
- ;; the entirety of the block (you should know the end of it...).
-
- ;; The only place we could have a problem is in the arbitrary TEXT
- ;; following a status response. So we quote that first.
-
- (let ((leave-brackets 0))
- (goto-char (point-min))
- (insert "(")
- (when (re-search-forward
- "\\=\\(\\(\\+\\)\\|[^ ]+ +\\(OK\\|NO\\|BAD\\|PREAUTH\\|BYE\\)\\( +\\[.*?\\]\\)?\\) *"
- nil t)
- (unless (or (match-string 2) (match-string 4))
- (insert "[] "))
- (setq leave-brackets (if (match-string 3) (point-marker) (point-min-marker)))
- (save-restriction
- (narrow-to-region (point) (- (point-max) 2))
- (insert "\"")
- (while (re-search-forward "\\\\\\|\"" nil 00)
- (replace-match "\\\\\\&"))
- (insert "\""))
- (goto-char (point-min)))
- (goto-char (- (point-max) 2))
- (insert ")")
- (goto-char (point-min))
- (let ((finished nil)
- (jump-amount nil))
- (while (and (not finished)
- (re-search-forward
- (mapconcat 'identity
- '("\"[^\"]*\"" ; quoted strings
- "\\[\\|\\]" ; [] characters
- "\\(UIDVALIDITY\\|COPYUID\\|APPENDUID\\) \\([0123456789]+\\)"
- "\\." ; . characters
- "\\#" ; # characters
- "\\\\" ; \ characters
- "\r\n" ; CRLF
- "{\\([^}]+\\)}") ; string literals
- "\\|") nil t)) ; regexp or
- (and (match-string 3)
- (setq jump-amount (string-to-number (match-string 3))))
- (let ((pc (preceding-char)))
- (cond ((eq pc ?\n)
- (setq finished t))
- ((member pc '(?\\ ?. ?#))
- (backward-char)
- (insert "\\")
- (forward-char))
- ((and (eq pc ?\[) (> (point) leave-brackets))
- (replace-match "{"))
- ((and (eq pc ?\]) (> (point) leave-brackets))
- (replace-match "}"))
- ((and (>= pc ?0)
- (<= pc ?9))
- ;; replace numbers too big for emacs with strings
- (replace-match "\\1 \"\\2\""))
- ((eq pc ?\})
- (delete-region (match-beginning 0) (match-end 0))
- (delete-char 2)
- (save-restriction;; save-res is good; we change buffer size.
- (narrow-to-region (point) (+ (point) jump-amount))
- (insert "\"")
- (while (re-search-forward "\\\\\\|\"" nil 00)
- (replace-match "\\\\\\&"))
- (goto-char (point-min))
- (while (search-forward "\r\n" nil 00)
- (replace-match "\n" nil t))
- (insert "\"")))))))
- (goto-char (point-min))
-
- (and imap-last
- (let ((buffer (current-buffer)))
- (with-current-buffer (get-buffer-create imap-last)
- (buffer-disable-undo)
- (erase-buffer)
- (insert-buffer-substring buffer))))
-
- (read (current-buffer))))
-
- (defun imap-cb-default (&rest a)
- (error "Default Callback Called %s" a))
-
- (defun imap-cb-list (code taglist delim name-symbol-or-string)
- (let ((name (if (symbolp name-symbol-or-string)
- (symbol-name name-symbol-or-string)
- name-symbol-or-string)))
- (imap-folder-set 'flags taglist name)
- (imap-folder-set 'delimiter delim name)
- (when (eq code 'LSUB)
- (imap-folder-set 'subbed t name))))
-
- (defun imap-cb-flags (code flags)
- (imap-folder-set 'list-flags flags))
-
- (defun imap-message-to-string (message)
- (if (numberp message)
- (format "\\%s" message)
- message))
-
- (defun imap-message-plist (id &optional buffer)
- "Set PROP to VALUE for message ID in buffer."
- (with-current-buffer (or buffer (current-buffer))
- (object-plist (intern (imap-message-plist id) imap-message-data))))
-
- (defun imap-message-map (func prop &optional buffer)
- "Call (func UID VALUE) for each message in `imap-message-data'.
- VALUE is the value of PROP for each message."
- (with-current-buffer (or buffer (current-buffer))
- (mapatoms
- (lambda (s)
- (funcall func (get s 'UID) (get s prop)))
- imap-message-data)))
-
- (defun imap-message-set (id prop value &optional buffer)
- "Set PROP to VALUE for message ID in buffer."
- (with-current-buffer (or buffer (current-buffer))
- (put (intern (imap-message-to-string id) imap-message-data) prop value)))
-
- (defun imap-message-get (id prop &optional buffer)
- "Get PROP for message ID in BUFFER."
- (with-current-buffer (or buffer (current-buffer))
- (get (intern (imap-message-to-string id) imap-message-data) prop)))
-
- ; Fetches MUST include (UID) otherwise we can't store the results.
- ; NUM is always the logical message number not the UID. We ignore it.
- (defun imap-cb-fetch (num fetch data)
- "Set `imap-current-message', Set all of the prop/value pairs
- in `imap-message-data'."
- ; (check-valid-plist data) ; Remove me when you have confidence???
- (setq data (destructive-plist-to-alist data))
- ;; All fetches should have used UID FETCH so UID should exist.
- ;; UID STORE will not have a UID in the data, in this case the UID is num
- (setq imap-current-message (or (cdr (assoc 'UID data)) num))
- (mapc (lambda (c) (imap-message-set imap-current-message (car c) (cdr c)))
- data))
-
- (defun imap-cb-search (search &rest found)
- ;; For some reason found doesn't have parens so we need the &rest
- (imap-folder-set 'search found))
-
- (defun imap-cb-capability (code &rest capabilities)
- (setq imap-data-capability capabilities))
-
- (defun imap-cb-acl (code group &rest acls)
- (imap-folder-set 'acl acls (symbol-name group)))
-
- (defun imap-cb-status (code folder statuses)
- ; (check-valid-plist statuses)
- (mapc (lambda (c) (imap-folder-set (car c) (cdr c) (symbol-name folder)))
- (destructive-plist-to-alist statuses)))
-
- (defun imap-cb-numbered (number code) ; These are just numbers not UIDs
- (cond ((eq 'EXISTS code)
- (imap-folder-set 'EXISTS number))
- ((eq 'RECENT code)
- (imap-folder-set 'RECENT number))))
-
- (defun imap-cb-bye (bye nothing string)
- "Called on BYE. This is most likely an autologout. Clean up."
- ;; Do something here???
- )
-
- (defun imap-cb-response (response code string)
- (setq code (append code '()))
- (let ((var (car code))
- (value (cadr code)))
- ;; missing NEWNAME, PARSE
- (when var
- (cond ((equal var 'ALERT)
- (y-or-n-p (concat "IMAP: ALERT! " string)))
- ((equal var 'APPENDUID)
- (imap-folder-set 'appenduid (cons value (caddr code))))
- ((equal var 'PERMANENTFLAGS)
- (imap-folder-set 'permanentflags (mapcar 'symbol-name value)))
- ((equal var 'READ-ONLY)
- (imap-folder-set 'writable nil))
- ((equal var 'READ-WRITE)
- (imap-folder-set 'writable t))
- ((equal var 'TRYCREATE)
- (message "IMAP: %s %s" code string))
- ((equal var 'UIDNEXT)
- (imap-folder-set 'uidnext value))
- ((equal var 'UNSEEN)
- (imap-folder-set 'unseen value))
- ((equal var 'UIDVALIDITY) ; We should wipe cache clean here only???
- (imap-folder-set 'uidvalidity value))
- ((equal var 'COPYUID)
- (imap-folder-set 'copyuid value))
- (t (error "IMAP: Unknown response code: %s %s" code string))))))
-
- (defun imap-cb-tag-default (tag response data)
- "This will put args on `imap-cb-finished-tags' for `imap-wait-for-tag'."
- (let ((stats (list response data)))
- (setq imap-cb-finished-tags (cons (cons (symbol-name tag) stats)
- imap-cb-finished-tags))))
-
- (defun imap-wait-for-tag (tag &optional bail)
- "Wait for TAG to complete by calling `imap-cb-tag-default' and return
- its args. Stop waiting if BAIL is seen"
- (let (data bailed)
- (while (when (not (or (setq data (assoc tag imap-cb-finished-tags))
- (setq bailed (assoc bail imap-cb-finished-tags))))
- ;; timeout after imap-timeout seconds with no data
- (accept-process-output imap-process imap-timeout)))
- (unless (or data bailed)
- (message "IMAP: Timed out waiting for %s" tag))
- (when (or data bailed)
- (setq imap-cb-finished-tags (remassoc tag imap-cb-finished-tags))
- (cdr data))))
-
- (provide 'imap4rev1)
--- 0 ----
Index: nnimap/manual.html
diff -c nnimap/manual.html:1.6 nnimap/manual.html:1.7
*** nnimap/manual.html:1.6 Wed Aug 19 15:35:30 1998
--- nnimap/manual.html Sun Aug 23 05:18:58 1998
***************
*** 1,9 ****
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<html> <head>
! <title>Installation and configuration instructions for nnimap</title>
</head>
<body bgcolor=white>
! <h1>Installation and configuration instructions for nnimap</h1>
<p><hr>
--- 1,9 ----
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<html> <head>
! <title>Installation, configuration and usage instructions for nnimap</title>
</head>
<body bgcolor=white>
! <h1>Installation, configuration and usage instructions for nnimap</h1>
<p><hr>
***************
*** 16,27 ****
<li><a href="#install">Installing nnimap</a>
<li><a href="#config">Configuring nnimap</a>
<ul>
! <li><a href="#config-server-address">nnimap-server-address</a>
! <li><a href="#config-server-port">nnimap-server-port</a>
! <li><a href="#config-list-pattern">nnimap-list-pattern</a>
! <li><a href="#config-auth-method">nnimap-auth-method</a>
! <li><a href="#configkrb">Configuring for kerberos</a>
! <li><a href="#configssl">Configuring for ssl</a>
</ul>
<li><a href="#using">Using nnimap</a>
<ul>
--- 16,32 ----
<li><a href="#install">Installing nnimap</a>
<li><a href="#config">Configuring nnimap</a>
<ul>
! <li><a href="#config-authinfo">Automatic logins using ~/.authinfo</a>
! <li><a href="#config-server">Server variables</a>
! <ul>
! <li><a href="#config-server-address">nnimap-server-address</a>
! <li><a href="#config-server-port">nnimap-server-port</a>
! <li><a href="#config-list-method">nnimap-list-method</a>
! <li><a href="#config-list-pattern">nnimap-list-pattern</a>
! <li><a href="#config-auth-method">nnimap-auth-method</a>
! </ul>
! <li><a href="#config-krb">Required programs for kerberos</a>
! <li><a href="#config-ssl">Required programs for ssl</a>
</ul>
<li><a href="#using">Using nnimap</a>
<ul>
***************
*** 38,43 ****
--- 43,49 ----
<li><a href="#trix-verbose">Getting verbose information</a>
<li><a href="#trix-summary">Showing article length in the summary buffer</a>
<li><a href="#trix-caching">Article caching</a>
+ <li><a href="#trix-portfwd">Automatic logins against a server with multiple servers</a>
</ul>
</ul>
***************
*** 48,54 ****
<p>Download the archive and unpack it.
<pre>
! host$ tar xfz nnimap.tar.gz
</pre>
<p>This will create a directory nnimap-X/ which contain all files. X is the current version number.
--- 54,60 ----
<p>Download the archive and unpack it.
<pre>
! $ tar xfz nnimap.tar.gz
</pre>
<p>This will create a directory nnimap-X/ which contain all files. X is the current version number.
***************
*** 99,117 ****
<p>(For information about the cyrus public IMAP server, there is more information <a href="http://andrew2.andrew.cmu.edu/cyrus/cyrustest.html">available</a>.)
! <p>Description of server variables:
<h4><a name="config-server-address">nnimap-server-address</a></h4>
! Hostname or IP address of IMAP server to use. Defaults to the Gnus server name ("dada" and "yoyo" in the examples above) unless specified.
<h4><a name="config-server-port">nnimap-server-port</a></h4>
Port on server to contact. Defaults to 143.
<h4><a name="config-list-pattern">nnimap-list-pattern</a></h4>
! String or list of strings of mailboxes to limit available groups to. This has two uses.
<p>First, as shown in the example, limiting the number of mailboxes you're interested in on a server with very many mailboxes.
--- 105,153 ----
<p>(For information about the cyrus public IMAP server, there is more information <a href="http://andrew2.andrew.cmu.edu/cyrus/cyrustest.html">available</a>.)
! <h3><a name="config-authinfo">Automatic logins using ~/.authinfo</a></h3>
!
! <p>Tired of telling nnimap about your username/password all the time? The New and Improved Gnus, Gnus series 5.6.x that is, can do this for you.
!
! <p>Unfortunely, you still have to tell it your username/password once. Whee, what a bugger. A bigger bugger (huh?) however is that you have to store the password clear-text in a file. Depending on your level of paranoia you may or may not want to do this.
!
! <p>Anyway, nnimap looks for a file ~/.authinfo (<code>nnimap-authinfo-file</code>) which contains the username/password. This file follows the old "netrc" format.
!
! <p>Example <code>~/.authinfo</code> file:
!
! <p><pre>
! machine mail.server login arne password aDd12xX1
! default login anonymous password arne@domain.org
! </pre>
!
! <h3><a name="config-server">Server variables</a></h3>
<h4><a name="config-server-address">nnimap-server-address</a></h4>
! <p>Hostname or IP address of IMAP server to use. Defaults to the Gnus server name ("dada" and "yoyo" in the examples above) unless specified.
<h4><a name="config-server-port">nnimap-server-port</a></h4>
Port on server to contact. Defaults to 143.
+ <h4><a name="config-list-method">nnimap-list-method</a></h4>
+
+ <p>When listing mailboxes on the server, the IMAP protocol has two commands. "LIST", the default in nnimap, lists all mailboxes (limited by <code>nnimap-list-pattern</code>). "LSUB" lists all subscribed mailboxes.
+
+ <p>Currently nnimap does not support server side subscribing/unsubscribing so the natural choice is "LIST". However, if you have subscribed to interesting mailboxes using another IMAP client you could take advantage of this selection by telling nnimap to use it.
+
+ <p>Example:
+
+ <p><pre>
+ (setq gnus-secondary-select-methods
+ '((nnimap "nana"
+ (nnimap-server-address "mail.server")
+ (nnimap-list-method "LSUB"))))
+ </pre>
+
<h4><a name="config-list-pattern">nnimap-list-pattern</a></h4>
! <p>String or list of strings of mailboxes to limit available groups to. This has two uses.
<p>First, as shown in the example, limiting the number of mailboxes you're interested in on a server with very many mailboxes.
***************
*** 119,125 ****
<p>The string can also be a cons of REFERENCE and the string as above, what REFERENCE is used for is server specific, but on the UWash server you can specify the directory to use. Another example:
! <p><code>("INBOX" "Mail/*" "alt.sex.*" ("~friend/Mail/" . "list/*"))</code>
<!--
<p>Some reports indicate that MS Exchange also requires a REFERENCE value, the semantic is unknown but it didn't work with a nil reference (no groups were returned on LIST). Try this:
--- 155,168 ----
<p>The string can also be a cons of REFERENCE and the string as above, what REFERENCE is used for is server specific, but on the UWash server you can specify the directory to use. Another example:
! <p>Example:
!
! <p><pre>
! (setq gnus-secondary-select-methods
! '((nnimap "nana"
! (nnimap-server-address "mail.server")
! (nnimap-list-pattern ("INBOX" "Mail/*" "alt.sex.*" ("~friend/Mail/" . "list/*"))))))
! </pre>
<!--
<p>Some reports indicate that MS Exchange also requires a REFERENCE value, the semantic is unknown but it didn't work with a nil reference (no groups were returned on LIST). Try this:
***************
*** 140,159 ****
<dt>login
<dd>Force plain text password LOGIN.
<dt>cram-md5
! <dd>Force CRAM MD5 authentication.
<dt>kerberos4
! <dd>Force KERBEROS_V4 authentication. See <a href="#configkrb">Configuring for kerberos</a> for further notes.
<dt>ssl
! <dd>Force SSL encryption. See <a href="#configssl">Configuring for SSL</a> for further notes.
</dl>
! <h3><a name="configkrb">Configuring for kerberos</a></h3>
! <p>For Kerberos authentication and encryption you need to have the external program "imtest" (comes with <a href="http://andrew2.andrew.cmu.edu/cyrus/">Cyrus IMAPD</a>) in your path, and also <a href="#config-auth-method">configure nnimap-auth-method</a> accordingly.
! <h3><a name="configssl">Configuring for ssl</a></h3>
! <p>For SSL encryption you need to have the external program "s_client" (comes with SSLeay) in your path, and also <a href="#config-auth-method">configure nnimap-auth-method</a> accordingly.
<p><b>Note!</b> If you get SSL to work, please send me a note! I have not been able to verify that this work.
--- 183,211 ----
<dt>login
<dd>Force plain text password LOGIN.
<dt>cram-md5
! <dd>Force CRAM MD5 authentication. <b>Note!</b> Requires (X)Emacs 20.x.
<dt>kerberos4
! <dd>Force KERBEROS_V4 authentication. See <a href="#config-krb">Required programs for kerberos</a> for further notes.
<dt>ssl
! <dd>Force SSL encryption. See <a href="#config-ssl">Required programs for SSL</a> for further notes.
</dl>
! <p>Example:
! <p><pre>
! (setq gnus-secondary-select-methods
! '((nnimap "nana"
! (nnimap-server-address "mail.server")
! (nnimap-auth-method kerberos4))))
! </pre>
!
! <h3><a name="config-krb">Required programs for kerberos</a></h3>
! <p>For Kerberos authentication and encryption you need to have the external program "imtest" (comes with <a href="http://andrew2.andrew.cmu.edu/cyrus/">Cyrus IMAPD</a>) in your path.
! <h3><a name="config-ssl">Required programs for ssl</a></h3>
!
! <p>For SSL encryption you need to have the external program "s_client" (comes with <a href="http://www.ssleay.org/">SSLeay</a>) in your path.
<p><b>Note!</b> If you get SSL to work, please send me a note! I have not been able to verify that this work.
***************
*** 271,279 ****
(setq gnus-cacheable-groups "^nnimap")
</pre>
<hr>
<a href="mailto:jas@pdc.kth.se"><address>jas@pdc.kth.se</address></a>
<!-- hhmts start -->
! Last modified: Thu Aug 20 00:14:45 METDST 1998
<!-- hhmts end -->
</body> </html>
--- 323,363 ----
(setq gnus-cacheable-groups "^nnimap")
</pre>
+ <p><h3><a name="trix-portfwd">Automatic logins against a server with multiple servers</a></h3>
+
+ <p>Scenario: You want to connect to multiple IMAP servers. You've seen the X Files so you know you can't trust anyone, so you've written your own privacy/encryption suite. Using it, you've securely forwarded the connections to your IMAP servers and have them available on <code>localhost:4711</code>, <code>localhost:4712</code>, <code>localhost:4713</code> and so on.
+
+ <p>So what's the problem? Just add them to your <code>gnus-secondary-select-method</code> just as any other servers. But of course, this works.
+
+ <p>However, if you want to use <a href="#config-authinfo">automatic logins using a ~/.authinfo file</a> you'll find out that this file format doesn't support multiple services on the same host.
+
+ <p>Nnimap has solved this problem by introducing something called a "port-extended" format. I think a example will tell you what you need to do:
+
+ <p>Example, ~/.authinfo file:
+
+ <p><pre>
+ machine localhost:4711 login user1 password pw1
+ machine localhost:4712 login user2 password pw2
+ machine localhost:4713 login user3 password pw3
+ </pre>
+
+ <p>And your ~/.gnus would contain something like:
+
+ <p><pre>
+ (setq gnus-secondary-select-methods
+ '((nnimap "srv1"
+ (nnimap-server-address "localhost:4711"))
+ (nnimap "srv2"
+ (nnimap-server-address "localhost:4712"))
+ (nnimap "srv3"
+ (nnimap-server-address "localhost:4713"))))
+ </pre>
+
+ <p>Now you should be able to connect to your IMAP server securly to read your mail, which, by the way, has been sent in clear-text through the entire internet.
+
<hr>
<a href="mailto:jas@pdc.kth.se"><address>jas@pdc.kth.se</address></a>
<!-- hhmts start -->
! Last modified: Sun Aug 23 14:16:18 METDST 1998
<!-- hhmts end -->
</body> </html>
Index: nnimap/nnimap.el
diff -c nnimap/nnimap.el:1.46 nnimap/nnimap.el:1.49
*** nnimap/nnimap.el:1.46 Thu Aug 20 03:27:41 1998
--- nnimap/nnimap.el Sun Aug 23 05:19:45 1998
***************
*** 30,36 ****
;;; (nnimap-server-address "robby.caltech.edu"))))
;;; And inside Gnus, list all available groups with A A (search for
! ;;; 'nnimap')and subscribe to the mailboxes you are interested in with U.
;;; If you know the name of the mailbox, you can also use 'U'
;;; (gnus-group-unsubscribe-group) to subscribe to it (no mailbox
;;; completion here, sorry).
--- 30,36 ----
;;; (nnimap-server-address "robby.caltech.edu"))))
;;; And inside Gnus, list all available groups with A A (search for
! ;;; 'nnimap') and subscribe to the mailboxes you are interested in with U.
;;; If you know the name of the mailbox, you can also use 'U'
;;; (gnus-group-unsubscribe-group) to subscribe to it (no mailbox
;;; completion here, sorry).
***************
*** 94,100 ****
;;; o MIME
;;;
! (require 'imap4rev1)
(require 'nnoo)
(require 'nnheader)
--- 94,100 ----
;;; o MIME
;;;
! (require 'imap)
(require 'nnoo)
(require 'nnheader)
***************
*** 109,115 ****
(nnoo-declare nnimap) ; we derive from no one
! (defconst nnimap-version "nnimap 0.3.24")
(defvoo nnimap-list-pattern "*"
"*PATTERN or list of PATTERNS use to limit available groups.
--- 109,117 ----
(nnoo-declare nnimap) ; we derive from no one
! (defconst nnimap-version "nnimap 0.3.25")
!
! ;; External variables.
(defvoo nnimap-list-pattern "*"
"*PATTERN or list of PATTERNS use to limit available groups.
***************
*** 201,206 ****
--- 203,216 ----
the argument. It should return a non-nil value if it thinks that the
mail belongs in that group.")
+ (defvoo nnimap-imap-defs nil
+ "*Definitions of variables to set up in the IMAP buffer.")
+
+ (defvoo nnimap-group-list-speed 'slow ; 'fast, 'medium
+ "*If fast, do not show number of articles in the group list.
+ If medium, guess number of articles by using the UIDNEXT attribute.
+ If slow, fetch the UID of lowest/highest article.")
+
;; Authorization / Privacy variables
;; todo:
***************
*** 236,250 ****
(string :format "Password: %v")))))))
- (defvoo nnimap-imap-defs nil
- "*Definitions of variables to set up in the IMAP buffer.")
-
- (defvoo nnimap-group-list-speed 'slow ; 'fast, 'medium
- "*If fast, do not show number of articles in the group list.
- If medium, guess number of articles by using the UIDNEXT attribute.
- If slow, fetch the UID of lowest/highest article.")
-
(defvoo nnimap-group-alist nil)
(defvoo nnimap-server-buffer nil)
--- 246,253 ----
(string :format "Password: %v")))))))
+ ;; Internal variables.
(defvoo nnimap-group-alist nil)
(defvoo nnimap-server-buffer nil)
***************
*** 503,513 ****
(nnoo-status-message 'nnimap server))))))
(deffoo nnimap-request-article (article &optional group server to-buffer)
! (nnimap-request-article-part 'RFC822 article group server to-buffer))
(deffoo nnimap-request-head (article &optional group server to-buffer)
(nnimap-request-article-part 'RFC822.HEADER article group server to-buffer))
(deffoo nnimap-request-body (article &optional group server to-buffer)
! (nnimap-request-article-part 'RFC822.TEXT article group server to-buffer))
(defun nnimap-request-article-part (part article &optional
group server to-buffer)
--- 506,516 ----
(nnoo-status-message 'nnimap server))))))
(deffoo nnimap-request-article (article &optional group server to-buffer)
! (nnimap-request-article-part 'RFC822.PEEK article group server to-buffer))
(deffoo nnimap-request-head (article &optional group server to-buffer)
(nnimap-request-article-part 'RFC822.HEADER article group server to-buffer))
(deffoo nnimap-request-body (article &optional group server to-buffer)
! (nnimap-request-article-part 'RFC822.TEXT.PEEK article group server to-buffer))
(defun nnimap-request-article-part (part article &optional
group server to-buffer)
***************
*** 576,585 ****
;; C13 FETCH 1,* (UID)
;; * 1 FETCH (UID 4198)
;; C13 OK Completed
! ;; we fetch 1:* instead
(when (< 2 (length articles))
! (setq articles nil)
! (when (nnimap-ok-p (nnimap-send-command-wait "FETCH 1:* (UID"))
(imap-message-map (lambda (uid Uid)
(push uid articles)) 'UID)))
;; end of bug workaround code
--- 579,587 ----
;; C13 FETCH 1,* (UID)
;; * 1 FETCH (UID 4198)
;; C13 OK Completed
! ;; we fetch * in addition
(when (< 2 (length articles))
! (when (nnimap-ok-p (nnimap-send-command-wait "FETCH * (UID"))
(imap-message-map (lambda (uid Uid)
(push uid articles)) 'UID)))
;; end of bug workaround code
***************
*** 689,699 ****
;; C13 FETCH 1,* (UID)
;; * 1 FETCH (UID 4198)
;; C13 OK Completed
! ;; we fetch 1:* instead
(when (< 2 (length articles))
- (setq articles nil)
(when (nnimap-ok-p (nnimap-send-command-wait
! "FETCH 1:* (UID"))
(imap-message-map (lambda (uid Uid)
(push uid articles)) 'UID)))
;; end of bug workaround code
--- 691,700 ----
;; C13 FETCH 1,* (UID)
;; * 1 FETCH (UID 4198)
;; C13 OK Completed
! ;; we fetch * in addition
(when (< 2 (length articles))
(when (nnimap-ok-p (nnimap-send-command-wait
! "FETCH * (UID"))
(imap-message-map (lambda (uid Uid)
(push uid articles)) 'UID)))
;; end of bug workaround code