From: Teodor Zlatanov Date: Sun, 27 Sep 2009 14:47:50 +0000 (+0000) Subject: * net/imap-hash.el: New library, see NEWS. X-Git-Tag: emacs-pretest-23.1.90~1124 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3d9942648dc039c75f23c327e48e92450e514e09;p=emacs.git * net/imap-hash.el: New library, see NEWS. * Makefile.in (ELCFILES): Add imap-hash.el. * NEWS: Mention new library imap-hash.el --- diff --git a/etc/ChangeLog b/etc/ChangeLog index e63316d2240..7795eefffa9 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2009-09-27 Teodor Zlatanov + + * NEWS: Mention new library imap-hash.el + 2009-09-22 Juanma Barranquero * NEWS: Mention new variable `help-downcase-arguments' diff --git a/etc/NEWS b/etc/NEWS index 7f4765e855c..2b5d208ec33 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -237,6 +237,8 @@ Command*'. ** js.el is a new major mode for JavaScript files. +** imap-hash.el is a new library to address IMAP mailboxes as hashtables. + * Lisp changes in Emacs 23.2 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9d12219081f..c7a24508189 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2009-09-27 Teodor Zlatanov + + * net/imap-hash.el: New library, see NEWS. + + * Makefile.in (ELCFILES): Add imap-hash.el. + 2009-09-27 Stefan Monnier * help.el (help-for-help-internal): Don't purecopy the text (bug#4560). diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 323356024d9..2011f117135 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -839,6 +839,7 @@ ELCFILES = \ $(lisp)/net/hmac-def.elc \ $(lisp)/net/hmac-md5.elc \ $(lisp)/net/imap.elc \ + $(lisp)/net/imap-hash.elc \ $(lisp)/net/ldap.elc \ $(lisp)/net/mairix.elc \ $(lisp)/net/net-utils.elc \ diff --git a/lisp/net/imap-hash.el b/lisp/net/imap-hash.el new file mode 100644 index 00000000000..5e53ddbb08b --- /dev/null +++ b/lisp/net/imap-hash.el @@ -0,0 +1,372 @@ +;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov +;; Keywords: mail + +;; 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 3 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, see . + +;;; Commentary: + +;; This module provides hashtable-like functions on top of imap.el +;; functionality. All the authentication is handled by auth-source so +;; there are no authentication options here, only the server and +;; mailbox names are needed. + +;; Create a IHT (imap-hash table) object with `imap-hash-make'. Then +;; use it with `imap-hash-map' to map a function across all the +;; messages. Use `imap-hash-get' and `imap-hash-rem' to operate on +;; individual messages. See the tramp-imap.el library in Tramp if you +;; need to see practical examples. + +;; This only works with IMAP4r1. Sorry to everyone without it, but +;; the compatibility code is too annoying and it's 2009. + +;; TODO: Use SEARCH instead of FETCH when a test is specified. List +;; available mailboxes. Don't select an invalid mailbox. + +;;; Code: + +(require 'assoc) +(require 'imap) +(require 'sendmail) ; for mail-header-separator +(require 'message) +(autoload 'auth-source-user-or-password "auth-source") + +;; retrieve these headers +(defvar imap-hash-headers + (append '(Subject From Date Message-Id References In-Reply-To Xref))) + +;; from nnheader.el +(defsubst imap-hash-remove-cr-followed-by-lf () + (goto-char (point-max)) + (while (search-backward "\r\n" nil t) + (delete-char 1))) + +;; from nnheader.el +(defun imap-hash-ms-strip-cr (&optional string) + "Strip ^M from the end of all lines in current buffer or STRING." + (if string + (with-temp-buffer + (insert string) + (imap-hash-remove-cr-followed-by-lf) + (buffer-string)) + (save-excursion + (imap-hash-remove-cr-followed-by-lf)))) + +(defun imap-hash-make (server port mailbox &optional user password ssl) + "Makes a new imap-hash object using SERVER, PORT, and MAILBOX. +SSL, USER, PASSWORD are optional. +The test is set to t, meaning all messages are considered." + (when (and server port mailbox) + (list :server server :port port :mailbox mailbox + :ssl ssl :user user :password password + :test t))) + +(defun imap-hash-p (iht) + "Checks whether IHT is a valid imap-hash." + (and + (imap-hash-server iht) + (imap-hash-port iht) + (imap-hash-mailbox iht) + (imap-hash-test iht))) + +(defmacro imap-hash-gather (uid) + `(imap-message-get ,uid 'BODYDETAIL)) + +(defmacro imap-hash-data-body (details) + `(nth 2 (nth 1 ,details))) + +(defmacro imap-hash-data-headers (details) + `(nth 2 (nth 0 ,details))) + +(defun imap-hash-get (key iht &optional refetch) + "Get the value for KEY in the imap-hash IHT. +Requires either `imap-hash-fetch' to be called beforehand +(e.g. by `imap-hash-map'), or REFETCH to be t. +Returns a list of the headers (an alist, see `imap-hash-map') and +the body of the message as a string. +Also see `imap-hash-test'." + (with-current-buffer (imap-hash-get-buffer iht) + (when refetch + (imap-hash-fetch iht nil key)) + (let ((details (imap-hash-gather key))) + (list + (imap-hash-get-headers + (imap-hash-data-headers details)) + (imap-hash-get-body + (imap-hash-data-body details)))))) + +(defun imap-hash-put (value iht &optional key) + "Put VALUE in the imap-hash IHT. Returns the new key. +If KEY is given, removes it. +VALUE can be a list of the headers (an alist, see `imap-hash-map') +and the body of the message as a string. It can also be a uid, +in which case `imap-hash-get' will be called to get the value. +Also see `imap-hash-test'." + (let ((server-buffer (imap-hash-get-buffer iht)) + (value (if (listp value) value (imap-hash-get value iht))) + newuid) + (when value + (with-temp-buffer + (funcall 'imap-hash-make-message + (nth 0 value) + (nth 1 value) + nil) + (setq newuid (nth 1 (imap-message-append + (imap-hash-mailbox iht) + (current-buffer) nil nil server-buffer))) + (when key (imap-hash-rem key iht)))) + newuid)) + +(defun imap-hash-make-message (headers body &optional overrides) + "Make a message with HEADERS and BODY suitable for `imap-append', +using `message-setup'.. +Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'." + ;; don't insert a signature no matter what + (let (message-signature) + (message-setup + (append overrides headers)) + (message-generate-headers message-required-mail-headers) + (message-remove-header "X-Draft-From") + (message-goto-body) + (insert (or (aget overrides 'body) + body + "")) + (goto-char (point-min)) + ;; TODO: make this search better + (if (search-forward mail-header-separator nil t) + (delete-region (line-beginning-position) (line-end-position)) + (error "Could not find the body separator in the encoded message!")))) + +(defun imap-hash-rem (key iht) + "Remove KEY in the imap-hash IHT. +Also see `imap-hash-test'. Requires `imap-hash-fetch' to have +been called and the imap-hash server buffer to be current, +so it's best to use it inside `imap-hash-map'. +The key will not be found on the next `imap-hash-map' call." + (with-current-buffer (imap-hash-get-buffer iht) + (imap-message-flags-add + (imap-range-to-message-set (list key)) + "\\Deleted" 'silent) + (imap-mailbox-expunge t))) + +(defun imap-hash-clear (iht) + "Remove all keys in the imap-hash IHT. +Also see `imap-hash-test'." + (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht)) + +(defun imap-hash-get-headers (text-headers) + (with-temp-buffer + (insert (or text-headers "")) + (imap-hash-remove-cr-followed-by-lf) + (mapcar (lambda (header) + (cons header + (message-fetch-field (format "%s" header)))) + imap-hash-headers))) + +(defun imap-hash-get-body (text) + (with-temp-buffer + (insert (or text "")) + (imap-hash-remove-cr-followed-by-lf) + (buffer-string))) + +(defun imap-hash-map (function iht &optional headers-only &rest messages) + "Call FUNCTION for all entries in IHT and pass it the message uid, +the headers (an alist, see `imap-hash-headers'), and the body +contents as a string. If HEADERS-ONLY is not nil, the body will be nil. +Returns results of evaluating, as would `mapcar'. +If MESSAGES are given, iterate only over those UIDs. +Also see `imap-hash-test'." + (imap-hash-fetch iht headers-only) + (let ((test (imap-hash-test iht))) + (with-current-buffer (imap-hash-get-buffer iht) + (delq nil + (imap-message-map (lambda (message ignored-parameter) + (let* ((details (imap-hash-gather message)) + (headers (imap-hash-data-headers details)) + (hlist (imap-hash-get-headers headers)) + (runit (cond + ((stringp test) + (string-match + test + (format "%s" (aget hlist 'Subject)))) + ((functionp test) + (funcall test hlist)) + ;; otherwise, return test itself + (t test)))) + ;;(debug message headers) + (when runit + (funcall function + message + (imap-hash-get-headers + headers) + (imap-hash-get-body + (imap-hash-data-body details)))))) + "UID"))))) + +(defun imap-hash-count (iht) + "Counts the number of messages in the imap-hash IHT. +Also see `imap-hash-test'. It uses `imap-hash-map' so just use that +function if you want to do more than count the elements." + (length (imap-hash-map (lambda (a b c)) iht t))) + +(defalias 'imap-hash-size 'imap-hash-count) + +(defun imap-hash-test (iht) + "Returns the test used by `imap-hash-map' for IHT. +When the test is t, any key will be a candidate. +When the test is a string, messages will be filtered on that string as a regexp +against the subject. +When the test is a function, messages will be filtered with it. +The function is passed the message headers (see `imap-hash-get-headers')." + (plist-get iht :test)) + +(defun imap-hash-server (iht) + "Returns the server used by the imap-hash IHT." + (plist-get iht :server)) + +(defun imap-hash-port (iht) + "Returns the port used by the imap-hash IHT." + (plist-get iht :port)) + +(defun imap-hash-ssl (iht) + "Returns the SSL need for the imap-hash IHT." + (plist-get iht :ssl)) + +(defun imap-hash-mailbox (iht) + "Returns the mailbox used by the imap-hash IHT." + (plist-get iht :mailbox)) + +(defun imap-hash-user (iht) + "Returns the username used by the imap-hash IHT." + (plist-get iht :user)) + +(defun imap-hash-password (iht) + "Returns the password used by the imap-hash IHT." + (plist-get iht :password)) + +(defun imap-hash-open-connection (iht) + "Open the connection used for IMAP interactions with the imap-hash IHT." + (let* ((server (imap-hash-server iht)) + (port (imap-hash-port iht)) + (ssl-need (imap-hash-ssl iht)) + (auth-need (not (and (imap-hash-user iht) + (imap-hash-password iht)))) + ;; this will not be needed if auth-need is t + (auth-info (when auth-need + (auth-source-user-or-password + '("login" "password") + server port))) + (auth-user (or (imap-hash-user iht) + (nth 0 auth-info))) + (auth-passwd (or (imap-hash-password iht) + (nth 1 auth-info))) + (imap-logout-timeout nil)) + + ;; (debug "opening server: opened+state" (imap-opened) imap-state) + ;; this is the only place where IMAP vs IMAPS matters + (if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer)) + (progn + ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state) + ;; (debug "authenticating" auth-user auth-passwd) + (if (not (imap-capability 'IMAP4rev1)) + (error "IMAP server does not support IMAP4r1, it won't work, sorry.") + (imap-authenticate auth-user auth-passwd) + (imap-id) + ;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state) + (imap-opened (current-buffer)))) + (error "Could not open the IMAP buffer")))) + +(defun imap-hash-get-buffer (iht) + "Get or create the connection buffer to be used for the imap-hash IHT." + (let* ((name (imap-hash-buffer-name iht)) + (buffer (get-buffer name))) + (if (and buffer (imap-opened buffer)) + buffer + (when buffer (kill-buffer buffer)) + (with-current-buffer (get-buffer-create name) + (setq buffer-undo-list t) + (when (imap-hash-open-connection iht) + (current-buffer)))))) + +(defun imap-hash-buffer-name (iht) + "Get the connection buffer to be used for the imap-hash IHT." + (when (imap-hash-p iht) + (let ((server (imap-hash-server iht)) + (port (imap-hash-port iht)) + (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL"))) + (format "*imap-hash/%s:%s:%s*" server port ssl-text)))) + +(defun imap-hash-fetch (iht &optional headers-only &rest messages) + "Fetch all the messages for imap-hash IHT. +Get only the headers if HEADERS-ONLY is not nil." + (with-current-buffer (imap-hash-get-buffer iht) + (let ((range (if messages + (list + (imap-range-to-message-set messages) + (imap-range-to-message-set messages)) + '("1:*" . "1,*:*")))) + + ;; (with-current-buffer "*imap-debug*" + ;; (erase-buffer)) + (imap-mailbox-unselect) + (imap-mailbox-select (imap-hash-mailbox iht)) + ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state) + ;; (setq imap-message-data (make-vector imap-message-prime 0) + (imap-fetch-safe range + (concat (format "(UID RFC822.SIZE BODY %s " + (if headers-only "" "BODY.PEEK[TEXT]")) + (format "BODY.PEEK[HEADER.FIELDS %s])" + imap-hash-headers)))))) + +(provide 'imap-hash) +;;; imap-hash.el ends here + +;; ignore, for testing only + +;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test")) +;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test")) +;;; (imap-hash-make "server1" "INBOX.mailbox2") +;;; (imap-hash-p iht) +;;; (imap-hash-get 35 iht) +;;; (imap-hash-get 38 iht) +;;; (imap-hash-get 37 iht t) +;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) +;;; (imap-hash-put (imap-hash-get 5 iht) iht) +;;; (with-current-buffer (imap-hash-get-buffer iht) (let ((uid (imap-hash-put (imap-hash-get 5 iht) iht))) (imap-hash-put uid iht uid))) +;;; (imap-hash-put (imap-hash-get 35 iht) iht) +;;; (imap-hash-make-message '((Subject . "normal")) "normal body") +;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new"))) +;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject))) +;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject))) +;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil) +;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht)) +;;; (kill-buffer (imap-hash-buffer-name iht)) +;;; (imap-hash-map 'debug iht) +;;; (imap-hash-map 'debug iht t) +;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") +;;;(imap-hash-count iht) +;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) +;;; (kill-buffer (imap-hash-buffer-name iht)) +;;; this should always return t if the server is up, automatically reopening if needed +;;; (imap-opened (imap-hash-get-buffer iht)) +;;; (imap-hash-buffer-name iht) +;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state)) +;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") +;;; (imap-hash-fetch iht nil) +;;; (imap-hash-fetch iht t) +;;; (imap-hash-fetch iht nil 1 2 3) +;;; (imap-hash-fetch iht t 1 2 3)