465 lines
16 KiB
EmacsLisp
465 lines
16 KiB
EmacsLisp
;;; mu-headers.el -- use `mu' from emacs
|
|
;; 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:
|
|
|
|
(require 'mu-common)
|
|
|
|
|
|
;;; mu-headers has functions for displaying/manipulating a list of headers (ie.,
|
|
;;; one line descriptions of an e-mail message), based on the output of 'mu
|
|
;;; find'.
|
|
|
|
;; 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
|
|
;;
|
|
;; then, marks are stored in a seperate hash 'mu-headers-marks-hash, using
|
|
;;
|
|
;; point-of-bol -> (src . target)
|
|
;;
|
|
;; and note both 'delete' (target=/dev/null), trash (target=trash-folder), and
|
|
;; move can be expressed by that
|
|
;;
|
|
;; after the marks have been 'executed', the lines will be marked a *invisible*
|
|
;; instead of deleting them; that way, the 'point-of-bol' stays valid.
|
|
|
|
(defvar mu-headers-hash nil "internal: buffer-local hash table
|
|
which maps bol->path")
|
|
(defvar mu-headers-marks-hash nil "internal: buffer-local hash table
|
|
which maps bol->(src . target) for marked lines")
|
|
|
|
(defun mu-headers-set-path (path)
|
|
"map the bol of the current header to a path"
|
|
(puthash (line-beginning-position 1) path mu-headers-hash))
|
|
|
|
(defun mu-headers-get-path ()
|
|
"get the path for the header at point"
|
|
(gethash (line-beginning-position 1) mu-headers-hash))
|
|
|
|
(defvar mu-headers-fields
|
|
'( (:date . 25)
|
|
(:from-or-to . 22)
|
|
(:subject . 40))
|
|
"a list of fields and their widths")
|
|
|
|
(defvar mu-headers-sort-field "date"
|
|
"shortcut of the field to sort on (see mu-headers (1))")
|
|
(defvar mu-headers-sort-descending nil
|
|
"whether to sort in descending order")
|
|
|
|
;; internal stuff
|
|
(defconst mu-headers-buffer-name " *mu-headers*" "name of the mu
|
|
results buffer; name should start with a space")
|
|
|
|
(defvar mu-headers-process nil "the possibly running find process")
|
|
|
|
(defconst mu-eom "\n;;eom\n" "marker for the end of message in
|
|
the mu find output")
|
|
|
|
(defvar mu-headers-expression nil
|
|
"search expression for the current find buffer")
|
|
|
|
(defvar mu-buf "" "internal: buffer for results data")
|
|
(defun mu-headers-process-filter (proc str)
|
|
"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"
|
|
(when (buffer-live-p (process-buffer proc))
|
|
(with-current-buffer (process-buffer proc)
|
|
(save-excursion
|
|
(setq mu-buf (concat mu-buf str))
|
|
(let ((eom (string-match mu-eom mu-buf)))
|
|
(while (numberp eom)
|
|
(let* ((msg (car (read-from-string (substring mu-buf 0 eom))))
|
|
(inhibit-read-only t))
|
|
(goto-char (point-max))
|
|
(mu-headers-set-path (plist-get msg :path))
|
|
(save-match-data (insert (mu-headers-header msg) ?\n)))
|
|
(setq mu-buf (substring mu-buf (match-end 0)))
|
|
(setq eom (string-match mu-eom mu-buf))))))))
|
|
|
|
(defun mu-headers-process-sentinel (proc msg)
|
|
"Check the mu-headers process upon completion"
|
|
(when (buffer-live-p (process-buffer proc))
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((status (process-status proc))
|
|
(exit-status (process-exit-status proc)))
|
|
(if (memq status '(exit signal))
|
|
(let ((inhibit-read-only t)
|
|
(text
|
|
(cond
|
|
((eq status 'signal)
|
|
"Search process killed (results incomplete)")
|
|
((eq status 'exit)
|
|
(cond
|
|
((= 0 exit-status) "End of search results")
|
|
((= 2 exit-status) "No matches found")
|
|
((= 4 exit-status) "Database problem; try running 'mu index'")
|
|
(t (format "Some error occured; mu-headers returned %d"
|
|
exit-status))))
|
|
(t "Unknown status")))) ;; shouldn't happen
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(insert (mu-str text)))))))))
|
|
|
|
|
|
;; 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 mu-headers-search (expr)
|
|
"search in the mu database"
|
|
(interactive "s[mu] search for: ")
|
|
(let* ((buf (mu-get-new-buffer mu-headers-buffer-name))
|
|
(dummy-arg "--fields=\"dummy\"") ;; ignored
|
|
(proc (start-process mu-headers-buffer-name buf
|
|
mu-binary
|
|
"find"
|
|
(if mu-home
|
|
(concat "--muhome=" mu-home) dummy-arg)
|
|
(if mu-headers-sort-field
|
|
(concat "--sortfield=" mu-headers-sort-field) dummy-arg)
|
|
(if mu-headers-sort-descending "--descending" dummy-arg)
|
|
"--format=sexp"
|
|
"--quiet"
|
|
expr)))
|
|
(mu-log "search: '%s'" expr)
|
|
(switch-to-buffer buf)
|
|
(mu-headers-mode)
|
|
|
|
(setq
|
|
mu-buf "" ;; if the last query went wrong...
|
|
mu-headers-expression expr
|
|
mu-headers-process proc
|
|
|
|
mu-headers-hash (make-hash-table :size 256 :rehash-size 2)
|
|
mu-headers-marks-hash (make-hash-table :size 16 :rehash-size 2))
|
|
|
|
(set-process-filter proc 'mu-headers-process-filter)
|
|
(set-process-sentinel proc 'mu-headers-process-sentinel)))
|
|
|
|
(defun mu-headers-field-contact (lst width face)
|
|
"display a list of contacts, truncated for fitting in WIDTH"
|
|
(if lst
|
|
(let* ((len (length lst))
|
|
(str (if (= len 0) "<none>"
|
|
;; try name -> email -> ?
|
|
(or (car(car lst)) (cdr(car lst)) "?")))
|
|
(others (if (> len 1) (mu-str (format " [+%d]" (- len 1))) "")))
|
|
(truncate-string-to-width
|
|
(concat(propertize (truncate-string-to-width str
|
|
(- width (length others)) 0 ?\s "...") 'face face) others)
|
|
width 0 ?\s))
|
|
(make-string width ?\s)))
|
|
|
|
|
|
(defun mu-headers-field-from-or-to (fromlst tolst width from-face to-face)
|
|
"return a propertized string for FROM unless TO matches
|
|
mu-own-address, in which case it returns TO, prefixed with To:"
|
|
(if (and fromlst tolst)
|
|
(let ((fromaddr (cdr(car fromlst))))
|
|
(if (and fromaddr (string-match mu-own-address fromaddr))
|
|
(concat (mu-str "To ") (mu-headers-field-contact tolst (- width 3) to-face))
|
|
(mu-headers-field-contact fromlst width from-face)))
|
|
(make-string width ?\s)))
|
|
|
|
(defun mu-headers-field-size (size width face)
|
|
"return a string for SIZE of WIDTH with FACE"
|
|
(let* ((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 face)))
|
|
|
|
(defun mu-headers-field-str (str width face)
|
|
"print a STR, at WIDTH (truncate or ' '-pad) with FACE"
|
|
(let ((str (if str str "")))
|
|
(propertize (truncate-string-to-width str width 0 ?\s t) 'face face)))
|
|
|
|
(defun mu-headers-field-flags (flags width face)
|
|
(let ((str
|
|
(mapconcat
|
|
(lambda(flag)
|
|
(let ((flagname (symbol-name flag)))
|
|
(cond
|
|
((string= flagname "unread") "U")
|
|
((string= flagname "seen") "S")
|
|
((string= flagname "replied") "R")
|
|
((string= flagname "attach") "a")
|
|
((string= flagname "encrypted") "x")
|
|
((string= flagname "signed") "s")))) flags "")))
|
|
(propertize (truncate-string-to-width str width 0 ?\s) 'face face)))
|
|
|
|
(defun mu-headers-field (msg fieldinfo)
|
|
"determine a field based on FIELDINFO in the header for MSG"
|
|
(let* ((field (car fieldinfo))
|
|
(width (cdr fieldinfo))
|
|
(val (plist-get msg field)) ;; note: header-field maps msg-field in
|
|
(str (case field ;; most cases..
|
|
(:date (mu-headers-field-str (format-time-string mu-date-format-short
|
|
val) width 'mu-date-face))
|
|
(:from (mu-headers-field-contact val width 'mu-from-face))
|
|
(:to (mu-headers-field-contact val width 'mu-to-face))
|
|
(:cc (mu-headers-field-contact val width 'mu-cc-face))
|
|
(:bcc (mu-headers-field-contact val width 'mu-bcc-face))
|
|
(:flags (mu-headers-field-flags val width 'mu-flag-face))
|
|
(:size (mu-headers-field-size val width 'mu-size-face))
|
|
(:subject (mu-headers-field-str val width 'mu-subject-face))
|
|
(:from-or-to ;; this one is special
|
|
(mu-headers-field-from-or-to (plist-get msg :from)
|
|
(plist-get msg :to) width 'mu-from-face 'mu-to-face)))))
|
|
str))
|
|
|
|
(defun mu-headers-header (msg)
|
|
"convert a message s-expression into a header for display, and
|
|
set text property 'path"
|
|
(concat " "
|
|
(mapconcat
|
|
(lambda (fieldinfo)
|
|
(mu-headers-field msg fieldinfo)) mu-headers-fields " ")))
|
|
|
|
|
|
(defun mu-headers-mode ()
|
|
"major mode for displaying search results"
|
|
(interactive)
|
|
(kill-all-local-variables)
|
|
(use-local-map mu-headers-mode-map)
|
|
|
|
(make-local-variable 'mu-buf)
|
|
(make-local-variable 'mu-parent-buffer)
|
|
(make-local-variable 'mu-headers-expression)
|
|
(make-local-variable 'mu-headers-process)
|
|
(make-local-variable 'mu-headers-hash)
|
|
(make-local-variable 'mu-headers-marks-hash)
|
|
|
|
(setq
|
|
major-mode 'mu-headers-mode mode-name "*headers*"
|
|
mu-buf ""
|
|
truncate-lines t buffer-read-only t
|
|
overwrite-mode 'overwrite-mode-binary))
|
|
|
|
(defvar mu-headers-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
|
|
(define-key map "s" 'mu-headers-search)
|
|
(define-key map "q" 'mu-quit-buffer)
|
|
(define-key map "s" 'mu-headers-change-sort)
|
|
(define-key map "g" 'mu-headers-refresh)
|
|
|
|
;; navigation
|
|
(define-key map "n" 'mu-headers-next)
|
|
(define-key map "p" 'mu-headers-previous)
|
|
(define-key map "j" 'mu-headers-jump-to-maildir)
|
|
|
|
;; marking/unmarking/executing
|
|
(define-key map "m" 'mu-headers-mark-for-move)
|
|
(define-key map "d" 'mu-headers-mark-for-trash)
|
|
(define-key map "D" 'mu-headers-mark-for-deletion)
|
|
(define-key map "u" 'mu-headers-unmark)
|
|
(define-key map "U" 'mu-headers-unmark-all)
|
|
(define-key map "x" 'mu-headers-marked-execute)
|
|
|
|
;; message composition
|
|
(define-key map "r" 'mu-reply)
|
|
(define-key map "f" 'mu-forward)
|
|
(define-key map (kbd "RET") 'mu-headers-view)
|
|
map)
|
|
"Keymap for \"mu-headers\" buffers.")
|
|
(fset 'mu-headers-mode-map mu-headers-mode-map)
|
|
|
|
(defun mu-headers-view ()
|
|
"display the message at the current line"
|
|
(interactive)
|
|
(let ((path (mu-headers-get-path)))
|
|
(when path (mu-view path (current-buffer)))))
|
|
|
|
(defun mu-headers-next ()
|
|
"go to the next line; t if it worked, nil otherwise"
|
|
(interactive)
|
|
(if (or (/= 0 (forward-line 1)) (not (mu-headers-get-path)))
|
|
(progn (message "No message after this one") nil)
|
|
t))
|
|
|
|
(defun mu-headers-prev ()
|
|
"go to the next line; t if it worked, nil otherwise"
|
|
(interactive)
|
|
(if (/= 0 (forward-line -1))
|
|
(progn (message "No message before this one") nil)
|
|
t))
|
|
|
|
(defun mu-headers-jump-to-maildir ()
|
|
"show the messages in one of the standard folders"
|
|
(interactive)
|
|
(let ((fld (mu-ask-maildir "Jump to maildir: ")))
|
|
(mu-headers-search (concat "maildir:" fld))))
|
|
|
|
(defun mu-headers-refresh ()
|
|
"re-run the query for the current search expression, but only
|
|
if the search process is not already running"
|
|
(interactive)
|
|
(message "REFRESH %s" mu-headers-expression)
|
|
(if (and mu-headers-process (eq (process-status mu-headers-process) 'run))
|
|
(message "Can't refresh while running")
|
|
(when mu-headers-expression (mu-headers mu-headers-expression))))
|
|
|
|
;; create a new query based on the old one, but with a changed sort order
|
|
|
|
(defun mu-headers-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 mu-headers-sort-field field)
|
|
(message "Invalid sort-field; use one of bcdfimpstz (see mu-headers(1)"))
|
|
field))
|
|
|
|
(defun mu-headers-change-sort-direction (dirchar)
|
|
"change the sort direction, either [a]scending or [d]escending"
|
|
(interactive
|
|
"cSorting direction ([a]scending or [d]escending):")
|
|
(cond
|
|
(?d (setq mu-headers-sort-descending t) t)
|
|
(?a (setq mu-headers-sort-descending nil) t)
|
|
(t (message
|
|
"Invalid sort-direction; choose either [a]scending or [d]escending") nil)))
|
|
|
|
(defun mu-headers-change-sort ()
|
|
"change sort field and direction"
|
|
(interactive)
|
|
(and (call-interactively 'mu-headers-change-sort-order)
|
|
(call-interactively 'mu-headers-change-sort-direction)))
|
|
|
|
(defun mu-headers-add-marked (src &optional dst)
|
|
(let ((bol (line-beginning-position 1)))
|
|
(if (gethash bol mu-headers-marks-hash)
|
|
(progn (message "Message is already marked") nil)
|
|
(progn (puthash bol (cons src dst) mu-headers-marks-hash) t))))
|
|
|
|
(defun mu-headers-remove-marked ()
|
|
(let ((bol (line-beginning-position 1)))
|
|
(if (not (gethash bol mu-headers-marks-hash))
|
|
(progn (message "Message is not marked") nil)
|
|
(progn (remhash bol mu-headers-marks-hash) t))))
|
|
|
|
(defun mu-headers-set-marker (kar)
|
|
"set the marker at the beginning of this line"
|
|
(beginning-of-line 1)
|
|
(let ((inhibit-read-only t))
|
|
(delete-char 2)
|
|
(insert (if kar kar " ") " ")))
|
|
|
|
(defun mu-headers-mark (action)
|
|
"mark the current msg for something: move, delete, trash, unmark"
|
|
(let ((target) (src (mu-headers-get-path)))
|
|
(when src
|
|
(case action
|
|
(move
|
|
(when (mu-headers-add-marked src
|
|
(mu-ask-maildir "Target maildir: " t))
|
|
(mu-headers-set-marker ?m)))
|
|
(trash
|
|
(when (mu-headers-add-marked src
|
|
(concat mu-maildir mu-trash-folder))
|
|
(mu-headers-set-marker ?d)))
|
|
(delete
|
|
(when (mu-headers-add-marked src "/dev/null")
|
|
(mu-headers-set-marker ?D)))
|
|
(unmark
|
|
(when (mu-headers-remove-marked)
|
|
(mu-headers-set-marker nil)))
|
|
(unmark-all
|
|
(when (y-or-n-p (format "Sure you want to remove all (%d) marks? "
|
|
(hash-table-count mu-headers-marks-hash)))
|
|
(save-excursion
|
|
(maphash (lambda (k v) (goto-char k) (mu-headers-mark 'unmark))
|
|
mu-headers-marks-hash)))
|
|
(t (message "Unsupported mark type"))))
|
|
(move-beginning-of-line 2))))
|
|
|
|
(defun mu-headers-marks-execute ()
|
|
"execute the actions for all marked messages"
|
|
(interactive)
|
|
(let ((n-marked (hash-table-count mu-headers-marks-hash)))
|
|
(if (= 0 n-marked)
|
|
(message "No marked messages")
|
|
(when (y-or-n-p
|
|
(format "Execute actions for %d marked message(s)? " n-marked))
|
|
(save-excursion
|
|
(maphash
|
|
(lambda(bol v)
|
|
(let ((src (car v)) (target (cdr v)) (inhibit-read-only t))
|
|
(when (mu-message-move src target)
|
|
(goto-char bol)
|
|
(mu-headers-remove-marked)
|
|
(put-text-property (line-beginning-position 1)
|
|
(line-beginning-position 2)
|
|
'invisible t)))) ;; when it succeedes, hide msg..)
|
|
mu-headers-marks-hash))
|
|
(message "Done")
|
|
))))
|
|
|
|
(defun mu-headers-mark-for-move () (interactive) (mu-headers-mark 'move))
|
|
(defun mu-headers-mark-for-trash () (interactive) (mu-headers-mark 'trash))
|
|
(defun mu-headers-mark-for-delete () (interactive) (mu-headers-mark 'delete))
|
|
(defun mu-headers-mark-for-deletion () (interactive) (mu-headers-mark 'delete))
|
|
(defun mu-headers-unmark () (interactive) (mu-headers-mark 'unmark))
|
|
(defun mu-headers-unmark-all () (interactive) (mu-headers-mark 'unmark-all))
|
|
|
|
(defun mu-headers-reply ()
|
|
"Reply to the message at point"
|
|
(interactive)
|
|
(let ((path (mu-headers-get-path)))
|
|
(if path
|
|
(mu-message-reply path)
|
|
(message "No message at point"))))
|
|
|
|
(defun mu-headers-forward ()
|
|
"Reply to the message at point"
|
|
(interactive)
|
|
(let ((path (mu-headers-get-path)))
|
|
(if path
|
|
(mu-message-forward path)
|
|
(message "No message at point"))))
|
|
|
|
|
|
(provide 'mu-headers)
|
|
|