alx/mu4e
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* remove the mua toy emacs ui -- the action now happens in 'mm'

Browse Source
This commit is contained in:
djcb
2011-12-01 21:18:11 +02:00
parent 1a3fc04e17
commit 6b417bc947
9 changed files with 0 additions and 1910 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
toys/mua/Makefile
View File

@ -1,41 +0,0 @@
EMACS=emacs
PREFIX=/usr/local
ELS=mua.el mua-common.el mua-view.el mua-hdrs.el mua-msg.el
ELCS=$(ELS:.el=.elc)
.PHONY=install
top_srcdir=/home/djcb/src/mu/
BATCH=$(EMACS) -batch -q -no-site-file -eval \
"(setq load-path (cons (expand-file-name \".\") load-path))"
%.elc: %.el
$(BATCH) --eval '(byte-compile-file "$<")'
all: $(ELCS)
BUILT_SOURCES=mu-errors.el
mu-errors.el: ${top_srcdir}/src/mu-util.h
@cat ${top_srcdir}/src/mu-util.h \
docs: mua.info
install_lisp:
mkdir -p $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp
install -m 644 $(ELS) $(ELCS) $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp
install_docs: docs
mkdir -p $(DESTDIR)/$(PREFIX)/share/info
install -m 644 mu.info $(DESTDIR)/$(PREFIX)/share/info
install-info --info-dir=$(DESTDIR)/$(PREFIX)/share/info $(DESTDIR)/$(PREFIX)/share/info/mu.info
install: install_lisp install_docs
clean:
rm -fr mua.info $(ELCS)

32
toys/mua/TODO
View File

@ -1,32 +0,0 @@
* TODO
[ ] message un-new in find/view
[ ] set 'Replied' flag on source when message is replied
[ ] save message to draft, sent items
[ ] attachment handling (open, play) in view
[ ] fix flags in src/
[ ] version check
[ ] make add, remove async (use async buffer)
[ ] threads support
[ ] expandable recipients list in view
[ ] additive font props in mu find
[ ] fix headers/view interaction
[ ] region commands
[ ] menu
[ ] mua-dashboard
# Local Variables:
# mode: org; org-startup-folded: nil
# End:

88
toys/mua/mua-common.el
View File

