mirror of https://github.com/djcb/mu.git
* add some elisp to access mu server
This commit is contained in:
Dirk-Jan C. Binnema
parent
c35923b467
commit
462f5f5247
|
|
@ -0,0 +1,413 @@
|
|||
;;; mm-common.el -- part of mm, the mu mail user agent
|
||||
;;
|
||||
;; Copyright (C) 2011 Dirk-Jan C. Binnema
|
||||
|
||||
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Keywords: email
|
||||
;; Version: 0.0
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
;;
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'ido)
|
||||
|
||||
|
||||
(defun mm/eval-msg-string (str)
|
||||
"Get the plist describing an email message, from STR containing
|
||||
a message sexp.
|
||||
|
||||
a message sexp looks something like:
|
||||
\(
|
||||
:from ((\"Donald Duck\" . \"donald@example.com\"))
|
||||
:to ((\"Mickey Mouse\" . \"mickey@example.com\"))
|
||||
:subject \"Wicked stuff\"
|
||||
:date (20023 26572 0)
|
||||
:size 15165
|
||||
:references (\"200208121222.g7CCMdb80690@msg.id\")
|
||||
:in-reply-to \"200208121222.g7CCMdb80690@msg.id\"
|
||||
:message-id \"foobar32423847ef23@pluto.net\"
|
||||
:maildir: \"/archive\"
|
||||
:path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\"
|
||||
:priority high
|
||||
:flags (new unread)
|
||||
:attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\"))
|
||||
:body-txt \" <message body>\"
|
||||
\)
|
||||
other fields are :cc, :bcc, :body-html
|
||||
|
||||
When the s-expression comes from the database ('mu find'), the
|
||||
fields :attachments, :body-txt, :body-html, :references, :in-reply-to
|
||||
are missing (because that information is not stored in the
|
||||
database -- at least not in a usable way."
|
||||
(condition-case nil
|
||||
(car (read-from-string str));; read-from-string returns a cons
|
||||
(error "Failed to parse message")))
|
||||
|
||||
|
||||
(defun mm/msg-field (msg field)
|
||||
"Get a field from this message, or nil. The fields are the
|
||||
fields of the message, which are the various items of the plist
|
||||
as described in `mm/eval-msg-string'
|
||||
|
||||
There is also the special field :body (which is either :body-txt,
|
||||
or if not available, :body-html converted to text)."
|
||||
(case field
|
||||
(:body
|
||||
(let* ((body (mm/msg-field msg :body-txt))
|
||||
(body (or body (with-temp-buffer
|
||||
(mm/msg-field msg :body-html)
|
||||
(html2text)
|
||||
(buffer-string)))))))
|
||||
(t (plist-get msg field))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; converting flags->string and vice-versa ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun mm/flags-to-string (flags)
|
||||
"Remove duplicates and sort the output of `mm/flags-to-string-raw'."
|
||||
(concat
|
||||
(sort (remove-duplicates (append (mm/flags-to-string-raw flags) nil)) '>)))
|
||||
|
||||
(defun mm/flags-to-string-raw (flags)
|
||||
"Convert a list of flags into a string as seen in Maildir
|
||||
message files; flags are symbols draft, flagged, new, passed,
|
||||
replied, seen, trashed and the string is the concatenation of the
|
||||
uppercased first letters of these flags, as per [1]. Other flags
|
||||
than the ones listed here are ignored.
|
||||
|
||||
Also see `mm/flags-to-string'.
|
||||
|
||||
\[1\]: http://cr.yp.to/proto/maildir.html"
|
||||
(when flags
|
||||
(let ((kar (case (car flags)
|
||||
('draft ?D)
|
||||
('flagged ?F)
|
||||
('new ?N)
|
||||
('passed ?P)
|
||||
('replied ?R)
|
||||
('seen ?S)
|
||||
('trashed ?T)
|
||||
('encrypted ?x)
|
||||
('signed ?s)
|
||||
('unread ?u))))
|
||||
(concat (and kar (string kar))
|
||||
(mm/flags-to-string-raw (cdr flags))))))
|
||||
|
||||
|
||||
(defun mm/string-to-flags (str)
|
||||
"Remove duplicates from the output of `mm/string-to-flags-1'"
|
||||
(remove-duplicates (mm/string-to-flags-1 str)))
|
||||
|
||||
(defun mm/string-to-flags-1 (str)
|
||||
"Convert a string with message flags as seen in Maildir
|
||||
messages into a list of flags in; flags are symbols draft,
|
||||
flagged, new, passed, replied, seen, trashed and the string is
|
||||
the concatenation of the uppercased first letters of these flags,
|
||||
as per [1]. Other letters than the ones listed here are ignored.
|
||||
Also see `mu/flags-to-string'.
|
||||
|
||||
\[1\]: http://cr.yp.to/proto/maildir.html"
|
||||
(when (/= 0 (length str))
|
||||
(let ((flag
|
||||
(case (string-to-char str)
|
||||
(?D 'draft)
|
||||
(?F 'flagged)
|
||||
(?P 'passed)
|
||||
(?R 'replied)
|
||||
(?S 'seen)
|
||||
(?T 'trashed))))
|
||||
(append (when flag (list flag))
|
||||
(mm/string-to-flags-1 (substring str 1))))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; moving message files, changing flags ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun mm/move-msg (uid &optional targetdir flags ignore-already)
|
||||
"Move message identified by UID to TARGETDIR using 'mu mv', and
|
||||
update the database with the new situation. TARGETDIR must be a
|
||||
maildir - that is, the part _without_ cur/ or new/. 'mu mv' will
|
||||
calculate the target directory and the exact file name. See
|
||||
`mm/msg-map' for a discussion about UID.
|
||||
|
||||
After the file system move (rename) has been done, 'mu remove'
|
||||
and/or 'mu add' are invoked asynchronously to update the database
|
||||
with the changes.
|
||||
|
||||
Optionally, you can specify the FLAGS for the new file. The FLAGS
|
||||
parameter can have the following forms:
|
||||
1. a list of flags such as '(passed replied seen)
|
||||
2. a string containing the one-char versions of the flags, e.g. \"PRS\"
|
||||
3. a delta-string specifying the changes with +/- and the one-char flags,
|
||||
e.g. \"+S-N\" to set Seen and remove New.
|
||||
|
||||
The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or
|
||||
`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See
|
||||
`mm/string-to-flags' and `mm/flags-to-string'.
|
||||
|
||||
If TARGETDIR is '/dev/null', remove SRC. After the file system
|
||||
move, the database will be updated as well, using the 'mu add'
|
||||
and 'mu remove' commands.
|
||||
|
||||
If IGNORE-ALREADY is non-nil, don't consider it an error when the target file is
|
||||
the same as the source file.
|
||||
|
||||
Function returns t the move succeeds, in other cases, it returns
|
||||
nil.
|
||||
|
||||
\[1\] URL `http://cr.yp.to/proto/maildir.html'."
|
||||
(let* ((src (mm/msg-map-get-path uid)))
|
||||
(unless src (error "Source path not registered for %S" uid))
|
||||
(unless (or targetdir src) (error "Either targetdir or flags required"))
|
||||
(unless (file-readable-p src) (error "Source is unreadable (%S)" src))
|
||||
(let* ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))
|
||||
(argl (remove-if 'not ;; build up the arg list
|
||||
(list "mv" "--print-target" "--ignore-dups"
|
||||
(when flagstr (concat "--flags=" flagstr))
|
||||
src targetdir)))
|
||||
;; execute it, and get the results
|
||||
(rv (apply 'mm/mu-run argl))
|
||||
(code (car rv)) (output (cdr rv)))
|
||||
(unless (= 0 code) (error "Moving message failed: %S" output))
|
||||
;; success!
|
||||
(let ((targetpath (substring output 0 -1)))
|
||||
(when (and targetpath (not (string= src targetpath)))
|
||||
(mm/msg-map-update uid targetpath) ;; update the UID-map
|
||||
(mm/db-remove-async src) ;; remove the src from the db
|
||||
(unless (string= targetdir "/dev/null")
|
||||
(mm/db-add-async targetpath))) ;; add the target to the db
|
||||
(mm/db-update-execute)
|
||||
t))))
|
||||
|
||||
;;; some functions for *asyncronously* updating the database
|
||||
|
||||
(defvar mm/db-update-proc nil
|
||||
"*internal* Process for async db updates.")
|
||||
(defvar mm/db-update-name "*mm-db-update*"
|
||||
"*internal* name of the db-update process")
|
||||
(defvar mm/db-add-paths nil
|
||||
"*internal* List of message paths to add to the database.")
|
||||
(defvar mm/db-remove-paths nil
|
||||
"*internal* List of message paths to remove from the database.")
|
||||
|
||||
|
||||
(defun mm/db-update-proc-sentinel (proc msg)
|
||||
"Check the database update process upon completion."
|
||||
(let ((procbuf (process-buffer proc))
|
||||
(status (process-status proc))
|
||||
(exit-status (process-exit-status proc)))
|
||||
(when (and (buffer-live-p procbuf) (memq status '(exit signal)))
|
||||
(case status
|
||||
('signal (mm/log "Process killed"))
|
||||
('exit
|
||||
(case exit-status
|
||||
(mm/log "Result: %s" (mm/error-string exit-status))))))
|
||||
;; try to update again, maybe there are some new updates
|
||||
(mm/db-update-execute)))
|
||||
|
||||
|
||||
(defun mm/db-update-execute ()
|
||||
"Update the database; remove paths in `mm/db-remove-paths',
|
||||
and add paths in `mm/db-add-paths'. Updating is ansynchronous."
|
||||
|
||||
;; when it's already running, do nothing
|
||||
(unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run))
|
||||
(when mm/db-remove-paths
|
||||
(let ((remove-paths (copy-list mm/db-remove-paths)))
|
||||
(mm/log (concat mm/mu-binary " remove "
|
||||
(mapconcat 'identity remove-paths " ")))
|
||||
(setq mm/db-remove-paths nil) ;; clear the old list
|
||||
(setq mm/db-update-proc
|
||||
(apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary
|
||||
"remove" remove-paths))
|
||||
(set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel)))))
|
||||
|
||||
;; when it's already running, do nothing
|
||||
(unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run))
|
||||
(when mm/db-add-paths
|
||||
(let ((add-paths (copy-list mm/db-add-paths)))
|
||||
(mm/log (concat mm/mu-binary " add " (mapconcat 'identity add-paths " ")))
|
||||
(setq mm/db-add-paths nil) ;; clear the old list
|
||||
(setq mm/db-update-proc
|
||||
(apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary
|
||||
"add" add-paths))
|
||||
(set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel))))
|
||||
|
||||
(defun mm/db-add-async (path-or-paths)
|
||||
"Asynchronously add msg at PATH-OR-PATHS to
|
||||
database. PATH-OR-PATHS is either a single path or a list of them."
|
||||
(setq mm/db-add-paths
|
||||
(append mm/db-add-paths
|
||||
(if (listp path-or-paths) path-or-paths `(,path-or-paths)))))
|
||||
;; (mm/db-update-execute))
|
||||
|
||||
(defun mm/db-remove-async (path-or-paths)
|
||||
"Asynchronously remove msg at PATH-OR-PATHS from
|
||||
database. PATH-OR-PATHS is either a single path or a list of
|
||||
them."
|
||||
(setq mm/db-remove-paths
|
||||
(append mm/db-remove-paths
|
||||
(if (listp path-or-paths) path-or-paths `(,path-or-paths)))))
|
||||
;; (mm/db-update-execute))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; error codes / names ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; generated with:
|
||||
;; cat mu-util.h | sed 's/\([A-Z_]\+\).*=\(.*\),/(defconst \L\1 \2)/' < "$<" \
|
||||
;; | sed 's/_/-/g' > mu-errors.el
|
||||
(defconst mm/err 1)
|
||||
(defconst mm/err-in-parameters 2)
|
||||
(defconst mm/err-internal 3)
|
||||
(defconst mm/err-no-matches 4)
|
||||
(defconst mm/err-xapian 11)
|
||||
(defconst mm/err-xapian-query 13)
|
||||
(defconst mm/err-xapian-dir-not-accessible 14)
|
||||
(defconst mm/err-xapian-not-up-to-date 15)
|
||||
(defconst mm/err-xapian-missing-data 16)
|
||||
(defconst mm/err-xapian-corruption 17)
|
||||
(defconst mm/err-xapian-cannot-get-writelock 18)
|
||||
(defconst mm/err-gmime 30)
|
||||
(defconst mm/err-contacts 50)
|
||||
(defconst mm/err-contacts-cannot-retrieve 51)
|
||||
(defconst mm/err-file 70)
|
||||
(defconst mm/err-file-invalid-name 71)
|
||||
(defconst mm/err-file-cannot-link 72)
|
||||
(defconst mm/err-file-cannot-open 73)
|
||||
(defconst mm/err-file-cannot-read 74)
|
||||
(defconst mm/err-file-cannot-create 75)
|
||||
(defconst mm/err-file-cannot-mkdir 76)
|
||||
(defconst mm/err-file-stat-failed 77)
|
||||
(defconst mm/err-file-readdir-failed 78)
|
||||
(defconst mm/err-file-invalid-source 79)
|
||||
(defconst mm/err-file-target-equals-source 80)
|
||||
|
||||
;; TODO: use 'case' instead...
|
||||
(defun mm/error-string (err)
|
||||
"Convert an exit code from mu into a string."
|
||||
(cond
|
||||
((eql err mm/err) "General error")
|
||||
((eql err mm/err-in-parameters) "Error in parameters")
|
||||
((eql err mm/err-internal) "Internal error")
|
||||
((eql err mm/err-no-matches) "No matches")
|
||||
((eql err mm/err-xapian) "Xapian error")
|
||||
((eql err mm/err-xapian-query) "Error in query")
|
||||
((eql err mm/err-xapian-dir-not-accessible) "Database dir not accessible")
|
||||
((eql err mm/err-xapian-not-up-to-date) "Database is not up-to-date")
|
||||
((eql err mm/err-xapian-missing-data) "Missing data")
|
||||
((eql err mm/err-xapian-corruption) "Database seems to be corrupted")
|
||||
((eql err mm/err-xapian-cannot-get-writelock)"Database is locked")
|
||||
((eql err mm/err-gmime) "GMime-related error")
|
||||
((eql err mm/err-contacts) "Contacts-related error")
|
||||
((eql err mm/err-contacts-cannot-retrieve) "Failed to retrieve contacts")
|
||||
((eql err mm/err-file) "File error")
|
||||
((eql err mm/err-file-invalid-name) "Invalid file name")
|
||||
((eql err mm/err-file-cannot-link) "Failed to link file")
|
||||
((eql err mm/err-file-cannot-open) "Cannot open file")
|
||||
((eql err mm/err-file-cannot-read) "Cannot read file")
|
||||
((eql err mm/err-file-cannot-create) "Cannot create file")
|
||||
((eql err mm/err-file-cannot-mkdir) "mu-mkdir failed")
|
||||
((eql err mm/err-file-stat-failed) "stat(2) failed")
|
||||
((eql err mm/err-file-readdir-failed) "readdir failed")
|
||||
((eql err mm/err-file-invalid-source) "Invalid source file")
|
||||
((eql err mm/err-file-target-equals-source) "Source is same as target")
|
||||
(t (format "Unknown error (%d)" err))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun mm/mu-run (&rest args)
|
||||
"Run 'mu' synchronously with ARGS as command-line argument;,
|
||||
where <exit-code> is the exit code of the program, or 1 if the
|
||||
process was killed. <str> contains whatever the command wrote on
|
||||
standard output/error, or nil if there was none or in case of
|
||||
error. `mm/mu-run' is like `shell-command-to-string', but with
|
||||
better possibilities for error handling. The --muhome= parameter is
|
||||
added automatically if `mm/mu-home' is non-nil."
|
||||
(let* ((rv)
|
||||
(allargs (remove-if 'not
|
||||
(append args (when mm/mu-home (concat "--muhome=" mm/mu-home)))))
|
||||
(cmdstr (concat mm/mu-binary " " (mapconcat 'identity allargs " ")))
|
||||
(str (with-output-to-string
|
||||
(with-current-buffer standard-output ;; but we also get stderr...
|
||||
(setq rv (apply 'call-process mm/mu-binary nil t nil
|
||||
args))))))
|
||||
(mm/log "%s %s => %S" mm/mu-binary (mapconcat 'identity args " ") rv)
|
||||
(when (and (numberp rv) (/= 0 rv))
|
||||
(error (mm/error-string rv)))
|
||||
`(,(if (numberp rv) rv 1) . ,str)))
|
||||
|
||||
|
||||
(defun mm/ask-maildir (prompt &optional fullpath)
|
||||
"Ask user with PROMPT for a maildir name, if fullpath is
|
||||
non-nill, return the fulpath (i.e., `mm/maildir' prepended to the
|
||||
chosen folder)."
|
||||
(unless (and mm/inbox-folder mm/drafts-folder mm/sent-folder)
|
||||
(error "`mm/inbox-folder', `mm/drafts-folder' and
|
||||
`mm/sent-folder' must be set"))
|
||||
(unless mm/maildir (error "`mm/maildir' must be set"))
|
||||
(interactive)
|
||||
(let* ((showfolders
|
||||
(append (list mm/inbox-folder mm/drafts-folder mm/sent-folder)
|
||||
mm/working-folders))
|
||||
(chosen (ido-completing-read prompt showfolders)))
|
||||
(concat (if fullpath mm/maildir "") chosen)))
|
||||
|
||||
|
||||
(defun mm/new-buffer (bufname)
|
||||
"Return a new buffer BUFNAME; if such already exists, kill the
|
||||
old one first."
|
||||
(when (get-buffer bufname)
|
||||
(progn
|
||||
(message (format "Killing %s" bufname))
|
||||
(kill-buffer bufname)))
|
||||
(get-buffer-create bufname))
|
||||
|
||||
|
||||
(defconst mm/log-buffer-name "*mm-log*"
|
||||
"*internal* Name of the logging buffer.")
|
||||
|
||||
(defun mm/log (frm &rest args)
|
||||
"Write something in the *mm-log* buffer - mainly useful for debugging."
|
||||
(with-current-buffer (get-buffer-create mm/log-buffer-name)
|
||||
(goto-char (point-max))
|
||||
(insert (apply 'format (concat (format-time-string "%x %X " (current-time))
|
||||
frm "\n") args))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(provide 'mm-common)
|
||||
|
|
@ -0,0 +1,493 @@
|
|||
;; mm-hdrs.el -- part of mm, the mu mail user agent
|
||||
;;
|
||||
;; Copyright (C) 2011 Dirk-Jan C. Binnema
|
||||
|
||||
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Keywords: email
|
||||
;; Version: 0.0
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
;;
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; In this file are function related to creating the list of one-line
|
||||
;; descriptions of emails, aka 'headers' (not to be confused with headers like
|
||||
;; 'To:' or 'Subject:')
|
||||
|
||||
;; mu
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(require 'mm-common)
|
||||
(require 'mm-proc)
|
||||
|
||||
(defvar mm/header-fields
|
||||
'( (:date . 25)
|
||||
(:from-or-to . 22)
|
||||
(:subject . 40))
|
||||
"A list of header fields and their character widths.")
|
||||
|
||||
|
||||
;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/last-expr nil
|
||||
"*internal* The most recent search expression.")
|
||||
(defvar mm/sortfield nil
|
||||
"*internal* Field to sort headers by")
|
||||
(defvar mm/sort-descending nil
|
||||
"*internal Whether to sort in descending order")
|
||||
|
||||
|
||||
(defconst mm/hdrs-buffer-name "*headers*"
|
||||
"*internal* Name of the buffer for message headers.")
|
||||
|
||||
(defvar mm/hdrs-buffer nil
|
||||
"*internal* Buffer for message headers")
|
||||
|
||||
(defun mm/hdrs-search (expr)
|
||||
"Search in the mu database for EXPR, and switch to the output
|
||||
buffer for the results."
|
||||
(interactive "s[mu] search for: ")
|
||||
;; make sure we get a brand new buffer
|
||||
(setq mm/hdrs-buffer (mm/new-buffer mm/hdrs-buffer-name))
|
||||
(switch-to-buffer mm/hdrs-buffer)
|
||||
(mm/hdrs-mode)
|
||||
(setq mm/last-expr expr)
|
||||
(mm/msg-map-init)
|
||||
(let ((inhibit-read-only t)) (erase-buffer)) ;; FIXME -- why is this needed?!
|
||||
|
||||
;; all set -- now execute the search
|
||||
(mm/proc-find expr))
|
||||
|
||||
(defun mm/hdrs-message-handler (msg)
|
||||
(message "Received message %d (%s)"
|
||||
(plist-get msg :docid)
|
||||
(plist-get msg :subject)))
|
||||
|
||||
(defun mm/hdrs-error-handler (err)
|
||||
(message "Error %d: %s"
|
||||
(plist-get err :error)
|
||||
(plist-get err :error-message)))
|
||||
|
||||
(defun mm/hdrs-update-handler (update)
|
||||
"Update handler, will be called when we get '(:update ... )' from
|
||||
the mu server process. This function will update the current list
|
||||
of headers."
|
||||
(message "We received a database update: %S" update)
|
||||
(let* ((type (plist-get update :update)) (docid (plist-get update :docid))
|
||||
(marker (mm/msg-map-get-marker docid)))
|
||||
(unless docid (error "Invalid update %S" update))
|
||||
(unless marker (error "Message %d not found" docid))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(save-excursion
|
||||
(goto-char (marker-position marker))
|
||||
;; sanity check
|
||||
(unless (eq docid (get-text-property (point) 'docid))
|
||||
(error "Unexpected docid"))
|
||||
(mm/hdrs-mark 'unmark)
|
||||
(let ((inhibit-read-only t) (bol (line-beginning-position))
|
||||
(eol (line-beginning-position 2)))
|
||||
(case type
|
||||
(remove (put-text-property bol eol 'invisible t))
|
||||
(move (put-text-property bol eol 'face 'mm/moved-face))
|
||||
(t (error "Invalid update %S" update))))))))
|
||||
|
||||
|
||||
(defun mm/hdrs-header-handler (msg)
|
||||
"Function to insert a line for a message. This will be called by
|
||||
`mm/proc-find'. Function expects to be in the output buffer
|
||||
already."
|
||||
(let* ((docid (mm/msg-field msg :docid))
|
||||
(line (propertize (concat " " (mm/hdrs-line msg) "\n")
|
||||
'docid docid)))
|
||||
;; add message to the docid=>path map, see `mm/msg-map'.
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(mm/msg-map-add msg (point-marker))
|
||||
(let ((inhibit-read-only t))
|
||||
(insert line))))))
|
||||
|
||||
(defun mm/hdrs-line (msg)
|
||||
"Get the one-line description of MSG (as per `mm/hdrs-raw-line'), and
|
||||
apply text-properties based on the message flags."
|
||||
(let ((line (mm/hdrs-raw-line msg))
|
||||
(flags (plist-get msg :flags)))
|
||||
(cond
|
||||
((member 'unread flags) (propertize line 'face 'mm/unread-face))
|
||||
(t (propertize line 'face 'mm/header-face)))))
|
||||
|
||||
(defun mm/hdrs-raw-line (msg)
|
||||
"Create a one line description of MSG in this buffer at
|
||||
point. Line does not include a newline or any text-properties."
|
||||
(mapconcat
|
||||
(lambda (f-w)
|
||||
(let* ((field (car f-w)) (width (cdr f-w))
|
||||
(val (plist-get msg field))
|
||||
(str
|
||||
(case field
|
||||
(:subject val)
|
||||
((:to :from :cc :bcc)
|
||||
(mapconcat
|
||||
(lambda (ct)
|
||||
(let ((name (car ct)) (email (cdr ct)))
|
||||
(or name email "?"))) val ", "))
|
||||
(:date (format-time-string "%x %X" val))
|
||||
(:flags (mm/flags-to-string val))
|
||||
(:size
|
||||
(cond
|
||||
((>= val 1000000) (format "%2.1fM" (/ val 1000000.0)))
|
||||
((and (>= val 1000) (< val 1000000))
|
||||
(format "%2.1fK" (/ val 1000.0)))
|
||||
((< val 1000) (format "%d" val))))
|
||||
(t (error "Unsupported header field (%S)" field)))))
|
||||
(when str (truncate-string-to-width str width 0 ?\s t))))
|
||||
mm/header-fields " "))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/hdrs-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
||||
(define-key map "s" 'mm/search)
|
||||
(define-key map "q" 'mm/quit-buffer)
|
||||
(define-key map "o" 'mm/change-sort)
|
||||
(define-key map "g" 'mm/rerun-search)
|
||||
|
||||
;; navigation
|
||||
(define-key map "n" 'mm/next-header)
|
||||
(define-key map "p" 'mm/prev-header)
|
||||
(define-key map "j" 'mm/jump-to-maildir)
|
||||
|
||||
;; marking/unmarking/executing
|
||||
(define-key map "m" 'mm/mark-for-move)
|
||||
(define-key map "d" 'mm/mark-for-trash)
|
||||
(define-key map "D" 'mm/mark-for-delete)
|
||||
(define-key map "u" 'mm/unmark)
|
||||
(define-key map "U" 'mm/unmark-all)
|
||||
(define-key map "x" 'mm/execute-marks)
|
||||
|
||||
;; message composition
|
||||
;; (define-key map "r" 'mua/hdrs-reply)
|
||||
;; (define-key map "f" 'mua/hdrs-forward)
|
||||
;; (define-key map "c" 'mua/hdrs-compose)
|
||||
|
||||
(define-key map (kbd "RET") 'mm/view-message)
|
||||
map)
|
||||
"Keymap for *mm-headers* buffers.")
|
||||
(fset 'mm/hdrs-mode-map mm/hdrs-mode-map)
|
||||
|
||||
(defun mm/hdrs-mode ()
|
||||
"Major mode for displaying mua search results."
|
||||
(interactive)
|
||||
|
||||
(kill-all-local-variables)
|
||||
(use-local-map mm/hdrs-mode-map)
|
||||
|
||||
(make-local-variable 'mm/buf)
|
||||
(make-local-variable 'mm/last-expr)
|
||||
(make-local-variable 'mm/hdrs-proc)
|
||||
(make-local-variable 'mm/marks-map)
|
||||
(make-local-variable 'mm/msg-map)
|
||||
|
||||
;; we register our handler functions for the mm-proc (mu server) output
|
||||
(setq mm/proc-error-func 'mm/hdrs-error-handler)
|
||||
(setq mm/proc-update-func 'mm/hdrs-update-handler)
|
||||
(setq mm/proc-header-func 'mm/hdrs-header-handler)
|
||||
(setq mm/proc-message-func 'mm/hdrs-message-handler)
|
||||
|
||||
(setq
|
||||
mm/marks-map (make-hash-table :size 16 :rehash-size 2)
|
||||
major-mode 'mm/hdrs-mode
|
||||
mode-name "*mm-headers*"
|
||||
truncate-lines t
|
||||
buffer-read-only t
|
||||
overwrite-mode 'overwrite-mode-binary))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; the message map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/msg-map nil
|
||||
"*internal* A map (hashtable) which maps a database (Xapian)
|
||||
docid (which uniquely identifies a message to a marker. where
|
||||
marker points to the buffer position for the message.
|
||||
|
||||
Using this map, we can update message headers which are currently
|
||||
on the screen, when we receive (:update ) notices from the mu
|
||||
server.")
|
||||
|
||||
(defun mm/msg-map-add (msg marker)
|
||||
"Update `mm/msg-map' with MSG, and MARKER pointing to the buffer
|
||||
position for the message header."
|
||||
(let ((docid (plist-get msg :docid)))
|
||||
(unless docid (error "Invalid message"))
|
||||
(puthash docid marker mm/msg-map)))
|
||||
|
||||
(defun mm/msg-map-get-marker (docid)
|
||||
"Get the marker for the message identified by DOCID."
|
||||
(gethash docid mm/msg-map))
|
||||
|
||||
(defun mm/msg-map-init()
|
||||
"(Re)initialize the msg map for use -- re-create the hash table,
|
||||
and reset the last-uid to 0."
|
||||
(setq mm/msg-map
|
||||
(make-hash-table :size 256 :rehash-size 2 :weakness nil)))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; marks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/marks-map nil
|
||||
"Map (hash) of docid->markinfo; when a message is marked, the
|
||||
information is added here.
|
||||
|
||||
markinfo is a list consisting of the following:
|
||||
\(marker mark target)
|
||||
where
|
||||
MARKER is an emacs-textmarker pointing to the beginning of the header line
|
||||
MARK is the type of mark (move, trash, delete)
|
||||
TARGET (optional) is the target directory (for 'move')")
|
||||
|
||||
(defun mm/hdrs-mark (mark &optional target)
|
||||
"Mark (or unmark) header line at point. MARK specifies the
|
||||
mark-type. For `move'-marks there is also the TARGET argument,
|
||||
which specifies to which maildir the message is to be moved.
|
||||
|
||||
The following marks are available, and the corresponding props:
|
||||
|
||||
MARK TARGET description
|
||||
----------------------------------------------------------
|
||||
`move' y move the message to some folder
|
||||
`trash' n move the message to `mm/trash-folder'
|
||||
`delete' n remove the message
|
||||
`unmark' n unmark this message"
|
||||
(let* ((docid (get-text-property (point) 'docid))
|
||||
(markkar
|
||||
(case mark ;; the visual mark
|
||||
('move "m")
|
||||
('trash "d")
|
||||
('delete "D")
|
||||
('unmark " ")
|
||||
(t (error "Invalid mark %S" mark)))))
|
||||
(unless docid (error "No message on this line"))
|
||||
(save-excursion
|
||||
(move-beginning-of-line 1)
|
||||
|
||||
;; is there anything to mark/unmark?
|
||||
(when (and (looking-at " ") (eql mark 'unmark))
|
||||
(error "Not marked"))
|
||||
(when (not (or (looking-at " ") (eql mark 'unmark)))
|
||||
(error "Already marked"))
|
||||
|
||||
;; update the hash
|
||||
(if (eql mark 'unmark)
|
||||
(remhash docid mm/marks-map)
|
||||
(puthash docid (list (point-marker) mark target) mm/marks-map))
|
||||
|
||||
;; now, update the visual mark..;
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-char 2)
|
||||
(insert (propertize (concat markkar " ") 'docid docid))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(defun mm/hdrs-marks-execute ()
|
||||
"Execute the actions for all marked messages in this
|
||||
buffer.
|
||||
|
||||
After the actions have been executed succesfully, the affected
|
||||
messages are *hidden* from the current header list. Since the
|
||||
headers are the result of a search, we cannot be certain that the
|
||||
messages no longer matches the current one - to get that certainty,
|
||||
we need to rerun the search, but we don't want to do that
|
||||
automatically, as it may be too slow and/or break the users
|
||||
flow. Therefore, we hide the message, which in practice seems to
|
||||
work well."
|
||||
(unless (/= 0 (hash-table-count mm/marks-map))
|
||||
(error "Nothing is marked"))
|
||||
(maphash
|
||||
(lambda (docid val)
|
||||
(let* ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val))
|
||||
(ok (case mark
|
||||
(move
|
||||
(mm/proc-move-msg docid target))
|
||||
(trash
|
||||
(unless mm/maildir "`mm/maildir' not set")
|
||||
(unless mm/trash-folder "`mm/trash-folder' not set")
|
||||
(mm/proc-move-msg docid (concat mm/maildir "/" mm/trash-folder) "+T"))
|
||||
(delete
|
||||
(mm/proc-remove-msg docid)))))
|
||||
;; (when ok
|
||||
;; (save-excursion
|
||||
;; (goto-char (marker-position marker))
|
||||
;; (mm/hdrs-mark 'unmark)
|
||||
;; ;; hide the line
|
||||
;; (let ((inhibit-read-only t))
|
||||
;; (put-text-property (line-beginning-position) (line-beginning-position 2)
|
||||
;; 'invisible t))))))
|
||||
))
|
||||
mm/marks-map))
|
||||
|
||||
|
||||
(defun mm/hdrs-unmark-all ()
|
||||
"Unmark all marked messages."
|
||||
(unless (/= 0 (hash-table-count mm/marks-map))
|
||||
(error "Nothing is marked"))
|
||||
(maphash
|
||||
(lambda (docid val)
|
||||
(save-excursion
|
||||
(goto-char (marker-position (nth 0 val)))
|
||||
(mm/hdrs-mark 'unmark)))
|
||||
mm/marks-map))
|
||||
|
||||
(defun mm/hdrs-view ()
|
||||
"View message at point"
|
||||
(let ((docid (get-text-property (point) 'docid)))
|
||||
(unless docid (error "No message at point."))
|
||||
(mm/proc-view-msg docid)))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; interactive functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; TODO warn if marks exist
|
||||
(defun mm/search ()
|
||||
"Start a new mu search."
|
||||
(interactive)
|
||||
(call-interactively 'mm/hdrs-search))
|
||||
|
||||
;; TODO warn if marks exist
|
||||
;; TODO: return to previous buffer
|
||||
(defun mm/quit-buffer ()
|
||||
"Quit the current buffer."
|
||||
(interactive)
|
||||
(kill-buffer (current-buffer)))
|
||||
|
||||
;; TODO implement
|
||||
(defun mm/change-sort ()
|
||||
"Change the sorting field and/or direction."
|
||||
(interactive)
|
||||
)
|
||||
|
||||
;; TODO warn if marks exist
|
||||
(defun mm/rerun-search ()
|
||||
"Rerun the search for the last search expression; if none exists,
|
||||
do a new search."
|
||||
(interactive)
|
||||
(if mm/last-expr
|
||||
(mm/hdrs-search mm/last-expr)
|
||||
(mm/search)))
|
||||
|
||||
(defun mm/view-message ()
|
||||
"View the message at point."
|
||||
(interactive)
|
||||
(mm/hdrs-view))
|
||||
|
||||
(defun mm/next-header ()
|
||||
"Move point to the next header."
|
||||
(interactive)
|
||||
(when (or (/= 0 (forward-line 1)) (not (get-text-property (point) 'docid)))
|
||||
(error "No header after this one")))
|
||||
|
||||
(defun mm/prev-header ()
|
||||
"Move point to the previous header."
|
||||
(interactive)
|
||||
(when (or (/= 0 (forward-line -1)) (not (get-text-property (point) 'docid)))
|
||||
(error "No header before this one")))
|
||||
|
||||
(defun mm/jump-to-maildir ()
|
||||
"Show the messages in one of the standard folders."
|
||||
(interactive)
|
||||
(let ((fld (mm/ask-maildir "Jump to maildir: ")))
|
||||
(mm/hdrs-search (concat "maildir:" fld))))
|
||||
|
||||
(defun mm/mark-for-move ()
|
||||
"Mark message at point for moving to a maildir."
|
||||
(interactive)
|
||||
(let ((target (mm/ask-maildir "Target maildir for move: ")))
|
||||
(when (or (file-directory-p target)
|
||||
(and (yes-or-no-p
|
||||
(format "%s does not exist. Create now?" target))
|
||||
(mm/proc-mkdir target)))
|
||||
(mm/hdrs-mark 'move target)
|
||||
(mm/next-header))))
|
||||
|
||||
(defun mm/mark-for-trash ()
|
||||
"Mark message at point for moving to the trash
|
||||
folder (`mm/trash-folder')."
|
||||
(interactive)
|
||||
(unless mm/trash-folder (error "`mm/trash-folder' is not set"))
|
||||
(mm/hdrs-mark 'trash)
|
||||
(mm/next-header))
|
||||
|
||||
(defun mm/mark-for-delete ()
|
||||
"Mark message at point for direct deletion."
|
||||
(interactive)
|
||||
(mm/hdrs-mark 'delete)
|
||||
(mm/next-header))
|
||||
|
||||
(defun mm/unmark ()
|
||||
"Unmark message at point."
|
||||
(interactive)
|
||||
(mm/hdrs-mark 'unmark)
|
||||
(mm/next-header))
|
||||
|
||||
(defun mm/unmark-all ()
|
||||
"Unmark all messages."
|
||||
(interactive)
|
||||
(unless (/= 0 (hash-table-count mm/marks-map))
|
||||
(error "Nothing is marked"))
|
||||
(when (y-or-n-p (format "Sure you want to unmark %d message(s)?"
|
||||
(hash-table-count mm/marks-map)))
|
||||
(mm/hdrs-unmark-all)))
|
||||
|
||||
(defun mm/execute-marks ()
|
||||
"Execute the actions for the marked messages."
|
||||
(interactive)
|
||||
(unless (/= 0 (hash-table-count mm/marks-map))
|
||||
(error "Nothing is marked"))
|
||||
(when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?"
|
||||
(hash-table-count mm/marks-map)))
|
||||
(mm/hdrs-marks-execute)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
(provide 'mm-hdrs)
|
||||
|
||||
|
|
@ -0,0 +1,256 @@
|
|||
;;; mm-proc.el -- part of mm, the mu mail user agent
|
||||
;;
|
||||
;; Copyright (C) 2011 Dirk-Jan C. Binnema
|
||||
|
||||
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Keywords: email
|
||||
;; Version: 0.0
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
;;
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(require 'mm-common)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; internal vars
|
||||
|
||||
(defvar mm/mu-proc nil
|
||||
"*internal* The mu-server process")
|
||||
|
||||
(defvar mm/proc-header-func nil
|
||||
"*internal* A function called for each message returned from the
|
||||
server process; the function is passed a msg plist as argument. See
|
||||
`mm/proc-eval-server-output' for the format.")
|
||||
|
||||
(defvar mm/proc-error-func nil
|
||||
"*internal* A function called for each error returned from the
|
||||
server process; the function is passed an error plist as
|
||||
argument. See `mm/proc-eval-server-output' for the format.")
|
||||
|
||||
(defvar mm/proc-update-func nil
|
||||
"*internal* A function called for each update sexp returned from
|
||||
the server process; the function is passed an update plist as
|
||||
argument. See `mm/proc-eval-server-output' for the format.")
|
||||
|
||||
(defvar mm/proc-message-func nil
|
||||
"*internal* A function called for each message sexp returned from
|
||||
the server process. This is designed for viewing a message. See
|
||||
`mm/proc-eval-server-output' for the format.")
|
||||
|
||||
|
||||
(defconst mm/eox-mark "\n;;eox\n"
|
||||
"*internal* Marker for the end of a sexp")
|
||||
|
||||
(defvar mm/buf ""
|
||||
"*internal* Buffer for results data.")
|
||||
|
||||
(defun mm/start-proc ()
|
||||
"Start the mu server process."
|
||||
;; TODO: add version check
|
||||
(unless (file-executable-p mm/mu-binary)
|
||||
(error (format "%S is not executable" mm/mu-binary)))
|
||||
(let* ((process-connection-type nil) ;; use a pipe
|
||||
(args '("server"))
|
||||
(args (append args (when mm/mu-home
|
||||
(list (concat "--muhome=" mm/mu-home))))))
|
||||
(setq mm/mu-proc (apply 'start-process "*mu-server*" "*mu-server*"
|
||||
mm/mu-binary args))
|
||||
(when mm/mu-proc
|
||||
(set-process-filter mm/mu-proc 'mm/proc-filter)
|
||||
(set-process-sentinel mm/mu-proc 'mm/proc-sentinel))))
|
||||
|
||||
(defun mm/kill-proc ()
|
||||
"Kill the mu server process."
|
||||
(when (mm/proc-is-running)
|
||||
(let ((delete-exited-processes t))
|
||||
(kill-process mm/mu-proc)
|
||||
(setq mm/mu-proc nil))))
|
||||
|
||||
(defun mm/proc-is-running ()
|
||||
(and mm/mu-proc (eq (process-status mm/mu-proc) 'run)))
|
||||
|
||||
|
||||
(defun mm/proc-filter (proc str)
|
||||
"A process-filter for the 'mu server' output; it accumulates the
|
||||
strings into valid sexps by checking of the ';;eox' end-of-msg
|
||||
marker, and then evaluating them."
|
||||
(setq mm/buf (concat mm/buf str)) ;; update our buffer
|
||||
(let ((eox (string-match mm/eox-mark mm/buf)))
|
||||
(while eox
|
||||
;; Process the sexp in `mm/buf', and remove it if it worked and return
|
||||
;; t. If no complete sexp is found, return nil."
|
||||
(let ( (after-eox (match-end 0))
|
||||
(sexp (mm/proc-eval-server-output (substring mm/buf 0 eox))))
|
||||
;; the sexp we get can either be a message or an error
|
||||
(message "[%S]" sexp)
|
||||
(cond
|
||||
((plist-get sexp :error) (funcall mm/proc-error-func sexp))
|
||||
;; if it has :docid, it's a message; if it's dbonly prop is `t', it's
|
||||
;; a header, otherwise it's a message (for viewing)
|
||||
((eq (plist-get sexp :msgtype) 'header)
|
||||
(funcall mm/proc-header-func sexp))
|
||||
((eq (plist-get sexp :msgtype) 'view)
|
||||
(funcall mm/proc-message-func sexp))
|
||||
((plist-get sexp :update) (funcall mm/proc-update-func sexp))
|
||||
(t (message "%S" sexp)))
|
||||
;;(t (error "Unexpected data from server"))))
|
||||
(setq mm/buf (substring mm/buf after-eox)))
|
||||
(setq eox (string-match mm/eox-mark mm/buf)))))
|
||||
|
||||
(defun mm/proc-sentinel (proc msg)
|
||||
"Function that will be called when the mu-server process
|
||||
terminates."
|
||||
(let ((status (process-status proc)) (code (process-exit-status proc)))
|
||||
(setq mm/mu-proc nil)
|
||||
(setq mm/buf "") ;; clear any half-received sexps
|
||||
(cond
|
||||
((eq status 'signal)
|
||||
(message (format "mu server process received signal %d" code)))
|
||||
((eq status 'exit)
|
||||
(cond
|
||||
((eq code 11) (message "Database is locked by another process"))
|
||||
(t (message (format "mu server process ended with exit code %d" code)))))
|
||||
(t
|
||||
(message "something bad happened to the mu server process")))))
|
||||
|
||||
(defun mm/proc-eval-server-output (str)
|
||||
"Evaluate a blob of server output; the output describe either a
|
||||
message, a database update or an error.
|
||||
|
||||
An error sexp looks something like:
|
||||
|
||||
(:error 2 :error-message \"unknown command\")
|
||||
;; eox
|
||||
|
||||
a message sexp looks something like:
|
||||
|
||||
\(
|
||||
:docid 1585
|
||||
:from ((\"Donald Duck\" . \"donald@example.com\"))
|
||||
:to ((\"Mickey Mouse\" . \"mickey@example.com\"))
|
||||
:subject \"Wicked stuff\"
|
||||
:date (20023 26572 0)
|
||||
:size 15165
|
||||
:references (\"200208121222.g7CCMdb80690@msg.id\")
|
||||
:in-reply-to \"200208121222.g7CCMdb80690@msg.id\"
|
||||
:message-id \"foobar32423847ef23@pluto.net\"
|
||||
:maildir: \"/archive\"
|
||||
:path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\"
|
||||
:priority high
|
||||
:flags (new unread)
|
||||
:attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\"))
|
||||
:body-txt \" <message body>\"
|
||||
\)
|
||||
;; eox
|
||||
|
||||
a database update looks like:
|
||||
\(:update 1585 :path \"/home/user/Maildir/foo/cur/12323213:,R\")
|
||||
when a message has been moved to a new location, or
|
||||
\(:update 1585 :path \"/dev/null\")
|
||||
when it has been removed.
|
||||
|
||||
other fields are :cc, :bcc, :body-html
|
||||
|
||||
When the s-expression comes from the database ('mu find'), the
|
||||
fields :attachments, :body-txt, :body-html, :references, :in-reply-to
|
||||
are missing (because that information is not stored in the
|
||||
database).
|
||||
|
||||
On the other hand, if the information comes from the message file,
|
||||
there won't be a :docid field."
|
||||
(condition-case nil
|
||||
(car (read-from-string str));; read-from-string returns a cons
|
||||
(error "Failed to parse sexp [%S]" str)))
|
||||
|
||||
|
||||
(defun mm/proc-remove-msg (docid)
|
||||
"Remove message identified by DOCID. The results are reporter
|
||||
through either (:update ... ) or (:error ) sexp, which are handled
|
||||
my `mm/proc-update-func' and `mm/proc-error-func', respectively."
|
||||
(unless (mm/proc-is-running) (mm/start-proc))
|
||||
(when mm/mu-proc
|
||||
(process-send-string mm/mu-proc (format "remove %d\n" docid))))
|
||||
|
||||
|
||||
(defun mm/proc-find (expr)
|
||||
"Start a database query for EXPR. For each result found, a
|
||||
function is called, depending on the kind of result. The variables
|
||||
`mm/proc-header-func' and `mm/proc-error-func' contain the function
|
||||
that will be called for, resp., a message (header row) or an
|
||||
error."
|
||||
(unless (mm/proc-is-running) (mm/start-proc))
|
||||
(when mm/mu-proc
|
||||
(process-send-string mm/mu-proc (format "find %s\n" expr))))
|
||||
|
||||
|
||||
(defun mm/proc-move-msg (docid targetdir flags)
|
||||
"Move message identified by DOCID to TARGETDIR, setting FLAGS in
|
||||
the process.
|
||||
|
||||
TARGETDIR must be a maildir, that is, the part _without_ cur/ or
|
||||
new/.
|
||||
|
||||
The FLAGS parameter can have the following forms:
|
||||
1. a list of flags such as '(passed replied seen)
|
||||
2. a string containing the one-char versions of the flags, e.g. \"PRS\"
|
||||
3. a delta-string specifying the changes with +/- and the one-char flags,
|
||||
e.g. \"+S-N\" to set Seen and remove New.
|
||||
|
||||
The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or
|
||||
`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See
|
||||
`mm/string-to-flags' and `mm/flags-to-string'.
|
||||
|
||||
The server reports the results for the operation through
|
||||
`mm/proc-update-func'.
|
||||
|
||||
The results are reported through either (:update ... )
|
||||
or (:error ) sexp, which are handled my `mm/proc-update-func' and
|
||||
`mm/proc-error-func', respectively."
|
||||
(let
|
||||
((flagstr (if (stringp flags) flags (mm/flags-to-string flags))))
|
||||
(unless (and (file-directory-p targetdir) (file-writable-p targetdir))
|
||||
(error "Not a writable directory: %s" targetdir))
|
||||
|
||||
(unless (mm/proc-is-running) (mm/start-proc))
|
||||
(when mm/mu-proc
|
||||
(process-send-string mm/mu-proc
|
||||
(format "move %d %s %s\n" docid targetdir flagstr)))))
|
||||
|
||||
|
||||
(defun mm/proc-flag-msg (docid flags)
|
||||
"Set FLAGS for the message identified by DOCID."
|
||||
(let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags))))
|
||||
(unless (mm/proc-is-running) (mm/start-proc))
|
||||
(when mm/mu-proc
|
||||
(process-send-string mm/mu-proc
|
||||
(format "flag %d %s\n" docid flagstr)))))
|
||||
|
||||
|
||||
(defun mm/proc-view-msg (docid)
|
||||
"Get one particular message based on its DOCID. The result will
|
||||
be delivered to the function registered as `mm/proc-message-func'."
|
||||
(unless (mm/proc-is-running) (mm/start-proc))
|
||||
(when mm/mu-proc
|
||||
(process-send-string mm/mu-proc
|
||||
(format "view %d\n" docid))))
|
||||
|
||||
|
||||
(provide 'mm-proc)
|
||||
|
|
@ -0,0 +1,152 @@
|
|||
;;; mm.el -- part of mm, the mu mail user agent
|
||||
;;
|
||||
;; Copyright (C) 2011 Dirk-Jan C. Binnema
|
||||
|
||||
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
;; Keywords: email
|
||||
;; Version: 0.0
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
;;
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(add-to-list 'load-path "/home/djcb/Sources/mu/toys/mm")
|
||||
|
||||
(require 'mm-hdrs)
|
||||
(require 'mm-common)
|
||||
(require 'mm-proc)
|
||||
|
||||
;; Customization
|
||||
|
||||
(defgroup mm nil
|
||||
"Mm." :group 'local)
|
||||
|
||||
|
||||
(defcustom mm/mu-home nil
|
||||
"Location of the mu homedir, or nil for the default."
|
||||
:type 'directory
|
||||
:group 'mm
|
||||
:safe 'stringp)
|
||||
|
||||
(defcustom mm/mu-binary "mu"
|
||||
"Name of the mu-binary to use; if it cannot be found in your
|
||||
PATH, you can specifiy the full path."
|
||||
:type 'file
|
||||
:group 'mm
|
||||
:safe 'stringp)
|
||||
|
||||
(defcustom mm/maildir nil
|
||||
"Your Maildir directory. When `nil', mu will try to find it."
|
||||
:type 'directory
|
||||
:safe 'stringp
|
||||
:group 'mm)
|
||||
|
||||
|
||||
;; Folders
|
||||
|
||||
(defgroup mm/folders nil
|
||||
"Special folders for mm."
|
||||
:group 'mm)
|
||||
|
||||
|
||||
(defcustom mm/inbox-folder nil
|
||||
"Your Inbox folder, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/outbox-folder nil
|
||||
"Your Outbox folder, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/sent-folder nil
|
||||
"Your folder for sent messages, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/draft-folder nil
|
||||
"Your folder for draft messages, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/trash-folder nil
|
||||
"Your folder for trashed messages, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
;; Faces
|
||||
|
||||
(defgroup mm/faces nil
|
||||
"Faces used in by mm."
|
||||
:group 'mm
|
||||
:group 'faces)
|
||||
|
||||
(defface mm/unread-face
|
||||
'((t :inherit font-lock-keyword-face :bold t))
|
||||
"Face for an unread mm message header."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/moved-face
|
||||
'((t :inherit font-lock-comment-face :italic t))
|
||||
"Face for an mm message header that has been moved from the
|
||||
search results."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/header-face
|
||||
'((t :inherit default))
|
||||
"Face for an mm header without any special flags."
|
||||
:group 'deft-faces)
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; FIXME
|
||||
(setq
|
||||
mm/maildir "/home/djcb/Maildir"
|
||||
mm/inbox-folder "/inbox"
|
||||
mm/outbox-folder "/outbox"
|
||||
mm/sent-folder "/sent"
|
||||
mm/drafts-folder "/drafts"
|
||||
mm/trash-folder "/trash")
|
||||
|
||||
(defvar mm/working-folders nil)
|
||||
|
||||
(setq mm/working-folders
|
||||
'("/bulk" "/archive" "/bulkarchive" "/todo"))
|
||||
|
||||
(setq mm/header-fields
|
||||
'( (:date . 25)
|
||||
(:flags . 6)
|
||||
(:from . 22)
|
||||
(:subject . 40)))
|
||||
|
||||
;;; my stuff
|
||||
(setq mm/mu-binary "/home/djcb/Sources/mu/src/mu")
|
||||
(setq mm/mu-home "/home/djcb/.mu")
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(provide 'mm)
|
||||
Loading…
Reference in New Issue