@ -1,88 +0,0 @@
;;; mua-common.el -- part of mua, 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:
;; mua-common contains common utility functions for mua
;;; Code:
(eval-when-compile (require 'cl))
(require 'ido)
(defconst mua/log-buffer-name "*mua-log*" "name of the logging buffer")
(defun mua/warn (frm &rest args)
"warn user in echo-area, return nil"
(let ((str (apply 'format frm args)))
(message str)
nil))
(defun mua/log (frm &rest args)
"write something in the *mua-log* buffer - mainly useful for debugging"
(with-current-buffer (get-buffer-create mua/log-buffer-name)
(goto-char (point-max))
(insert (apply 'format (concat (format-time-string "%x %X " (current-time))
frm "\n") args))))
(defun mua/warn-and-log (frm &rest args)
"log and warn (ie., mua/warn + mua/log); return nil"
(apply 'mua/log frm args)
(apply 'mua/warn frm args)
nil)
(defun mua/new-buffer (bufname)
"return a new buffer BUFNAME; if such already exists, kill the
old one first"
(when (get-buffer bufname)
(kill-buffer bufname))
(get-buffer-create bufname))
(defun mua/message (frm &rest args)
"print a message at point"
(let ((str (apply 'format frm args)) (inhibit-read-only t))
(insert (propertize str 'face 'italic))))
(defun mua/quit-buffer ()
"kill this buffer, and switch to it's parentbuf if it is alive"
(interactive)
(let ((parentbuf mua/parent-buffer))
(kill-buffer)
(when (and parentbuf (buffer-live-p parentbuf))
(switch-to-buffer parentbuf))))
(defun mua/ask-maildir (prompt &optional fullpath)
"Ask user with PROMPT for a maildir name, if fullpath is
non-nill, return the fulpath (ie, mu-maildir prepended to the
maildir."
(interactive)
(let* ((showfolders
(append (list mua/inbox-folder mua/drafts-folder mua/sent-folder)
mua/working-folders))
(chosen (ido-completing-read prompt showfolders)))
(concat (if fullpath mua/maildir "") chosen)))
(provide 'mua-common)

491
toys/mua/mua-hdrs.el
View File

@ -1,491 +0,0 @@
;;; mua-hdrs.el -- part of mua, 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 'mua-common)
(require 'mua-msg)
;; note: these next two are *not* buffer-local, so they persist during a session
(defvar mua/hdrs-sortfield nil
"*internal* Field to sort headers by")
(defvar mua/hdrs-sort-descending nil
"*internal Whether to sort in descending order")
(defvar mua/hdrs-fields
'( (:date . 25)
(:from-or-to . 22)
(:subject . 40))
"A list of header fields and their character widths")
;; internal stuff
(defvar mua/buf ""
"*internal* Buffer for results data.")
(defvar mua/last-expression nil
"*internal* The most recent search expression.")
(defvar mua/hdrs-proc nil
"*internal* The mu-find process.")
(defconst mua/eom-mark "\n;;eom\n"
"*internal* Marker for the end of message in the mu find
output.")
(defconst mua/hdrs-buffer-name "*mua-headers*"
"*internal* Name of the mua headers buffer.")
(defun mua/hdrs-proc-filter (proc str)
"A process-filter for the 'mu find --format=sexp output; it
accumulates the strings into valid sexps by checking of the
';;eom' end-of-msg marker, and then evaluating them."
(setq mua/buf (concat mua/buf str)) ;; update our buffer
(let ((buf (process-buffer proc))) ;; check the buffer
(unless (buffer-live-p buf)
(error "No live buffer for process filter"))
(while ;; for-each-sex
;; Process the sexp in `mua/buf', and remove it if it worked and return
;; t. If no complete sexp is found, return nil."
(let ((eom (string-match mua/eom-mark mua/buf))
(after-eom (match-end 0)) (inhibit-read-only t))
(when (numberp eom) ;; was the marker found?
(with-current-buffer buf
(mua/hdrs-append-message (mua/msg-from-string
(substring mua/buf 0 eom))))
(setq mua/buf (substring mua/buf after-eom)) t)))))
(defun mua/hdrs-proc-sentinel (proc msg)
"Sentinel funtion for the mu-find process -- ie., will be called upon its ."
(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)))
(let ((msg
(case status
('signal "Search process killed (results incomplete)")
('exit
(if (= 0 exit-status)
"End of search results"
(mua/mu-error exit-status))))))
(with-current-buffer procbuf
(save-excursion
(goto-char (point-max))
(mua/message "%s" msg)))))))
(defun mua/hdrs-search-execute (expr)
"Search in the mu database, and output the results in the current
buffer."
(let* ((argl
(remove-if 'not
(list "find" "--format=sexp" "--threads"
(when mua/mu-home (concat "--muhome=" mua/mu-home))
(when mua/hdrs-sortfield
(concat "--sortfield=" mua/hdrs-sortfield))
(when mua/hdrs-sort-descending "--descending")
expr)))
(mua/buf "")
;; start the process
(proc (apply 'start-process
mua/hdrs-buffer-name (current-buffer) mua/mu-binary argl)))
(setq mua/hdrs-proc proc)
(set-process-filter proc 'mua/hdrs-proc-filter)
(set-process-sentinel proc 'mua/hdrs-proc-sentinel)
(mua/log (concat mua/mu-binary " " (mapconcat 'identity argl " ")))))
;; Note, the 'mu find --format=sexp' sexp is almost the same as the ones that
;; 'mu view --format=sexp' produces (see mu-get-message), with the difference
;; that former may give more than one result, and that mu-headers output comes
;; from the database rather than file, and does _not_ contain the message body
(defun mua/hdrs-search (expr)
"Search in the mu database for EXPR, and switch to the output
buffer for the results."
(interactive "s[mu] search for: ")
;; kill a running process if needed
(when (and mua/hdrs-proc (eq (process-status mua/hdrs-proc) 'run))
(kill-process mua/hdrs-proc))
(let ((buf (mua/new-buffer mua/hdrs-buffer-name)))
(switch-to-buffer buf)
(mua/hdrs-mode)
(mua/hdrs-search-execute expr)))
(defun mua/hdrs-mode ()
"Major mode for displaying mua search results."
(interactive)
(kill-all-local-variables)
(use-local-map mua/hdrs-mode-map)
(make-local-variable 'mua/buf)
(make-local-variable 'mua/last-expression)
(make-local-variable 'mua/hdrs-proc)
(make-local-variable 'mua/hdrs-hash)
(make-local-variable 'mua/hdrs-marks-hash)
(setq
mua/last-expression expr
mua/hdrs-marks-hash (make-hash-table :size 16 :rehash-size 2)
major-mode 'mua/mua/hdrs-mode mode-name "*mua-headers*"
truncate-lines t
buffer-read-only t
overwrite-mode 'overwrite-mode-binary))
(defun mua/hdrs-line (msg)
"Return line describing a message (ie., a header line)."
(mapconcat
(lambda(fieldpair)
(let ((field (car fieldpair)) (width (cdr fieldpair)))
(case field
(:subject (mua/hdrs-header msg :subject width))
(:to (mua/hdrs-contact msg field width))
(:from (mua/hdrs-contact msg field width))
;;(:from-or-to (mua/msg-header-header-from-or-to msg width 'mua/header-face))
(:cc (mua/hdrs-contact msg field width))
(:bcc (mua/hdrs-contact msg field width))
(:date (mua/hdrs-date msg width))
(:flags (mua/hdrs-flags msg width))
(:size (mua/hdrs-size msg width))
(t (error "Unsupported field: %S" field)))))
mua/header-fields " "))
;;
;; Note: we maintain a hash table to remember what message-path corresponds to a
;; certain line in the buffer. (mua/hdrs-set-path, mua/hdrs-get-path)
;;
;; data is stored like the following: for each header-line, we
;; take the (point) at beginning-of-line (bol) and use that as the key in the
;; mu-headers-hash hash, which does
;;
;; point-of-bol -> path
;;
(defun mua/hdrs-get-uid ()
"Get the uid for the message header at point."
(get-text-property (point) 'uid))
(defun mua/hdrs-get-path ()
"Get the current path for the header at point."
(mua/msg-map-get-path (mua/hdrs-get-uid)))
(defun mua/hdrs-append-message (msg)
"Append a one-line description of MSG to the buffer, and register
it with `mua/msg-map-add' to `mua/msg-map'; add the uid for this
message as a text-property `uid'."
(let* ((uid (mua/msg-map-add (mua/msg-field msg :path)))
(line (propertize (concat " " (mua/hdrs-line msg) "\n") 'uid uid))
(inhibit-read-only t))
(save-excursion
(goto-char (point-max))
(insert line))))
;; Now follow a bunch of function to turn some message field in a
;; string for display
(defun mua/hdrs-header (msg field width)
"Get a string at WIDTH (truncate or ' '-pad) for display as a
header."
(let* ((str (mua/msg-field msg field)) (str (if str str "")))
(propertize (truncate-string-to-width str width 0 ?\s t)
'face 'mua/header-face)))
(defun mua/hdrs-contact (msg field width)
"get display string for a list of contacts in a header, truncated for
fitting in WIDTH"
(unless (member field '(:to :from :bcc :cc))
(error "Illegal type for contact"))
(let* ((lst (mua/msg-field msg field))
(str (mapconcat
(lambda (ctc)
(let ((name (car ctc)) (email (cdr ctc)))
(or name email "?"))) lst ",")))
(propertize (truncate-string-to-width str width 0 ?\s t)
'face 'mua/contacts-face)))
(defun mua/hdrs-size (msg width)
"return a string for size of MSG of WIDTH"
(let* ((size (mua/msg-field msg :size))
((str
(cond
((>= size 1000000) (format "%2.1fM" (/ size 1000000.0)))
((and (>= size 1000) (< size 1000000)) (format "%2.1fK" (/ size 1000.0)))
((< size 1000) (format "%d" size)))))
(propertize (truncate-string-to-width str width 0 ?\s)
'face 'mua/header-face))))
(defun mua/hdrs-date (msg width)
"Return a string for the date of MSG of WIDTH."
(let* ((date (mua/msg-field msg :date)))
(if date
(propertize (truncate-string-to-width (format-time-string "%x %X" date)
width 0 ?\s) 'face 'mua/date-face))))
(defun mua/hdrs-flags (msg width)
"Return a string describing the flags of MSG at WIDTH."
(let ((flagstr (mua/msg-flags-to-string (mua/msg-field msg :flags))))
(propertize (truncate-string-to-width flagstr width 0 ?\s)
'face 'mua/header-face)))
;; some keybinding / functions for basic navigation
(defvar mua/hdrs-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "s" 'mua/hdrs-search)
(define-key map "q" 'mua/quit-buffer)
(define-key map "o" 'mua/hdrs-change-sort)
(define-key map "g" 'mua/hdrs-refresh)
;; navigation
(define-key map "n" 'mua/hdrs-next)
(define-key map "p" 'mua/hdrs-prev)
(define-key map "j" 'mua/hdrs-jump-to-maildir)
;; marking/unmarking/executing
(define-key map "m" (lambda()(interactive)(mua/hdrs-mark 'move)))
(define-key map "d" (lambda()(interactive)(mua/hdrs-mark 'trash)))
(define-key map "D" (lambda()(interactive)(mua/hdrs-mark 'delete)))
(define-key map "u" (lambda()(interactive)(mua/hdrs-mark 'unmark)))
(define-key map "U" (lambda()(interactive)(mua/hdrs-mark 'unmark-all)))
(define-key map "x" 'mua/hdrs-marks-execute)
;; 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") 'mua/hdrs-view)
map)
"Keymap for *mua-headers* buffers.")
(fset 'mua/hdrs-mode-map mua/hdrs-mode-map)
(defun mua/hdrs-next ()
"go to the next line; t if it worked, nil otherwise"
(interactive) ;; TODO: check if next line has path, if not, don't go there
(if (or (/= 0 (forward-line 1)) (not (mua/hdrs-get-path)))
(mua/warn "No message after this one")
t))
(defun mua/hdrs-prev ()
"Go to the previous line; t if it worked, nil otherwise."
(when (buffer-live-p mua/hdrs-buffer)
(with-current-buffer mua/hdrs-buffer
(if (or (/= 0 (forward-line -1)) (not (mua/hdrs-get-uid)))
(mua/warn "No message before this one")))
(when mua/view-uid ;; are we in view buffer?
(mua/view (mua/hdrs-get-uid) mua/hdrs-buffer))))
(defun mua/hdrs-view ()
(interactive)
(let ((uid (mua/hdrs-get-uid)))
(if uid
(mua/view uid (current-buffer))
(mua/warn "No message at point"))))
(defun mua/hdrs-jump-to-maildir ()
"Show the messages in one of the standard folders."
(interactive)
(let ((fld (mua/ask-maildir "Jump to maildir: ")))
(mua/hdrs-search (concat "maildir:" fld))))
(defun mua/hdrs-refresh ()
"Re-run the query for the current search expression, but only
if the search process is not already running"
(interactive)
(when mua/last-expression
(mua/hdrs-search mua/last-expression)))
;;; functions for sorting
(defun mua/hdrs-change-sort-order (fieldchar)
"Change the sortfield to FIELDCHAR."
(interactive "cField to sort by ('d', 's', etc.; see mu-headers(1)):\n")
(let ((field
(case fieldchar
(?b "bcc")
(?c "cc")
(?d "date")
(?f "from")
(?i "msgid")
(?m "maildir")
(?p "prio")
(?s "subject")
(?t "to")
(?z "size"))))
(if field
(setq mua/hdrs-sortfield field)
(mua/warn "Invalid sort-field; use one of bcdfimpstz (see mu-headers(1)"))
field))
(defun mua/hdrs-change-sort-direction (dirchar)
"Change the sort direction, either [a]scending or [d]escending."
(interactive)
(setq mua/hdrs-sort-descending
(y-or-n-p "Set sorting direction to descending(y) or ascending(n)")))
(defun mua/hdrs-change-sort ()
"Change thee sort field and dirtrection."
(interactive)
(and (call-interactively 'mua/hdrs-change-sort-order)
(call-interactively 'mua/hdrs-change-sort-direction)))
;;; functions for marking
(defvar mua/hdrs-marks-hash nil
"*internal* The hash for marked messages. The hash maps
bol (beginning-of-line) to a 3-tuple: [UID TARGET FLAGS], where UID is the
the UID of the message file (see `mua/msg-map'), TARGET is the
target maildir (ie., \"/inbox\", but can also be nil (for 'delete);
and finally FLAGS is the flags to set when the message is moved.")
(defun mua/hdrs-set-mark-ui (bol action)
"Display (or undisplay) the mark for BOL for action ACTION."
(unless (member action '(delete trash move unmark))
(error "Invalid action %S" action))
(save-excursion
(let ((inhibit-read-only t))
(delete-char 2)
(insert
(case action
(delete "d ")
(trash "D ")
(move "m ")
(unmark " "))))))
(defun mua/hdrs-set-mark (bol uid &optional target flags)
"Add a mark to `mua/hdrs-marks-hash', with BOL being the beginning of the line
of the marked message and (optionally) TARGET the target for the trash or move,
and FLAGS the flags to set for the message, either as a string or as a list (see
`mua/msg-move' for a discussion of the format)."
(if (gethash bol mua/hdrs-marks-hash)
(mua/warn "Message is already marked")
(let ((tuple `[,uid ,target ,flags]))
(puthash bol tuple mua/hdrs-marks-hash) ;; add to the hash...
(mua/hdrs-set-mark-ui bol action))))
(defun mua/hdrs-remove-mark (bol)
"Remove the mark for the message at BOL from the markings
hash. BOL must be the point at the beginning of the line."
(if (not (gethash bol mua/hdrs-marks-hash))
(mua/warn "Message is not marked")
(progn
(remhash bol mua/hdrs-marks-hash) ;; remove from the hash...
(mua/hdrs-set-mark-ui bol 'unmark))))
(defun mua/hdrs-marks-execute ()
"Execute the corresponding actions for all marked messages in
`mua/hdrs-marks-hash'."
(interactive)
(let ((n-marked (hash-table-count mua/hdrs-marks-hash)))
(if (= 0 n-marked)
(mua/warn "No marked messages")
(when (y-or-n-p
(format "Execute actions for %d marked message(s)? " n-marked))
(save-excursion
(maphash
(lambda(bol tuple)
(let* ((uid (aref tuple 0)) (target (aref tuple 1))
(flags (aref tuple 2)) (inhibit-read-only t))
(when (mua/msg-move uid target flags)
;; remember the updated path -- for now not too useful
;; as we're hiding the header, but...
(save-excursion
(mua/hdrs-remove-mark bol)
(goto-char bol)
;; when it succeedes, hide msg..)
(put-text-property (line-beginning-position 1)
(line-beginning-position 2) 'invisible t)))))
mua/hdrs-marks-hash))))))
(defun mua/hdrs-mark (action)
"Mark the message at point BOL (the beginning of the line) with
one of the symbols: move, delete, trash, unmark, unmark-all; the
latter two are pseudo-markings."
(let* ((bol (line-beginning-position 1)) (uid (mua/hdrs-get-uid)))
(when uid
(case action
(move
(mua/hdrs-set-mark bol uid (mua/ask-maildir "Target maildir: " t)))
(trash
(if (member 'trashed (mua/msg-flags-from-path (mua/hdrs-get-path)))
(mua/warn "Message is already trashed")
(mua/hdrs-set-mark bol uid (concat mua/maildir mua/trash-folder) "+T")))
(delete
(mua/hdrs-set-mark bol action uid "/dev/null"))
(unmark
(mua/hdrs-remove-mark bol))
(unmark-all
(when (y-or-n-p (format "Sure you want to remove all (%d) marks? "
(hash-table-count mua/hdrs-marks-hash)))
(save-excursion
(maphash (lambda (k v) (goto-char k) (mua/hdrs-mark 'unmark))
mua/hdrs-marks-hash))))
(t (error "Unsupported mark type")))
(move-beginning-of-line 2))))
;; functions for creating new message -- reply, forward, and new
(defun mua/hdrs-reply ()
"Reply to message at point."
(interactive)
(let* ((uid (mua/hdrs-get-uid))
(path (mua/hdrs-get-path))
(str (when path (mua/mu-view-sexp path)))
(msg (and str (mua/msg-from-string str))))
(if msg
(mua/msg-reply msg uid)
(mua/warn "No message at point"))))
(defun mua/hdrs-for-reply ()
"Forward the message at point."
(interactive)
(let* ((uid (mua/hdrs-get-uid))
(path (mua/hdrs-get-path))
(str (when path (mua/mu-view-sexp path)))
(msg (and str (mua/msg-from-string str))))
(if msg
(mua/msg-reply msg uid)
(mua/warn "No message at point"))))
(defun mua/hdrs-compose ()
"Create a new message."
(interactive)
(mua/msg-compose-new))
(provide 'mua-hdrs)

227
toys/mua/mua-msg-file.el
View File

@ -1,227 +0,0 @@
;;; mua-msg.el -- part of mua, 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:
;; mua
;;; Code:
(eval-when-compile (require 'cl))
(defvar mua/msg-map nil
"*internal* a map of uid->message.
This map adds a level of indirection for message files; many
actions (such moving, responding to or even reading a message)
cause the file names to change. Here we map the initial file to a
uid, the latter which stays constant over the lifetime of a
message in the system (in practice, the lifetime of a particular
headers buffer).
When creating the headers buffer, the file names are registered
with `mua/msg-map-add'.
All operation that change file names ultimately (should) end up
in `mua/msg-move', which will update the map after the
moving (using `mua/msg-map-update')
Other places of the code can use the uid to get the *current*
path of the file using `mua/msg-map-get-path'.
")
(defun mua/msg-map-add (path)
"Add a message PATH to the `mua/msg-map', and return the uid
for it."
(unless mua/msg-map
(setq mua/msg-map (make-hash-table :size 256 :rehash-size 2 :weakness t)))
(let ((uid (sha1 path)))
(puthash uid path mua/msg-map)
uid))
(defun mua/msg-map-update (uid path)
"Set the new path for the message identified by UID to PATH."
(if (gethash uid mua/msg-map)
(puthash uid path mua/msg-map)
(mua/warn "No message file registered for uid")))
(defun mua/msg-map-get-path (uid)
"Get the current path for the message identified by UID."
(gethash uid mua/msg-map))
(defun mua/msg-move (uid &optional targetdir flags ignore-already)
"Move message identified by UID to TARGETDIR using 'mu mv', and
update the database with the new situation. SRC must be the full,
absolute path to a message file, while 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
`mua/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
`mua/msg-string-to-flags' and `mua/msg-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'."
(condition-case err
(let ((src (mua/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 (mua/msg-flags-to-string flags)))
(argl (append ;; build-up the command line
'("mv" "--print-target" "--ignore-dups")
(when flagstr (list (concat "--flags=" flagstr)))
(list src)
(when targetdir (list targetdir))))
;; execute it, and get the results
(rv (apply 'mua/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)))
;; update the UID-map
(mua/msg-map-update uid targetpath)
;; remove the src file
(mua/mu-remove-async src)
;; and add the target file, unless it's dead now
(unless (string= targetdir "/dev/null")
(mua/mu-add-async targetpath)))
t)))
(error (mua/warn "error: %s" (error-message-string err)))))
(defun mua/msg-flags-from-path (path)
"Get the flags for the message at PATH, which does not have to exist.
The flags are returned as a list consisting of one or more of
DFNPRST, mean resp. Deleted, Flagged, New, Passed Replied, Seen
and Trash, as defined in [1]. See `mua/msg-string-to-flags'
and `mua/msg-flags-to-string'.
\[1\] http://cr.yp.to/proto/maildir.html."
(when (string-match ",\\(\[A-Z\]*\\)$" path)
(mua/msg-string-to-flags (match-string 1 path))))
(defun mua/msg-maildir-from-path (path &optional dont-strip-prefix)
"Get the maildir from PATH; in this context, 'maildir' is the
part between the `mua/maildir' and the /cur or /new; so
e.g. \"/home/user/Maildir/foo/bar/cur/12345:2,S\" would have
\"/foo/bar\" as its maildir. If DONT-STRIP-PREFIX is non-nil,
function will instead _not_ remove the `mua/maildir' from the
front - so in that case, the example would return
\"/home/user/Maildir/foo/bar/\". If the maildir cannot be
determined, return `nil'."
(when (and (string-match "^\\(.*\\)/\\(cur\\|new\\)/\[^/\]*$" path))
(let ((mdir (match-string 1 path)))
(when (and (< (length mua/maildir) (length mdir))
(string= (substring mdir 0 (length mua/maildir)) mua/maildir))
(if dont-strip-prefix
mdir
(substring mdir (length mua/maildir)))))))
(defun mua/msg-flags-to-string (flags)
"Remove duplicates and sort the output of `mua/msg-flags-to-string-1'."
(concat
(sort (remove-duplicates
(append (mua/msg-flags-to-string-1 flags) nil)) '>)))
(defun mua/msg-flags-to-string-1 (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 `mua/msg-string-to-flags'.
\[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))
(mua/msg-flags-to-string-1 (cdr flags))))))
(defun mua/msg-string-to-flags (str)
"Remove duplicates from the output of `mua/msg-string-to-flags-1'"
(remove-duplicates (mua/msg-string-to-flags-1 str)))
(defun mua/msg-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 `mua/msg-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))
(mua/msg-string-to-flags-1 (substring str 1))))))
(provide 'mua-msg-file)

455
toys/mua/mua-msg.el
View File

@ -1,455 +0,0 @@
;;; mua-msg.el -- part of mua, 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:
;; mua
;;; Code:
(eval-when-compile (require 'cl))
;; we use some stuff from gnus...
(require 'message)
(require 'mail-parse)
(require 'html2text)
(require 'mua-common)
(defun mua/msg-from-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 mua/msg-body-txt-or-html (msg)
"Get :body-txt, or if not available, :body-html converted to
text, using `html2text'."
(let ((body (mua/msg-field msg :body-txt)))
(unless body
(setq body (mua/msg-field msg :body-html))
(when body
(setq body (with-temp-buffer
(insert body)
(html2text)
(buffer-string)))))
body))
(defun mua/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 `mua/msg-from-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
(mua/msg-body-txt-or-html msg))
(:maildir ;; messages gotten from mu-view don't have their maildir set...
(or (plist-get msg :maildir)
(mua/msg-maildir-from-path (mua/msg-field msg :path))))
(t (plist-get msg field))))
;; functions for composing new messages (forward, reply and new)
(defvar mua/msg-citation-prefix "> "
"String to prefix cited message parts with.")
(defvar mua/msg-reply-prefix "Re: "
"String to prefix the subject of replied messages with.")
(defvar mua/msg-forward-prefix "Fwd: "
"String to prefix the subject of forwarded messages with.")
(defconst mua/msg-draft-name "*mua-draft*"
"Name for draft messages.")
(defun mua/msg-user-agent ()
"Return the User-Agent string for mua. This is either the value
of `mua/user-agent', or, if not set, a string based on the
version of mua and emacs."
(or mua/user-agent
(format "mu %s; emacs %s" (mua/mu-binary-version) emacs-version)))
(defun mua/msg-cite-original (msg)
"Cite the body text of MSG, with a \"On %s, %s wrote:\"
line (with the %s's replaced with the date of MSG and the name
or e-mail address of its sender (or 'someone' if nothing
else)), followed of the quoted body of MSG, constructed by by
prepending `mua/msg-citation-prefix' to each line. If there is
no body in MSG, return nil."
(let* ((from (mua/msg-field msg :from))
(body (mua/msg-body-txt-or-html msg)))
(when body
(concat
(format "On %s, %s wrote:"
(format-time-string "%c" (mua/msg-field msg :date))
(if (and from (car from)) ;; a list ((<name> . <email>))
(or (caar from) (cdar from) "someone")
"someone"))
"\n\n"
(replace-regexp-in-string "^" " > " body)))))
(defun mua/msg-recipients-remove (lst email-to-remove)
"Remove the recipient with EMAIL from the recipient list (of
form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))."
(remove-if
(lambda (name-email)
(let ((email (cdr name-email)))
(when email (string= email-to-remove (downcase email))))) lst))
(defun mua/msg-recipients-to-string (lst)
"Convert a recipient list (of form '( (\"A\"
. \"a@example.com\") (\"B\" . \"B@example.com\") (nil
. \"c@example.com\")) into a string of form \"A <@aexample.com>,
B <b@example.com>, c@example.com\."
(mapconcat
(lambda (recip)
(let ((name (car recip)) (email (cdr recip)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))
(defun mua/msg-hidden-header (hdr val)
"Return user-invisible header to the message (HDR: VAL\n)."
;; (format "%s: %s\n" hdr val))
(propertize (format "%s: %s\n" hdr val) 'invisible t))
(defun mua/msg-header (hdr val)
"Return a header line of the form HDR: VAL\n. If VAL is nil,
return nil."
(when val (format "%s: %s\n" hdr val)))
(defun mua/msg-references-create (msg)
"Construct the value of the References: header based on MSG as
a comma-separated string. Normally, this the concatenation of the
existing References (which may be empty) and the message-id. If
the message-id is empty, returns the old References. If both are
empty, return nil."
(let ((refs (mua/msg-field msg :references))
(msgid (mua/msg-field msg :message-id)))
(if msgid ;; every received message should have one...
(mapconcat 'identity (append refs (list msgid)) ",")
(mapconcat 'identity refs ","))))
(defun mua/msg-to-create (msg reply-all)
"Construct the To: header for a reply-message based on some
message MSG. If REPLY-ALL is nil, this the the Reply-To addresss
of MSG if it exist, or the From:-address othewise. If reply-all
is non-nil, the To: is what was in the old To: with either the
Reply-To: or From: appended, and then the
receiver (i.e. `user-mail-address') removed.
So:
reply-all nil: Reply-To: or From: of MSG
reply-all t : Reply-To: or From: of MSG + To: of MSG - `user-mail-address'
The result is either nil or a string which can be used for the To:-field."
(let ((to-lst (mua/msg-field msg :to))
(reply-to (mua/msg-field msg :reply-to))
(from (mua/msg-field msg :from)))
(if reply-all
(progn ;; reply-all
(setq to-lst ;; append Reply-To:, or if not set, From: if set
(if reply-to (cons `(nil . ,reply-to) to-lst)
(if from (append to-lst from)
to-lst)))
;; and remove myself from To:
(setq to-lst (mua/msg-recipients-remove to-lst user-mail-address))
(mua/msg-recipients-to-string to-lst))
;; reply single
(progn
(or reply-to (mua/msg-recipients-to-string from))))))
(defconst mua/msg-separator "--text follows this line--\n\n"
"separator between headers and body, needed for `message-mode'")
(defun mua/msg-cc-create (msg reply-all)
"Get the list of Cc-addresses for the reply to MSG. If
REPLY-ALL is nil this is simply empty, otherwise it is the same
list as the one in MSG, minus `user-mail-address'. The result of
this function is either nil or a string to be used for the Cc:
field."
(let ((cc-lst (mua/msg-field msg :cc)))
(when (and reply-all cc-lst)
(mua/msg-recipients-to-string
(mua/msg-recipients-remove cc-lst
user-mail-address)))))
(defun mua/msg-from-create ()
"Construct a value for the From:-field of the reply to MSG,
based on `user-full-name' and `user-mail-address'; if the latter
is nil, function returns nil."
(when user-mail-address
(if user-full-name
(format "%s <%s>" user-full-name user-mail-address)
(format "%s" user-mail-address))))
(defun mua/msg-create-reply (msg reply-all)
"Create a draft message as a reply to MSG; if REPLY-ALL is
non-nil, reply to all recipients.
A reply message has fields:
From: - see `mu-msg-from-create'
To: - see `mua/msg-to-create'
Cc: - see `mua/msg-cc-create'
Subject: - `mua/msg-reply-prefix' + subject of MSG
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
References: - see `mua/msg-references-create'
In-Reply-To: - message-id of MSG
User-Agent - see `mua/msg-user-agent'
Then follows `mua/msg-separator' (for `message-mode' to separate
body from headers)
And finally, the cited body of MSG, as per `mua/msg-cite-original'."
(concat
(mua/msg-header "From" (or (mua/msg-from-create) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" (or (mua/msg-to-create msg reply-all) ""))
(mua/msg-header "Cc" (mua/msg-cc-create msg reply-all))
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-hidden-header "References" (mua/msg-references-create msg))
(mua/msg-hidden-header "In-reply-to" (mua/msg-field msg :message-id))
(mua/msg-header"Subject"
(concat mua/msg-reply-prefix (mua/msg-field msg :subject)))
mua/msg-separator
(mua/msg-cite-original msg)))
;; TODO: attachments
(defun mua/msg-create-forward (msg)
"Create a draft forward message for MSG.
A forward message has fields:
From: - see `mu-msg-from-create'
To: - empty
Subject: - `mua/msg-forward-prefix' + subject of MSG
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
References: - see `mua/msg-references-create'
User-Agent - see `mua/msg-user-agent'
Then follows `mua-msg-separator' (for `message-mode' to separate
body from headers)
And finally, the cited body of MSG, as per `mua/msg-cite-original'."
(concat
(mua/msg-header "From" (or (mua/msg-from-for-new) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" "")
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-hidden-header "References" (mua/msg-references-for-reply msg))
(mua/msg-header"Subject"
(concat mua/msg-forward-prefix (mua/msg-field msg :subject)))
mua/msg-separator
(mua/msg-cite-original msg)))
(defun mua/msg-create-new ()
"Create a new message.
A new draft message has fields:
From: - see `mu-msg-from-create'
To: - empty
Subject: - empty
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
User-Agent - see `mua/msg-user-agent'
Then follows `mua-msg-separator' (for `message-mode' to separate
body from headers)."
(concat
(mua/msg-header "From" (or (mua/msg-from-create) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" "")
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-header "Subject" "")
mua/msg-separator))
(defconst mua/msg-prefix "mua" "prefix for mua-generated
mail files; we use this to ensure that our hooks don't mess
with non-mua-generated messages")
(defun mua/msg-draft-file-name ()
"Create a Maildir-compatible[1], unique file name for a draft
message.
[1]: see http://cr.yp.to/proto/maildir.html"
(format "%s-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
mua/msg-prefix
(format-time-string "%Y%m%d" (current-time))
(emacs-pid)
(random t)
(replace-regexp-in-string "[:/]" "_" (system-name))))
(defvar mua/msg-reply-uid nil "UID of the message this is a reply to.")
(defvar mua/msg-forward-uid nil "UID of the message being forwarded.")
(defun mua/msg-compose (str)
"Create a new draft message in the drafts folder with STR as
its contents, and open this message file for editing. Optionally
specify PARENT-UID,
The name of the draft folder is constructed from the concatenation of
`mua/maildir' and `mua/drafts-folder' (therefore, these must be set).
The message file name is a unique name determined by
`mua/msg-draft-file-name'.
The initial STR would be created from either `mua/msg-create-reply',
`mua/msg-create-forward' or `mua/msg-create-new'. The editing buffer is
using Gnus' `message-mode'."
(unless mua/maildir (error "mua/maildir not set"))
(unless mua/drafts-folder (error "mua/drafts-folder not set"))
;; write our draft message to the the drafts folder
(let ((draftfile (concat mua/maildir "/" mua/drafts-folder "/cur/"
(mua/msg-draft-file-name))))
(with-temp-file draftfile (insert str))
(find-file draftfile) (rename-buffer mua/msg-draft-name t)
(message-mode)
(make-local-variable 'mua/msg-forward-uid)
(message-goto-body)))
(defun mua/msg-reply (msg &optional reply-uid)
"Create a draft reply to MSG, and swith to an edit buffer with
the draft message. PARENT-UID refers to the UID of the message wer"
(let* ((recipnum (+ (length (mua/msg-field msg :to))
(length (mua/msg-field msg :cc))))
(replyall (when (> recipnum 1)
(yes-or-no-p (format "Reply to all ~%d recipients? "
(+ recipnum))))))
;; exact num depends on some more things
(when (mua/msg-compose (mua/msg-create-reply msg replyall))
(when reply-uid (setq mua/msg-reply-uid reply-uid))
(message-goto-body))))
(defun mua/msg-forward (msg &optional forward-uid)
"Create a draft forward for MSG, and swith to an edit buffer with
the draft message."
(when (mua/msg-compose (mua/msg-create-forward msg))
(when forward-uid (setq mua/msg-forward-uid forward-uid))
(message-goto-to)))
(defun mua/msg-compose-new ()
"Create a draft message, and swith to an edit buffer with the
draft message."
(when (mua/msg-compose (mua/msg-create-new))
(message-goto-to)))
(defun mua/msg-save-to-sent ()
"Move the message in this buffer to the sent folder. This is
meant to be called from message mode's `message-sent-hook'."
(if (mua/msg-is-mua-message) ;; only if we are mua
(unless mua/sent-folder (error "mua/sent-folder not set"))
(let* ;; TODO: remove duplicate flags
((newflags ;; remove Draft; maybe set 'Seen' as well?
(delq 'draft (mua/msg-flags-from-path (buffer-file-name))))
;; so, we register path => uid, then we move uid, then check the name
;; uid is referring to
(uid (mua/msg-register (buffer-file-name)))
(if (mua/msg-move uid
(concat mua/maildir mua/sent-folder)
(mua/msg-flags-to-string newflags))
(set-visited-file-name (mua/msg-get-path uid) t t)
(mua/warn "Failed to save message to the Sent-folder"))))))
(defun mua/msg-set-replied-or-passed-flag ()
"Set the 'replied' flag on messages we replied to, and the
'passed' flag on message we have forwarded. This uses
`mua/msg-reply-uid' and `mua/msg-forward-uid', repectively.
NOTE: This does not handle the case yet of message which are
edited from drafts. That case could be solved by searching for
the In-Reply-To message-id for replies.
This is meant to be called from message mode's
`message-sent-hook'."
;; handle the replied-to message
(when mua/msg-reply-uid
(unless (mua/msg-move mua/msg-reply-uid nil "+R")
(mua/warn "Failed to marked parent message as 'Replied'")))
;; handle the forwarded message
(when mua/msg-forward-uid
(unless (mua/msg-move mua/msg-forward-uid nil "+P")
(mua/warn "Failed to marked parent message as 'Passed'"))))
;; hook our functions up with sending of the message
(add-hook 'message-sent-hook 'mua/msg-save-to-sent)
(add-hook 'message-sent-hook 'mua/msg-set-replied-or-passed-flag)
(provide 'mua-msg)

144
toys/mua/mua-mu.el
View File

@ -1,144 +0,0 @@
;;; mua-mu.el -- part of mua, 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:
;; mua-mu contains common functions that interact with the mu program
;;; Code:
(eval-when-compile (require 'cl))
(defun mua/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. Basically, `mua/mu-run' is like `shell-command-to-string',
but with better possibilities for error handling. The --muhome=
parameter is added automatically if `mua/mu-home' is non-nil."
(let* ((rv)
(args (append args (when mua/mu-home
(list (concat "--muhome=" mua/mu-home)))))
(cmdstr (concat mua/mu-binary " " (mapconcat 'identity args " ")))
(str (with-output-to-string
(with-current-buffer standard-output ;; but we also get stderr...
(setq rv (apply 'call-process mua/mu-binary nil t nil
args))))))
(when (and (numberp rv) (/= 0 rv))
(mua/log "mua error: %s" (mua/mu-error rv)))
(mua/log "%s => %S" cmdstr rv)
`(,(if (numberp rv) rv 1) . ,str)))
(defun mua/mu-binary-version ()
"Get the version string of the mu binary, or nil if we failed
to get it"
(let ((rv (mua/mu-run "--version")))
(if (and (= (car rv) 0) (string-match "version \\(.*\\)$" (cdr rv)))
(match-string 1 (cdr rv))
(mua/warn "Failed to get version string"))))
(defun mua/mu-view-sexp (path)
"Return a string with an s-expression representing the message
at PATH; the format is described in `mua/msg-from-string', and
that function converts the string into a Lisp object (plist)"
(if (not (file-readable-p path))
(mua/warn "Cannot view unreadable file %s" path)
(let* ((rv (mua/mu-run "view" "--format=sexp" path))
(code (car rv)) (str (cdr rv)))
(if (= code 0)
str
(mua/warn "mu view failed (%d): %s"
code (if str str "error"))))))
(defvar mua/db-update-proc nil "*internal* process for db updates")
(defvar mua/db-update-name "*mua-db-update*"
"*internal* name of the db-update process")
(defvar mua/db-add-paths nil "list of paths to add to database")
(defvar mua/db-remove-paths nil "list of paths to remove from database")
(defun mua/db-update-proc-sentinel (proc msg)
"Check the 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 (mua/warn "Process killed"))
('exit
(case exit-status
(mua/warn "Result: %s" (mua/mu-log exit-status))))))
(mua/mu-db-update-execute)))
(defun mua/mu-db-update-execute ()
"Update the database; remove paths in `mua/db-remove-paths',
and add paths in `mua/db-add-paths'. Updating is ansynchronous."
;; when it's already running, do nothing
(unless (and mua/db-update-proc (eq (process-status mua/db-update-proc) 'run))
(when mua/db-remove-paths
(let ((remove-paths (copy-list mua/db-remove-paths)))
(mua/log (concat mua/mu-binary " remove "
(mapconcat 'identity remove-paths " ")))
(setq mua/db-remove-paths nil) ;; clear the old list
(setq mua/db-update-proc
(apply 'start-process mua/db-update-name mua/db-update-name mua/mu-binary
"remove" remove-paths))
(set-process-sentinel mua/db-update-proc 'mua/db-update-proc-sentinel))))
;; when it's already running, do nothing
(unless (and mua/db-update-proc
(eq (process-status mua/db-update-proc) 'run))
(when mua/db-add-paths
(let ((add-paths (copy-list mua/db-add-paths)))
(mua/log (concat mua/mu-binary " add " (mapconcat 'identity add-paths " ")))
(setq mua/db-add-paths nil) ;; clear the old list
(setq mua/db-update-proc
(apply 'start-process mua/db-update-name mua/db-update-name mua/mu-binary
"add" add-paths))
(set-process-sentinel mua/db-update-proc 'mua/db-update-proc-sentinel)))))
(defun mua/mu-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 mua/db-add-paths
(append mua/db-add-paths
(if (listp path-or-paths) path-or-paths `(,path-or-paths))))
(mua/mu-db-update-execute))
(defun mua/mu-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 mua/db-remove-paths
(append mua/db-remove-paths
(if (listp path-or-paths) path-or-paths `(,path-or-paths))))
(mua/mu-db-update-execute))
(provide 'mua-mu)

255
toys/mua/mua-view.el
View File

@ -1,255 +0,0 @@
;;; mua-view.el -- part of mua, 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:
;; mu
;;; Code:
(eval-when-compile (require 'cl))
(require 'mua-common)
(require 'mua-msg)
(defconst mua/view-buffer-name " *mua-view*"
"buffer name for mua/view buffers")
(defvar mua/view-headers
'(:from :to :cc :subject :flags :date :maildir :path :attachments)
"Fields to display in the message view buffer.")
(defvar mua/hdrs-buffer nil
"*internal* Headers buffer for the view in this buffer.")
(defvar mua/view-uid nil
"*internal* The UID for the message being viewed in this buffer.")
(defun mua/view (uid hdrsbuf)
"Display the message identified by UID in a new buffer, and mark
is as no longer unread, -- note that the action of viewing a
message may cause it to be moved/renamed; this function returns the
resulting name. PARENTBUF refers to the buffer who invoked this
view; this allows us to return there when we quit from this
view. Also, if PARENTBUF is a find buffer (ie., has mu-headers-mode
as its major mode), this allows various commands (navigation,
marking etc.) to be applied to this buffer.
For the reasoning to use UID here instead of just the path, see
`mua/msg-map'."
(condition-case err
(let* ((path (mua/msg-map-get-path uid))
(sexp (mua/mu-view-sexp path))
(msg (and sexp (mua/msg-from-string sexp))))
(unless (buffer-live-p hdrsbuf) (error "Headers buffer is dead"))
(unless msg (error "Cannot view message %S" path))
(let ((buf (get-buffer-create mua/view-buffer-name))
(inhibit-read-only t))
;; fill buffer with the message
(erase-buffer)
(insert (mua/view-message msg))
(mua/view-mode)
(goto-char (point-min))
(setq ;; these are buffer-local
mua/view-uid uid
mua/hdrs-buffer hdrsbuf
mua/parent-buffer hdrsbuf)
(unless (mua/msg-move uid nil "+S-N" t) ;; mark as read
(error "Failed to mark message as read"))))
(debug (error))));; (mua/warn "error: %s" (error-message-string err)))))
(defun mua/view-message (msg)
"construct a display string for the message"
(let ((hdrs
(mapconcat
(lambda (field)
(case field
(:subject (mua/view-header msg "Subject" :subject))
(:path (mua/view-header msg "Path" :path))
(:to (mua/view-contacts msg field))
(:from (mua/view-contacts msg field))
(:cc (mua/view-contacts msg field))
(:bcc (mua/view-contacts msg field))
(:date (mua/view-date msg))
(:flags (mua/view-flags msg))
(:maildir (mua/view-header msg "Maildir" :maildir))
(:size (mua/view-size msg))
(:attachments (mua/view-attachments msg))
(t (error "Unsupported field: %S" field))))
mua/view-headers ""))
(body (mua/msg-body-txt-or-html msg)))
(concat hdrs "\n" body)))
(defun mua/view-header-string (key val face)
(if val
(concat
(propertize key 'face 'mua/header-title-face) ": "
(propertize val 'face face) "\n")
""))
(defun mua/view-header (msg key field)
"show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD\n"
(mua/view-header-string key (mua/msg-field msg field) 'mua/header-face))
(defun mua/view-contacts (msg field)
(unless (member field '(:to :from :bcc :cc))
(error "Illegal type for contact"))
(let* ((lst (mua/msg-field msg field))
(contacts
(when lst
(mapconcat
(lambda(c) (let ((name (car c)) (email (cdr c)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))))
(if contacts
(mua/view-header-string
(case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc"))
contacts 'mua/contacts-face)
"")))
(defun mua/view-date (msg)
(let* ((date (mua/msg-field msg :date))
(datestr (when date (format-time-string "%c" date))))
(mua/view-header-string "Date" datestr 'mua/header-face)))
(defun mua/view-size (msg)
(let* ((size (mua/msg-field msg :size))
(sizestr (when size (format "%d bytes"))))
(mua/view-header-string "Size" sizestr 'mua-header-face)))
(defun mua/view-flags (msg)
""
"" ;; todo
)
(defun mua/view-attachments (msg)
""
"" ;; todo
)
(defvar mua/view-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" 'mua/quit-buffer)
(define-key map "s" 'mua/view-search)
(define-key map "f" 'mua/view-forward)
(define-key map "r" 'mua/view-reply)
(define-key map "c" 'mua/view-compose)
;; navigation between messages
(define-key map "n" 'mua/view-next)
(define-key map "p" 'mua/view-prev)
;; marking/unmarking
(define-key map "d" '(lambda()(interactive)(mua/view-mark 'trash)))
(define-key map "D" '(lambda()(interactive)(mua/view-mark 'delete)))
(define-key map "m" '(lambda()(interactive)(mua/view-mark 'move)))
(define-key map "u" '(lambda()(interactive)(mua/view-mark 'unmark)))
(define-key map "x" 'mua/view-marked-execute)
map)
"Keymap for \"*mua-view*\" buffers.")
(fset 'mua/view-mode-map mua/view-mode-map)
(defun mua/view-mode ()
"major mode for viewing an e-mail message"
(interactive)
(kill-all-local-variables)
(use-local-map mua/view-mode-map)
(make-local-variable 'mua/parent-buffer)
(make-local-variable 'mua/hdrs-buffer)
(make-local-variable 'mua/view-uid)
(setq major-mode 'mua/view-mode mode-name "*mu-view*")
(setq truncate-lines t buffer-read-only t))
(defmacro mua/with-hdrs-buffer (&rest body)
"Execute the forms in BODY with the mua/hdrs-buffer temporarily current.
Note that this actually switches the buffer, and changes to point
etc. persist."
(declare (indent 1) (debug t))
`(let ((oldbuf (current-buffer)))
(if (buffer-live-p mua/hdrs-buffer)
(progn
(set-buffer mua/hdrs-buffer)
(progn ,@body)
(set-buffer oldbuf))
(mua/warn "hdrs buffer is dead"))))
(defun mua/view-mark (action)
"Set/unset marks for the current message."
(interactive)
(mua/with-hdrs-buffer (mua/hdrs-mark action)))
(defun mua/view-marked-execute ()
"Warn user that marks cannot be executed from here (for his/her
own safety)."
(interactive)
(mua/warn "You cannot execute marks from here"))
(defun mua/view-search()
"Start a new search."
(interactive)
(mua/with-hdrs-buffer
(call-interactively 'mua/hdrs-search)))
(defun mua/view-next ()
"move to the next message; note, this will replace the current
buffer"
(interactive)
(with-current-buffer mua/hdrs-buffer
(when (mua/hdrs-next) (mua/hdrs-view))))
(defun mua/view-prev ()
"move to the previous message; note, this will replace the
current buffer"
(interactive)
(mua/with-hdrs-buffer
(when (mua/hdrs-prev) (mua/hdrs-view))))
(defun mua/view-reply ()
"Reply to the current message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-reply)))
(defun mua/view-forward ()
"Reply to the current message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-forward)))
(defun mua/view-compose ()
"Write a new message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-compose)))
(provide 'mua-view)

177
toys/mua/mua.el
View File

@ -1,177 +0,0 @@
;;; mua.el -- part of mua, 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:
;; mu
;;; Code:
(eval-when-compile (require 'cl))
(require 'mua-common)
(require 'mua-mu)
(require 'mua-msg)
(require 'mua-hdrs)
(require 'mua-view)
(require 'mua-msg-file)
(defvar mua/mu-home nil "location of the mu homedir, or nil for
the default")
(defvar mua/mu-binary "mu" "name/path of the mu binary")
(setq mua/mu-binary "/home/djcb/src/mu/src/mu")
(defvar mua/user-agent nil "User-specified User-Agent string")
(defvar mua/parent-buffer nil "parent buffer; if a buffer is
quitted, it switches back to its parent buffer")
(defvar mua/maildir nil "our maildir")
(defvar mu/maildir nil "location of your maildir, typically ~/Maildir")
(defvar mu/inbox-folder nil "location of your inbox folder")
(defvar mu/outbox-folder nil "location of your outbox folder")
(defvar mu/sent-folder nil "location of your sent folder")
(defvar mu/trash-folder nil "location of your trash folder")
(defvar mu/drafts-folder nil "location of your drafts folder")
(setq
mua/maildir "/home/djcb/Maildir"
mua/inbox-folder "/inbox"
mua/outbox-folder "/outbox"
mua/sent-folder "/sent"
mua/drafts-folder "/drafts"
mua/trash-folder "/trash")
(defvar mua/working-folders nil)
(setq mua/working-folders
'("/bulk" "/archive" "/bulkarchive" "/todo"))
(setq mua/header-fields
'( (:date . 25)
(:flags . 6)
(:from . 22)
(:subject . 40)))
(defface mua/date-face '((t (:foreground "#8c5353"))) "")
(defface mua/header-title-face '((t (:foreground "#df558f"))) "")
(defface mua/header-face '((t (:foreground "#dfaf8f"))) "")
(defface mua/contacts-face '((t (:foreground "#7f9f7f"))) "")
(defface mua/body-face '((t (:foreground "#8cd0d3"))) "")
(setq mua/hdrs-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "s" 'mua/hdrs-search)
(define-key map "q" 'mua/quit-buffer)
(define-key map "o" 'mua/hdrs-change-sort)
(define-key map "g" 'mua/hdrs-refresh)
;; navigation
(define-key map "n" 'mua/hdrs-next)
(define-key map "p" 'mua/hdrs-prev)
(define-key map (kbd "<down>") 'mua/hdrs-next)
(define-key map (kbd "<up>") 'mua/hdrs-prev)
(define-key map (kbd "<SPC>") 'scroll-up)
(define-key map "j" 'mua/hdrs-jump-to-maildir)
;; marking/unmarking/executing
(define-key map "m" (lambda()(interactive)(mua/hdrs-mark 'move)))
(define-key map "d" (lambda()(interactive)(mua/hdrs-mark 'trash)))
(define-key map "D" (lambda()(interactive)(mua/hdrs-mark 'delete)))
(define-key map "u" (lambda()(interactive)(mua/hdrs-mark 'unmark)))
(define-key map "U" (lambda()(interactive)(mua/hdrs-mark 'unmark-all)))
(define-key map "x" 'mua/hdrs-marks-execute)
;; 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") 'mua/hdrs-view)
map))
(fset 'mua/hdrs-mode-map mua/hdrs-mode-map)
(defconst mua/buffer-name "*mua*"
"Name of the top-level mua buffer")
(defun mua()
"Start mua, the mu e-mail client with an impressive dashboard."
(interactive)
(let ((buf (mua/new-buffer mua/buffer-name)))
(with-current-buffer buf
(insert (propertize "mua" 'face 'highlight)
(propertize " version: " 'face 'mua/header-title-face)
(propertize (mua/mu-binary-version) 'face 'mua/header-face)
(propertize " maildir: " 'face 'mua/header-title-face)
(propertize mua/maildir 'face 'mua/header-face)
"\n\n\n"
(propertize "* quick jump folders" 'face 'mua/header-title-face)
" (use " (propertize "j" 'face 'highlight) ")\n"
" " (mapconcat 'identity
(append (list mua/inbox-folder mua/sent-folder mua/drafts-folder)
mua/working-folders) " ") "\n\n"
(propertize "* search" 'face 'mua/header-title-face)
" (use " (propertize "s" 'face 'highlight) ")\n\n"
(propertize "* compose a new message" 'face 'mua/header-title-face)
" (use " (propertize "c" 'face 'highlight) ")\n\n"
))
(switch-to-buffer buf)
(mua/mua-mode)))
(defvar mua/mua-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "s" 'mua/hdrs-search)
(define-key map "q" 'mua/quit-buffer)
(define-key map "j" 'mua/hdrs-jump-to-maildir)
(define-key map "c" 'mua/hdrs-compose)
map)
"Keymap for *mua-headers* buffers.")
(fset 'mua/mua-mode-map mua/mua-mode-map)
(defun mua/mua-mode ()
"Major mode for the mua dashboard screen."
(interactive)
(kill-all-local-variables)
(use-local-map mua/mua-mode-map)
(make-local-variable 'mua/buf)
(setq
major-mode 'mua/mua-mode mode-name "*mua*"
truncate-lines t buffer-read-only t
overwrite-mode 'overwrite-mode-binary))
(provide 'mua)