* some code re-arrangement: src/guile-> guile, toys/mm -> emacs
This commit is contained in:
djcb
35
emacs/Makefile.am
Normal file
35
emacs/Makefile.am
Normal file
@ -0,0 +1,35 @@
|
||||
## Copyright (C) 2008-2011 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
||||
##
|
||||
## This program is free software; you can redistribute it and/or modify
|
||||
## it under the terms of the GNU General Public License as published by
|
||||
## the Free Software Foundation; either version 3 of the License, or
|
||||
## (at your option) any later version.
|
||||
##
|
||||
## This program is distributed in the hope that it will be useful,
|
||||
## but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
## GNU General Public License for more details.
|
||||
##
|
||||
## You should have received a copy of the GNU General Public License
|
||||
## along with this program; if not, write to the Free Software Foundation,
|
||||
## Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
|
||||
include $(top_srcdir)/gtest.mk
|
||||
|
||||
SUBDIRS=
|
||||
|
||||
BUILT_SOURCES=mm-version.el
|
||||
|
||||
mm-version.el:
|
||||
@echo -e ";; auto-generated\n\
|
||||
(defconst mm/mu-version \"$(VERSION)\" \"Required mu binary version.\")\n\
|
||||
(provide 'mm-version)\n" >$@
|
||||
|
||||
EXTRA_DIST= \
|
||||
mm.el \
|
||||
mm-hdrs.el \
|
||||
mm-view.el \
|
||||
mm-proc.el \
|
||||
mm-send.el \
|
||||
mm-version.el
|
||||
|
||||
66
emacs/TODO
Normal file
66
emacs/TODO
Normal file
@ -0,0 +1,66 @@
|
||||
|
||||
* TODO
|
||||
|
||||
** Bugs
|
||||
|
||||
*** forward should take the attachments from the original
|
||||
*** database locks
|
||||
|
||||
** Features i
|
||||
|
||||
*** documentation
|
||||
*** emacs install
|
||||
|
||||
** Features ii
|
||||
|
||||
*** mark thread
|
||||
*** bounce support
|
||||
*** sorting
|
||||
*** recursive ask-maildir
|
||||
*** display unread info at startup
|
||||
*** tool bars
|
||||
*** make links clickable
|
||||
*** colorize cited parts in view
|
||||
*** refiling-by-pattern
|
||||
*** window management
|
||||
*** inspect message (muile)
|
||||
*** message statistics
|
||||
*** include exchange handling / org integration
|
||||
*** integrate with org-contacts, bbdb
|
||||
|
||||
|
||||
* DONE
|
||||
** don't put updated messages at the end
|
||||
** mark region
|
||||
** editing drafts
|
||||
** combine download / re-index
|
||||
** toggleable message line wrapping in view
|
||||
** threading problems
|
||||
** missing? message
|
||||
** double messages (different docids though)
|
||||
** sometimes commands are not executed immediately
|
||||
** menus
|
||||
** flag information for content flags (encrypted, signed, has-attach)
|
||||
** use top bar
|
||||
** add footer to search results
|
||||
** q while adding headers
|
||||
** handle start/stopping server
|
||||
** hostname in draftname
|
||||
** make quick folders work for both jump and move
|
||||
** synchronize headers / view buffer point
|
||||
** make date format customizable
|
||||
** add :from-or-to
|
||||
** fix to:/cc: etc.
|
||||
** give info about target for move
|
||||
** --maildir=~/Maildir does not work anymore
|
||||
** message threading
|
||||
** view raw message
|
||||
** Sent Items
|
||||
** raw-mode / quit
|
||||
** customizable bookmarks
|
||||
** fix queued sending
|
||||
** version check at startup
|
||||
|
||||
# Local Variables:
|
||||
# mode: org; org-startup-folded: nil
|
||||
# End:
|
||||
779
emacs/mm-hdrs.el
Normal file
779
emacs/mm-hdrs.el
Normal file
@ -0,0 +1,779 @@
|
||||
;; 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:')
|
||||
|
||||
;; mm
|
||||
|
||||
;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(require 'mm-proc)
|
||||
|
||||
;;;; 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 "*mm-headers*"
|
||||
"*internal* Name of the buffer for message headers.")
|
||||
|
||||
(defvar mm/hdrs-buffer nil
|
||||
"*internal* Buffer for message headers")
|
||||
|
||||
(defun mm/hdrs-search (expr &optional full-search)
|
||||
"Search in the mu database for EXPR, and switch to the output
|
||||
buffer for the results. If FULL-SEARCH is non-nil return all
|
||||
results, otherwise, limit number of results to
|
||||
`mm/search-results-limit'."
|
||||
(let ((buf (get-buffer-create mm/hdrs-buffer-name))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(mm/hdrs-mode)
|
||||
(setq
|
||||
mm/mm/marks-map nil
|
||||
mm/msg-map (make-hash-table :size 1024 :rehash-size 2 :weakness nil)
|
||||
mode-name expr
|
||||
mm/last-expr expr
|
||||
mm/hdrs-buffer buf)))
|
||||
(switch-to-buffer mm/hdrs-buffer)
|
||||
(mm/proc-find expr ;; '-1' means 'unlimited search'
|
||||
(if full-search -1 mm/search-results-limit)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; handler functions
|
||||
;;
|
||||
;; next are a bunch of handler functions; those will be called from mm-proc in
|
||||
;; response to output from the server process
|
||||
|
||||
|
||||
(defun mm/hdrs-view-handler (msg)
|
||||
"Handler function for displaying a message."
|
||||
(mm/view msg mm/hdrs-buffer))
|
||||
|
||||
(defun mm/hdrs-error-handler (err)
|
||||
"Handler function for showing an error."
|
||||
(let ((errcode (plist-get err :error))
|
||||
(errmsg (plist-get err :error-message)))
|
||||
(case errcode
|
||||
(4 (message "No matches for this search query."))
|
||||
(t (message (format "Error %d: %s" errcode errmsg))))))
|
||||
|
||||
(defun mm/hdrs-update-handler (msg is-move)
|
||||
"Update handler, will be called when a message has been updated
|
||||
in the database. This function will update the current list of
|
||||
headers."
|
||||
(when (buffer-live-p mm/hdrs-buffer)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(let* ((docid (plist-get msg :docid))
|
||||
(marker (gethash docid mm/msg-map))
|
||||
(point (when marker (marker-position marker))))
|
||||
(when point ;; is the message present in this list?
|
||||
;; if it's marked, unmark it now
|
||||
(when (mm/hdrs-docid-is-marked docid) (mm/hdrs-mark 'unmark))
|
||||
;; first, remove the old one (otherwise, we'd have to headers with
|
||||
;; the same docid...
|
||||
(mm/hdrs-remove-handler docid)
|
||||
|
||||
;; if we we're actually viewing this message (in mm/view mode), we
|
||||
;; update the `mm/current-msg' there as well; that way, the flags can
|
||||
;; be updated, as well as the path (which is useful for viewing the
|
||||
;; raw message)
|
||||
(let ((viewbuf (get-buffer mm/view-buffer-name)))
|
||||
(when (and viewbuf (buffer-live-p viewbuf))
|
||||
(with-current-buffer viewbuf
|
||||
(when (eq docid (plist-get mm/current-msg :docid))
|
||||
(setq mm/current-msg msg)))))
|
||||
|
||||
;; now, if this update was about *moving* a message, we don't show it
|
||||
;; anymore (of course, we cannot be sure if the message really no
|
||||
;; longer matches the query, but this seem a good heuristic.
|
||||
;; if it was only a flag-change, show the message with its updated flags.
|
||||
(unless is-move
|
||||
(mm/hdrs-header-handler msg point)))))))
|
||||
|
||||
|
||||
(defun mm/hdrs-remove-handler (docid)
|
||||
"Remove handler, will be called when a message has been removed
|
||||
from the database. This function will hide the remove message in
|
||||
the current list of headers."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(let* ((marker (gethash docid mm/msg-map))
|
||||
(pos (and marker (marker-position marker)))
|
||||
(docid-at-pos (and pos (mm/hdrs-get-docid pos))))
|
||||
(unless marker (error "Message %d not found" docid))
|
||||
(unless (eq docid docid-at-pos)
|
||||
(error "At point %d, expected docid %d, but got %d"
|
||||
pos docid docid-at-pos))
|
||||
(mm/hdrs-remove-header docid pos))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun mm/hdrs-contact-str (contacts)
|
||||
"Turn the list of contacts CONTACTS (with elements (NAME . EMAIL)
|
||||
into a string."
|
||||
(mapconcat
|
||||
(lambda (ct)
|
||||
(let ((name (car ct)) (email (cdr ct)))
|
||||
(or name email "?"))) contacts ", "))
|
||||
|
||||
(defun mm/thread-prefix (thread)
|
||||
"Calculate the thread prefix based on thread info THREAD."
|
||||
(if thread
|
||||
(let ( (level (plist-get thread :level))
|
||||
(first-child (plist-get thread :first-child))
|
||||
(has-child (plist-get thread :has-child))
|
||||
(duplicate (plist-get thread :duplicate))
|
||||
(empty-parent (plist-get thread :empty-parent)))
|
||||
(concat
|
||||
(make-string (* (if empty-parent 0 2) level) ?\s)
|
||||
(cond
|
||||
(has-child "+ ")
|
||||
(empty-parent "- ")
|
||||
(first-child "\\ ")
|
||||
(duplicate "= ")
|
||||
(t "| "))))))
|
||||
;; FIXME: when updating an header line, we don't know the thread
|
||||
;; stuff
|
||||
|
||||
(defun mm/hdrs-header-handler (msg &optional point)
|
||||
"Create a one line description of MSG in this buffer, at POINT,
|
||||
if provided, or at the end of the buffer otherwise."
|
||||
(let* ( (docid (plist-get msg :docid))
|
||||
(thread-info
|
||||
(or (plist-get msg :thread) (gethash docid mm/thread-info-map)))
|
||||
(line
|
||||
(mapconcat
|
||||
(lambda (f-w)
|
||||
(let* ((field (car f-w)) (width (cdr f-w))
|
||||
(val (plist-get msg field))
|
||||
(str
|
||||
(case field
|
||||
(:subject (concat (mm/thread-prefix thread-info) val))
|
||||
((:maildir :path) val)
|
||||
((:to :from :cc :bcc) (mm/hdrs-contact-str val))
|
||||
;; if we (ie. `user-mail-address' is the 'From', show
|
||||
;; 'To', otherwise show From
|
||||
(:from-or-to
|
||||
(let* ((from-lst (plist-get msg :from))
|
||||
(from (and from-lst (cdar from-lst))))
|
||||
(if (and from (string-match
|
||||
mm/user-mail-address-regexp from))
|
||||
(concat "To "
|
||||
(mm/hdrs-contact-str (plist-get msg :to)))
|
||||
(mm/hdrs-contact-str from-lst))))
|
||||
(:date (format-time-string mm/headers-date-format val))
|
||||
(:flags (mm/flags-to-string val))
|
||||
(:size (mm/display-size val))
|
||||
(t (error "Unsupported header field (%S)" field)))))
|
||||
(when str
|
||||
(if (not width)
|
||||
str
|
||||
(truncate-string-to-width str width 0 ?\s t)))))
|
||||
mm/headers-fields " "))
|
||||
(flags (plist-get msg :flags))
|
||||
(line (cond
|
||||
((member 'draft flags)
|
||||
(propertize line 'face 'mm/draft-face 'draft t))
|
||||
((member 'trashed flags)
|
||||
(propertize line 'face 'mm/trashed-face))
|
||||
((member 'unread flags)
|
||||
(propertize line 'face 'mm/unread-face))
|
||||
(t ;; else
|
||||
(propertize line 'face 'mm/header-face)))))
|
||||
|
||||
;; store the thread info, so we can use it when updating the message
|
||||
(when thread-info
|
||||
(puthash docid thread-info mm/thread-info-map))
|
||||
(mm/hdrs-add-header line (plist-get msg :docid)
|
||||
(if point point (point-max)))))
|
||||
|
||||
|
||||
(defun mm/hdrs-found-handler (count)
|
||||
"Create a one line description of the number of headers found
|
||||
after the end of the search results."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(let ((inhibit-read-only t))
|
||||
(insert (propertize
|
||||
(case count
|
||||
(0 "No matching messages found")
|
||||
;; note, don't show the number so we don't have to update it
|
||||
;; when we delete messsages...
|
||||
(otherwise "End of search results"))
|
||||
;; (1 "Found 1 message")
|
||||
;; (otherwise (format "Found %d messages" count)))
|
||||
'face 'mm/system-face 'intangible t))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(setq mm/hdrs-mode-map nil)
|
||||
(defvar mm/hdrs-mode-map nil
|
||||
"Keymap for *mm-headers* buffers.")
|
||||
(unless mm/hdrs-mode-map
|
||||
(setq mm/hdrs-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
||||
(define-key map "s" 'mm/search)
|
||||
(define-key map "S" 'mm/search-full)
|
||||
|
||||
(define-key map "b" 'mm/search-bookmark)
|
||||
|
||||
(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)
|
||||
|
||||
|
||||
;; marking/unmarking/executing
|
||||
(define-key map (kbd "<backspace>") 'mm/mark-for-trash)
|
||||
(define-key map "d" 'mm/mark-for-trash)
|
||||
|
||||
(define-key map (kbd "<delete>") 'mm/mark-for-delete)
|
||||
(define-key map "D" 'mm/mark-for-delete)
|
||||
|
||||
(define-key map "j" 'mm/jump-to-maildir)
|
||||
(define-key map "m" 'mm/mark-for-move)
|
||||
|
||||
(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" 'mm/compose-reply)
|
||||
(define-key map "f" 'mm/compose-forward)
|
||||
(define-key map "c" 'mm/compose-new)
|
||||
(define-key map "e" 'mm/edit-draft)
|
||||
|
||||
(define-key map (kbd "RET") 'mm/view-message)
|
||||
|
||||
;; menu
|
||||
(define-key map [menu-bar] (make-sparse-keymap))
|
||||
(let ((menumap (make-sparse-keymap "Headers")))
|
||||
(define-key map [menu-bar headers] (cons "Headers" menumap))
|
||||
|
||||
(define-key menumap [quit-buffer] '("Quit view" . mm/quit-buffer))
|
||||
(define-key menumap [sepa0] '("--"))
|
||||
|
||||
(define-key menumap [execute-marks] '("Execute marks" . mm/execute-marks))
|
||||
(define-key menumap [unmark-all] '("Unmark all" . mm/unmark-all))
|
||||
(define-key menumap [unmark] '("Unmark" . mm/unmark))
|
||||
(define-key menumap [mark-delete] '("Mark for deletion" . mm/mark-for-delete))
|
||||
(define-key menumap [mark-trash] '("Mark for trash" . mm/mark-for-trash))
|
||||
(define-key menumap [mark-move] '("Mark for move" . mm/mark-for-move))
|
||||
(define-key menumap [sepa1] '("--"))
|
||||
|
||||
(define-key menumap [compose-new] '("Compose new" . mm/compose-new))
|
||||
(define-key menumap [forward] '("Forward" . mm/compose-forward))
|
||||
(define-key menumap [reply] '("Reply" . mm/compose-reply))
|
||||
(define-key menumap [sepa2] '("--"))
|
||||
|
||||
(define-key menumap [refresh] '("Refresh" . mm/rerun-search))
|
||||
(define-key menumap [search] '("Search" . mm/search))
|
||||
(define-key menumap [search-full] '("Search full" . mm/search-full))
|
||||
|
||||
(define-key menumap [jump] '("Jump to maildir" . mm/jump-to-maildir))
|
||||
(define-key menumap [sepa3] '("--"))
|
||||
|
||||
(define-key menumap [view] '("View" . mm/view-message))
|
||||
(define-key menumap [next] '("Next" . mm/next-header))
|
||||
(define-key menumap [previous] '("Previous" . mm/prev-header))
|
||||
(define-key menumap [sepa4] '("--")))
|
||||
|
||||
;;(define-key menumap [draft] '("Edit draft" . mm/compose-new))
|
||||
map)))
|
||||
|
||||
(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/last-expr)
|
||||
(make-local-variable 'mm/hdrs-proc)
|
||||
(make-local-variable 'mm/marks-map)
|
||||
(make-local-variable 'mm/msg-map)
|
||||
(make-local-variable 'mm/thread-info-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-found-func 'mm/hdrs-found-handler)
|
||||
(setq mm/proc-view-func 'mm/hdrs-view-handler)
|
||||
(setq mm/proc-remove-func 'mm/hdrs-remove-handler)
|
||||
;; this last one is defined in mm-send.el
|
||||
(setq mm/proc-compose-func 'mm/send-compose-handler)
|
||||
|
||||
(setq
|
||||
mm/marks-map (make-hash-table :size 16 :rehash-size 2)
|
||||
mm/thread-info-map (make-hash-table :size 512 :rehash-size 2)
|
||||
major-mode 'mm/hdrs-mode
|
||||
mode-name "mm: message headers"
|
||||
truncate-lines t
|
||||
buffer-read-only t
|
||||
overwrite-mode 'overwrite-mode-binary)
|
||||
|
||||
(setq header-line-format
|
||||
(cons "* "
|
||||
(map 'list
|
||||
(lambda (item) ;; FIXME
|
||||
(let ((field (cdr (assoc (car item) mm/header-names)))
|
||||
(width (cdr item)))
|
||||
(concat
|
||||
(propertize
|
||||
(if width
|
||||
(truncate-string-to-width field width 0 ?\s t)
|
||||
field)
|
||||
'face 'mm/title-face) " ")))
|
||||
mm/headers-fields))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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/hdrs-add-header (str docid point)
|
||||
"Add header STR with DOCID to the buffer at POINT."
|
||||
(unless docid (error "Invalid message"))
|
||||
(when (buffer-live-p mm/hdrs-buffer)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(let ((inhibit-read-only t))
|
||||
(save-excursion
|
||||
(goto-char point)
|
||||
;; Update `mm/msg-map' with MSG, and MARKER pointing to the buffer
|
||||
;; position for the message header."
|
||||
(insert (propertize (concat " " str "\n") 'docid docid))
|
||||
(puthash docid (copy-marker point t) mm/msg-map))))))
|
||||
|
||||
(defun mm/hdrs-remove-header (docid point)
|
||||
"Remove header with DOCID at POINT."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(goto-char point)
|
||||
;; sanity check
|
||||
(unless (eq docid (mm/hdrs-get-docid))
|
||||
(error "%d: Expected %d, but got %d"
|
||||
(line-number-at-pos) docid (mm/hdrs-get-docid)))
|
||||
(let ((inhibit-read-only t))
|
||||
;; (put-text-property (line-beginning-position line-beginning-positio 2)
|
||||
;; 'invisible t))
|
||||
(delete-region (line-beginning-position) (line-beginning-position 2)))
|
||||
(remhash docid mm/msg-map)))
|
||||
|
||||
(defun mm/hdrs-mark-header (docid mark)
|
||||
"(Visually) mark the header for DOCID with character MARK."
|
||||
(let ((marker (gethash docid mm/msg-map)))
|
||||
;; (unless marker (error "Unregistered message"))
|
||||
(when marker
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(save-excursion
|
||||
(let ((inhibit-read-only t) (pos (marker-position marker)))
|
||||
(goto-char pos)
|
||||
(delete-char 2)
|
||||
(insert (propertize mark 'face 'mm/hdrs-marks-face) " ")
|
||||
(put-text-property pos
|
||||
(line-beginning-position 2) 'docid docid)
|
||||
;; update the msg-map, ie., move it back to the start of the line
|
||||
(puthash docid
|
||||
(copy-marker (line-beginning-position) t)
|
||||
mm/msg-map)))))))
|
||||
|
||||
|
||||
(defun mm/hdrs-get-docid (&optional point)
|
||||
"Get the docid for the message at POINT, if provided, or (point), otherwise."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(get-text-property (if point point (point)) 'docid)))
|
||||
|
||||
(defun mm/dump-msg-map ()
|
||||
"*internal* dump the message map (for debugging)."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(message "msg-map (%d)" (hash-table-count mm/msg-map))
|
||||
(maphash
|
||||
(lambda (k v)
|
||||
(message "%s => %s" k v))
|
||||
mm/msg-map)))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
;; threadinfo-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/thread-info-map nil
|
||||
"Map (hash) of docid->threadinfo; when filling the list of
|
||||
messages, we fill a map of thread info, such that when a header
|
||||
changes (e.g., it's read-flag gets set) through some (:update
|
||||
...) message, we can restore the thread-info (this is needed
|
||||
since :update messages do not include thread info).")
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
;;; 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-message (mark &optional target)
|
||||
"Mark (or unmark) message 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 (mm/hdrs-get-docid))
|
||||
(markkar
|
||||
(case mark ;; the visual mark
|
||||
('move "m")
|
||||
('trash "d")
|
||||
('delete "D")
|
||||
('select "*")
|
||||
('unmark " ")
|
||||
(t (error "Invalid mark %S" mark)))))
|
||||
(unless docid (error "No message on this line"))
|
||||
(save-excursion
|
||||
(when (mm/hdrs-mark-header docid markkar))
|
||||
;; update the hash -- remove everything current, and if add the new stuff,
|
||||
;; unless we're unmarking
|
||||
(remhash docid mm/marks-map)
|
||||
;; remove possible overlays
|
||||
(remove-overlays (line-beginning-position) (line-end-position))
|
||||
|
||||
;; now, let's set a mark (unless we were unmarking)
|
||||
(unless (eql mark 'unmark)
|
||||
(puthash docid (list (point-marker) mark target) mm/marks-map)
|
||||
;; when we have a target (ie., when moving), show the target folder in
|
||||
;; an overlay
|
||||
(when target
|
||||
(let* ((targetstr (propertize (concat "-> " target " ")
|
||||
'face 'mm/system-face))
|
||||
(start (+ 2 (line-beginning-position))) ;; +2 for the marker fringe
|
||||
(overlay (make-overlay start (+ start (length targetstr)))))
|
||||
(overlay-put overlay 'display targetstr)))))))
|
||||
|
||||
|
||||
(defun mm/hdrs-mark (mark &optional target)
|
||||
"Mark the header at point, or, if
|
||||
region is active, mark all headers in the region. Als see
|
||||
`mm/hdrs-mark-message'."
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(if (use-region-p)
|
||||
;; mark all messages in the region.
|
||||
(save-excursion
|
||||
(let ((b (region-beginning)) (e (region-end)))
|
||||
(goto-char b)
|
||||
(while (<= (line-beginning-position) e)
|
||||
(mm/hdrs-mark-message mark target)
|
||||
(forward-line 1))))
|
||||
;; just a single message
|
||||
(mm/hdrs-mark-message mark target))))
|
||||
|
||||
|
||||
|
||||
(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."
|
||||
(if (= 0 (hash-table-count mm/marks-map))
|
||||
(message "Nothing is marked")
|
||||
(maphash
|
||||
(lambda (docid val)
|
||||
(let ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)))
|
||||
(case mark
|
||||
(move
|
||||
(mm/proc-move-msg docid target))
|
||||
(trash
|
||||
(unless mm/trash-folder
|
||||
(error "`mm/trash-folder' not set"))
|
||||
(mm/proc-move-msg docid mm/trash-folder "+T"))
|
||||
(delete
|
||||
(mm/proc-remove-msg docid)))))
|
||||
mm/marks-map)
|
||||
(mm/hdrs-unmark-all)))
|
||||
|
||||
(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 (mm/hdrs-get-docid)))
|
||||
(unless docid (error "No message at point."))
|
||||
(mm/proc-view-msg docid)))
|
||||
|
||||
(defun mm/hdrs-compose (compose-type)
|
||||
"Compose either a reply/forward based on the message at point. or
|
||||
start editing it. COMPOSE-TYPE is either `reply', `forward' or
|
||||
`edit'."
|
||||
(if (eq compose-type 'new)
|
||||
(mm/send-compose-handler 'new)
|
||||
(let ((docid (mm/hdrs-get-docid))
|
||||
;; note, the first two chars of the line (the mark margin) does *not*
|
||||
;; have the 'draft property; thus, we check one char before the end of
|
||||
;; the current line instead
|
||||
(is-draft (get-text-property (- (line-end-position) 1) 'draft)))
|
||||
(unless docid
|
||||
(error "No message at point."))
|
||||
(cond
|
||||
((member compose-type '(reply forward))
|
||||
(mm/proc-compose compose-type docid))
|
||||
((eq compose-type 'edit)
|
||||
(unless is-draft
|
||||
(error "Cannot edit a non-draft message"))
|
||||
(mm/proc-compose 'edit docid))
|
||||
(t (error "invalid compose type %S" compose-type))))))
|
||||
|
||||
|
||||
(defun mm/hdrs-docid-is-marked (docid)
|
||||
"Is the given docid marked?"
|
||||
(when (gethash docid mm/marks-map) t))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; interactive functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun mm/ignore-marks ()
|
||||
(let*
|
||||
((num
|
||||
(hash-table-count mm/marks-map))
|
||||
(unmark (or (= 0 num)
|
||||
(y-or-n-p
|
||||
(format "Sure you want to unmark %d message(s)?" num)))))
|
||||
(message nil)
|
||||
unmark))
|
||||
|
||||
(defun mm/search (expr)
|
||||
"Start a new mu search, limited to `mm/search-results-limit'
|
||||
results."
|
||||
(interactive "s[mu] search for: ")
|
||||
(when (mm/ignore-marks) (mm/hdrs-search expr)))
|
||||
|
||||
(defun mm/search-full (expr)
|
||||
"Start a new mu search; resturn *all* results."
|
||||
(interactive "s[mu] full search for: ")
|
||||
(when (mm/ignore-marks)
|
||||
(mm/hdrs-search expr t)))
|
||||
|
||||
|
||||
(defun mm/search-bookmark ()
|
||||
"Search using some bookmarked query."
|
||||
(interactive)
|
||||
(let ((query (mm/ask-bookmark "Bookmark: ")))
|
||||
(when query
|
||||
(mm/hdrs-search query))))
|
||||
|
||||
|
||||
(defun mm/quit-buffer ()
|
||||
"Quit the current buffer."
|
||||
(interactive)
|
||||
(when (mm/ignore-marks)
|
||||
(mm/kill-proc) ;; hmmm...
|
||||
(kill-buffer)
|
||||
(mm)))
|
||||
|
||||
(defun mm/rerun-search ()
|
||||
"Rerun the search for the last search expression; if none exists,
|
||||
do a new search."
|
||||
(interactive)
|
||||
(when (mm/ignore-marks)
|
||||
(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 message header. If this succeeds, return
|
||||
the new docid. Otherwise, return nil."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(when (= 0 (forward-line 1))
|
||||
(or (mm/hdrs-get-docid) (mm/next-header)) ;; skip non-headers
|
||||
;; trick to move point, even if this function is called when this window
|
||||
;; is not visible
|
||||
(set-window-point (get-buffer-window mm/hdrs-buffer) (point)))))
|
||||
|
||||
(defun mm/prev-header ()
|
||||
"Move point to the previous message header. If this succeeds,
|
||||
return the new docid. Otherwise, return nil."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(when (= 0 (forward-line -1))
|
||||
(or (mm/hdrs-get-docid) (mm/prev-header)) ;; skip non-headers
|
||||
;; trick to move point, even if this function is called when this window
|
||||
;; is not visible
|
||||
(set-window-point (get-buffer-window mm/hdrs-buffer) (point)))))
|
||||
|
||||
|
||||
(defun mm/jump-to-maildir ()
|
||||
"Show the messages in maildir TARGET. If TARGET is not provided,
|
||||
ask user for it."
|
||||
(interactive)
|
||||
(let ((fld (mm/ask-maildir "Jump to maildir: ")))
|
||||
(when fld
|
||||
(mm/hdrs-search (concat "maildir:" fld)))))
|
||||
|
||||
|
||||
(defun mm/mark-for-move (&optional target)
|
||||
"Mark message at point for moving to maildir TARGET. If target is
|
||||
not provided, function asks for it."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(let* ((target (or target (mm/ask-maildir "Move message to: ")))
|
||||
(fulltarget (concat mm/maildir target)))
|
||||
(when (or (file-directory-p fulltarget)
|
||||
(and (yes-or-no-p
|
||||
(format "%s does not exist. Create now?" fulltarget))
|
||||
(mm/proc-mkdir fulltarget)))
|
||||
(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"))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'trash)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/mark-for-delete ()
|
||||
"Mark message at point for direct deletion."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'delete)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/unmark ()
|
||||
"Unmark message at point."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'unmark)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/unmark-all ()
|
||||
"Unmark all messages."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(if (= 0 (hash-table-count mm/marks-map))
|
||||
(message "Nothing is marked")
|
||||
(when (mm/ignore-marks)
|
||||
(mm/hdrs-unmark-all)))))
|
||||
|
||||
(defun mm/execute-marks ()
|
||||
"Execute the actions for the marked messages."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(if (= 0 (hash-table-count mm/marks-map))
|
||||
(message "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)
|
||||
(message nil)))))
|
||||
|
||||
(defun mm/compose-reply ()
|
||||
"Start composing a reply to the current message."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-compose 'reply)))
|
||||
|
||||
(defun mm/compose-forward ()
|
||||
"Start composing a forward to the current message."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-compose 'forward)))
|
||||
|
||||
(defun mm/compose-new ()
|
||||
"Compose a new, empty message."
|
||||
(interactive)
|
||||
(mm/hdrs-compose 'new))
|
||||
|
||||
(defun mm/edit-draft ()
|
||||
"Start editing the existing draft message at point."
|
||||
(interactive)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-compose 'edit)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(provide 'mm-hdrs)
|
||||
142
emacs/mm-main.el
Normal file
142
emacs/mm-main.el
Normal file
@ -0,0 +1,142 @@
|
||||
;;; mm-main.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:
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; mm main view mode + keybindings
|
||||
(defconst mm/main-buffer-name "*mm*"
|
||||
"*internal* Name of the mm main view buffer.")
|
||||
|
||||
(defvar mm/mm-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
||||
(define-key map "b" 'mm/search-bookmark)
|
||||
(define-key map "s" 'mm/search)
|
||||
(define-key map "S" 'mm/search-full)
|
||||
(define-key map "q" 'mm/quit-mm)
|
||||
(define-key map "j" 'mm/jump-to-maildir)
|
||||
(define-key map "c" 'mm/compose-new)
|
||||
|
||||
(define-key map "m" 'mm/toggle-mail-sending-mode)
|
||||
(define-key map "f" 'smtpmail-send-queued-mail)
|
||||
(define-key map "u" 'mm/retrieve-mail-update-db)
|
||||
|
||||
map)
|
||||
"Keymap for the *mm* buffer.")
|
||||
(fset 'mm/mm-mode-map mm/mm-mode-map)
|
||||
|
||||
(defun mm/mm-mode ()
|
||||
"Major mode for the mm main screen."
|
||||
(interactive)
|
||||
|
||||
(kill-all-local-variables)
|
||||
(use-local-map mm/mm-mode-map)
|
||||
|
||||
(setq
|
||||
mm/marks-map (make-hash-table :size 16 :rehash-size 2)
|
||||
major-mode 'mm/mm-mode
|
||||
mode-name "mm: main view"
|
||||
truncate-lines t
|
||||
buffer-read-only t
|
||||
overwrite-mode 'overwrite-mode-binary))
|
||||
|
||||
(defun mm/action-str (str)
|
||||
"Highlight the first occurence of [..] in STR."
|
||||
(if (string-match "\\[\\(\\w+\\)\\]" str)
|
||||
(let* ((key (match-string 1 str))
|
||||
(keystr (propertize key 'face 'mm/highlight-face)))
|
||||
(replace-match keystr nil t str 1))
|
||||
str))
|
||||
|
||||
|
||||
(defun mm/main-view()
|
||||
"Show the mm main view."
|
||||
(let ((buf (get-buffer-create mm/main-buffer-name))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(insert
|
||||
"* "
|
||||
(propertize "mm - mu mail for emacs version " 'face 'mm/title-face)
|
||||
(propertize mm/mu-version 'face 'mm/view-header-key-face)
|
||||
"\n\n"
|
||||
(propertize " Basics\n\n" 'face 'mm/title-face)
|
||||
(mm/action-str "\t* [j]ump to some maildir\n")
|
||||
(mm/action-str "\t* enter a [s]earch query\n")
|
||||
(mm/action-str "\t* [c]ompose a new message\n")
|
||||
"\n"
|
||||
(propertize " Bookmarks\n\n" 'face 'mm/title-face)
|
||||
(mapconcat
|
||||
(lambda (bm)
|
||||
(let* ((query (nth 0 bm)) (title (nth 1 bm)) (key (nth 2 bm)))
|
||||
(mm/action-str
|
||||
(concat "\t* [b" (make-string 1 key) "] " title))))
|
||||
mm/bookmarks "\n")
|
||||
|
||||
"\n"
|
||||
(propertize " Misc\n\n" 'face 'mm/title-face)
|
||||
(mm/action-str "\t* [u]pdate email & database\n")
|
||||
(mm/action-str "\t* toggle [m]ail sending mode ")
|
||||
"(" (propertize (if smtpmail-queue-mail "queued" "direct")
|
||||
'face 'mm/view-header-key-face) ")\n"
|
||||
(mm/action-str "\t* [f]lush queued mail\n")
|
||||
"\n"
|
||||
(mm/action-str "\t* [q]uit mm\n"))
|
||||
(mm/mm-mode)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Interactive functions
|
||||
|
||||
(defun mm/retrieve-mail-update-db ()
|
||||
"Get new mail and update the database."
|
||||
(interactive)
|
||||
(mm/proc-retrieve-mail-update-db))
|
||||
|
||||
(defun mm/toggle-mail-sending-mode ()
|
||||
"Toggle sending mail mode, either queued or direct."
|
||||
(interactive)
|
||||
(setq smtpmail-queue-mail (not smtpmail-queue-mail))
|
||||
(message
|
||||
(if smtpmail-queue-mail
|
||||
"Outgoing mail will now be queued"
|
||||
"Outgoing mail will now be sent directly"))
|
||||
(mm))
|
||||
|
||||
|
||||
(defun mm/quit-mm()
|
||||
"Quit the mm session."
|
||||
(interactive)
|
||||
(when (y-or-n-p "Are you sure you want to quit mm? ")
|
||||
(message nil)
|
||||
(mm/kill-proc)
|
||||
(kill-buffer)))
|
||||
|
||||
(provide 'mm-main)
|
||||
450
emacs/mm-proc.el
Normal file
450
emacs/mm-proc.el
Normal file
@ -0,0 +1,450 @@
|
||||
;;; 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))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; internal vars
|
||||
|
||||
(defvar mm/mu-proc nil
|
||||
"*internal* The mu-server process")
|
||||
|
||||
(defvar mm/proc-error-func 'mm/default-handler
|
||||
"*internal* A function called for each error returned from the
|
||||
server process; the function is passed an error plist as
|
||||
argument. See `mm/proc-filter' for the format.")
|
||||
|
||||
(defvar mm/proc-update-func 'mm/default-handler
|
||||
"*internal* A function called for each :update sexp returned from
|
||||
the server process; the function is passed a msg sexp as
|
||||
argument. See `mm/proc-filter' for the format.")
|
||||
|
||||
(defvar mm/proc-remove-func 'mm/default-handler
|
||||
"*internal* A function called for each :remove sexp returned from
|
||||
the server process, when some message has been deleted. The
|
||||
function is passed the docid of the removed message.")
|
||||
|
||||
(defvar mm/proc-view-func 'mm/default-handler
|
||||
"*internal* A function called for each single message sexp
|
||||
returned from the server process. The function is passed a message
|
||||
sexp as argument. See `mm/proc-filter' for the
|
||||
format.")
|
||||
|
||||
(defvar mm/proc-header-func 'mm/default-handler
|
||||
"*internal* A function called for each message returned from the
|
||||
server process; the function is passed a msg plist as argument. See
|
||||
`mm/proc-filter' for the format.")
|
||||
|
||||
(defvar mm/proc-found-func 'mm/default-handler
|
||||
"*internal* A function called for when we received a :found sexp
|
||||
after the headers have returns, to report on the number of
|
||||
matches. See `mm/proc-filter' for the format.")
|
||||
|
||||
(defvar mm/proc-compose-func 'mm/default-handler
|
||||
"*internal* A function called for each message returned from the
|
||||
server process that is used as basis for composing a new
|
||||
message (ie., either a reply or a forward); the function is passed
|
||||
msg and a symbol (either reply or forward). See `mm/proc-filter'
|
||||
for the format of <msg-plist>.")
|
||||
|
||||
(defvar mm/proc-info-func 'mm/default-handler
|
||||
"*internal* A function called for each (:info type ....) sexp
|
||||
received from the server process.")
|
||||
|
||||
(defvar mm/proc-pong-func 'mm/default-handler
|
||||
"*internal* A function called for each (:pong type ....) sexp
|
||||
received from the server process.")
|
||||
|
||||
(defvar mm/buf nil
|
||||
"*internal* Buffer for results data.")
|
||||
|
||||
(defvar mm/path-docid-map
|
||||
(make-hash-table :size 32 :rehash-size 2 :test 'equal :weakness nil)
|
||||
"*internal* hash we use to keep a path=>docid mapping for message
|
||||
we added ourselves (ie., draft messages), so we can e.g. move them
|
||||
to the sent folder using their docid")
|
||||
|
||||
(defun mm/proc-info-handler (info)
|
||||
"Handler function for (:info ...) sexps received from the server
|
||||
process."
|
||||
(let ((type (plist-get info :info)))
|
||||
(cond
|
||||
;; (:info :version "3.1")
|
||||
((eq type 'add)
|
||||
;; update our path=>docid map; we use this when composing messages to
|
||||
;; add draft messages to the db, so when we're sending them, we can move
|
||||
;; to the sent folder using the `mm/proc-move'.
|
||||
(puthash (plist-get info :path) (plist-get info :docid) mm/path-docid-map))
|
||||
((eq type 'version)
|
||||
(setq
|
||||
mm/version (plist-get info :version)
|
||||
mm/doccount (plist-get-info :doccount)))
|
||||
((eq type 'index)
|
||||
(if (eq (plist-get info :status) 'running)
|
||||
(message (format "Indexing... processed %d, updated %d"
|
||||
(plist-get info :processed) (plist-get info :updated)))
|
||||
(message
|
||||
(format "Indexing completed; processed %d, updated %d, cleaned-up %d"
|
||||
(plist-get info :processed) (plist-get info :updated)
|
||||
(plist-get info :cleaned-up)))))
|
||||
((plist-get info :message) (message "%s" (plist-get info :message))))))
|
||||
|
||||
|
||||
(defun mm/default-handler (&rest args)
|
||||
"Dummy handler function."
|
||||
(error "Not handled: %S" args))
|
||||
|
||||
(defconst mm/server-name "*mm-server"
|
||||
"*internal* Name of the server process, buffer.")
|
||||
|
||||
(defun mm/start-proc ()
|
||||
"Start the mu server process."
|
||||
;; TODO: add version check
|
||||
(unless (file-executable-p mm/mu-binary)
|
||||
(error (format "%S not found" 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/buf "")
|
||||
(setq mm/mu-proc (apply 'start-process mm/server-name mm/server-name
|
||||
mm/mu-binary args))
|
||||
;; register a function for (:info ...) sexps
|
||||
(setq mm/proc-info-func 'mm/proc-info-handler)
|
||||
(when mm/mu-proc
|
||||
(set-process-coding-system mm/mu-proc 'binary 'utf-8-unix)
|
||||
(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."
|
||||
(let* ((buf (get-buffer mm/server-name))
|
||||
(proc (and buf (get-buffer-process buf))))
|
||||
(when proc
|
||||
(let ((delete-exited-processes t))
|
||||
;; the mu server signal handler will make it quit after 'quit'
|
||||
(mm/proc-send-command "quit"))
|
||||
;; try sending SIGINT (C-c) to process, so it can exit gracefully
|
||||
(ignore-errors
|
||||
(signal-process proc 'SIGINT))))
|
||||
(setq
|
||||
mm/mu-proc nil
|
||||
mm/buf nil))
|
||||
|
||||
(defun mm/proc-is-running ()
|
||||
(and mm/mu-proc (eq (process-status mm/mu-proc) 'run)))
|
||||
|
||||
(defun mm/proc-eat-sexp-from-buf ()
|
||||
"'Eat' the next s-expression from `mm/buf'. `mm/buf gets its
|
||||
contents from the mu-servers in the following form:
|
||||
\376<len-of-sexp>\376<sexp>
|
||||
Function returns this sexp, or nil if there was none. `mm/buf' is
|
||||
updated as well, with all processed sexp data removed."
|
||||
(when mm/buf
|
||||
;; TODO: maybe try a non-regexp solution?
|
||||
(let* ((b (string-match "\376\\([0-9]+\\)\376" mm/buf))
|
||||
(sexp-len
|
||||
(when b (string-to-number (match-string 1 mm/buf)))))
|
||||
;; does mm/buf contain the full sexp?
|
||||
(when (and b (>= (length mm/buf) (+ sexp-len (match-end 0))))
|
||||
;; clear-up start
|
||||
(setq mm/buf (substring mm/buf (match-end 0)))
|
||||
;; note: we read the input in binary mode -- here, we take the part that
|
||||
;; is the sexp, and convert that to utf-8, before we interpret it.
|
||||
(let ((objcons
|
||||
(ignore-errors ;; note: this may fail if we killed the process
|
||||
;; in the middle
|
||||
(read-from-string
|
||||
(decode-coding-string (substring mm/buf 0 sexp-len) 'utf-8)))))
|
||||
(when objcons
|
||||
(setq mm/buf (substring mm/buf sexp-len))
|
||||
(car objcons)))))))
|
||||
|
||||
|
||||
(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-sexp
|
||||
marker, and then evaluating them.
|
||||
|
||||
The server output is as follows:
|
||||
|
||||
1. an error
|
||||
(:error 2 :error-message \"unknown command\")
|
||||
;; eox
|
||||
=> this will be passed to `mm/proc-error-func'.
|
||||
|
||||
2a. 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
|
||||
=> this will be passed to `mm/proc-header-func'.
|
||||
|
||||
2b. After the list of message sexps has been returned (see 2a.),
|
||||
we'll receive a sexp that looks like
|
||||
(:found <n>) with n the number of messages found. The <n> will be
|
||||
passed to `mm/proc-found-func'.
|
||||
|
||||
3. a view looks like:
|
||||
(:view <msg-sexp>)
|
||||
=> the <msg-sexp> (see 2.) will be passed to `mm/proc-view-func'.
|
||||
|
||||
4. a database update looks like:
|
||||
(:update <msg-sexp> :move <nil-or-t>)
|
||||
|
||||
=> the <msg-sexp> (see 2.) will be passed to
|
||||
`mm/proc-update-func', :move tells us whether this is a move to
|
||||
another maildir, or merely a flag change.
|
||||
|
||||
5. a remove looks like:
|
||||
(:remove <docid>)
|
||||
=> the docid will be passed to `mm/proc-remove-func'
|
||||
|
||||
6. a compose looks like:
|
||||
(:compose <msg-sexp> :action <reply|forward>) => the <msg-sexp>
|
||||
and either 'reply or 'forward will be passed
|
||||
`mm/proc-compose-func'."
|
||||
(mm/proc-log "* Received %d byte(s)" (length str))
|
||||
(setq mm/buf (concat mm/buf str)) ;; update our buffer
|
||||
(let ((sexp (mm/proc-eat-sexp-from-buf)))
|
||||
(while sexp
|
||||
(mm/proc-log "<- %S" sexp)
|
||||
(cond
|
||||
;; a header plist can be recognized by the existence of a :date field
|
||||
((plist-get sexp :date)
|
||||
(funcall mm/proc-header-func sexp))
|
||||
|
||||
;; the found sexp, we receive after getting all the headers
|
||||
((plist-get sexp :found)
|
||||
(funcall mm/proc-found-func (plist-get sexp :found)))
|
||||
|
||||
;; viewin a specific message
|
||||
((plist-get sexp :view)
|
||||
(funcall mm/proc-view-func (plist-get sexp :view)))
|
||||
|
||||
;; receive a pong message
|
||||
((plist-get sexp :pong)
|
||||
(funcall mm/proc-pong-func
|
||||
(plist-get sexp :version) (plist-get sexp :doccount)))
|
||||
|
||||
;; something got moved/flags changed
|
||||
((plist-get sexp :update)
|
||||
(funcall mm/proc-update-func
|
||||
(plist-get sexp :update) (plist-get sexp :move)))
|
||||
|
||||
;; a message got removed
|
||||
((plist-get sexp :remove)
|
||||
(funcall mm/proc-remove-func (plist-get sexp :remove)))
|
||||
|
||||
;; start composing a new message
|
||||
((plist-get sexp :compose)
|
||||
(funcall mm/proc-compose-func
|
||||
(plist-get sexp :compose-type)
|
||||
(plist-get sexp :compose)))
|
||||
|
||||
;; get some info
|
||||
((plist-get sexp :info)
|
||||
(funcall mm/proc-info-func sexp))
|
||||
|
||||
;; receive an error
|
||||
((plist-get sexp :error)
|
||||
(funcall mm/proc-error-func sexp))
|
||||
(t (message "Unexpected data from server [%S]" sexp)))
|
||||
(setq sexp (mm/proc-eat-sexp-from-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)
|
||||
(cond
|
||||
((eq code 9) (message nil))
|
||||
;;(message "the mu server process has been stopped"))
|
||||
(t (message (format "mu server process received signal %d" code)))))
|
||||
((eq status 'exit)
|
||||
(cond
|
||||
((eq code 0)
|
||||
(message nil)) ;; don't do anything
|
||||
((eq code 11)
|
||||
(message "Database is locked by another process"))
|
||||
((eq code 19)
|
||||
(message "Database is empty; try indexing some messages"))
|
||||
(t (message (format "mu server process ended with exit code %d" code)))))
|
||||
(t
|
||||
(message "something bad happened to the mu server process")))))
|
||||
|
||||
|
||||
(defconst mm/proc-log-buffer-name "*mm-log*"
|
||||
"*internal* Name of the logging buffer.")
|
||||
|
||||
(defun mm/proc-log (frm &rest args)
|
||||
"Write something in the *mm-log* buffer - mainly useful for debugging."
|
||||
(when mm/debug
|
||||
(with-current-buffer (get-buffer-create mm/proc-log-buffer-name)
|
||||
(goto-char (point-max))
|
||||
(insert (apply 'format (concat (format-time-string "%Y-%m-%d %T "
|
||||
(current-time)) frm "\n") args)))))
|
||||
|
||||
(defun mm/proc-send-command (frm &rest args)
|
||||
"Send as command to the mu server process; start the process if needed."
|
||||
(unless (mm/proc-is-running)
|
||||
(mm/start-proc))
|
||||
(let ((cmd (apply 'format frm args)))
|
||||
(mm/proc-log (concat "-> " cmd))
|
||||
(process-send-string mm/mu-proc (concat cmd "\n"))))
|
||||
|
||||
(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."
|
||||
(mm/proc-send-command "remove %d" docid))
|
||||
|
||||
|
||||
(defun mm/proc-find (expr &optional maxnum)
|
||||
"Start a database query for EXPR, getting up to MAXNUM
|
||||
results (or -1 for unlimited). 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."
|
||||
(mm/proc-send-command "find \"%s\" %d"
|
||||
expr (if maxnum maxnum -1)))
|
||||
|
||||
|
||||
(defun mm/proc-move-msg (docid targetmdir &optional flags)
|
||||
"Move message identified by DOCID to TARGETMDIR, optionally
|
||||
setting FLAGS in the process.
|
||||
|
||||
TARGETDIR must be a maildir, that is, the part _without_ cur/ or
|
||||
new/ or the root-maildir-prefix. E.g. \"/archive\". This directory
|
||||
must already exist.
|
||||
|
||||
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)))
|
||||
(fullpath (concat mm/maildir targetmdir)))
|
||||
(unless (and (file-directory-p fullpath) (file-writable-p fullpath))
|
||||
(error "Not a writable directory: %s" fullpath))
|
||||
;; note, we send the maildir, *not* the full path
|
||||
(mm/proc-send-command "move %d \"%s\" %s" docid
|
||||
targetmdir flagstr)))
|
||||
|
||||
(defun mm/proc-flag (docid-or-msgid flags)
|
||||
"Set FLAGS for the message identified by either DOCID-OR-MSGID."
|
||||
(let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags))))
|
||||
(mm/proc-send-command "flag %S %s" docid-or-msgid flagstr)))
|
||||
|
||||
(defun mm/proc-index (maildir)
|
||||
"Update the message database for MAILDIR."
|
||||
(mm/proc-send-command "index \"%s\"" maildir))
|
||||
|
||||
(defun mm/proc-add (path maildir)
|
||||
"Add the message at PATH to the database, with MAILDIR
|
||||
set to e.g. '/drafts'; if this works, we will receive (:info :path
|
||||
<path> :docid <docid>)."
|
||||
(mm/proc-send-command "add \"%s\" \"%s\"" path maildir))
|
||||
|
||||
(defun mm/proc-save (docid partidx path)
|
||||
"Save attachment PARTIDX from message with DOCID to PATH."
|
||||
(mm/proc-send-command "save %d %d \"%s\"" docid partidx path))
|
||||
|
||||
(defun mm/proc-open (docid partidx)
|
||||
"Open attachment PARTIDX from message with DOCID."
|
||||
(mm/proc-send-command "open %d %d" docid partidx))
|
||||
|
||||
(defun mm/proc-ping ()
|
||||
"Sends a ping to the mu server, expecting a (:pong ...) in
|
||||
response."
|
||||
(mm/proc-send-command "ping"))
|
||||
|
||||
(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'."
|
||||
(mm/proc-send-command "view %d" docid))
|
||||
|
||||
(defun mm/proc-compose (compose-type docid)
|
||||
"Start composing a message with DOCID and COMPOSE-TYPE (a symbol,
|
||||
either `forward', `reply' or `edit'.
|
||||
The result will be delivered to the function registered as
|
||||
`mm/proc-compose-func'."
|
||||
(unless (member compose-type '(forward reply edit))
|
||||
(error "Unsupported compose-type"))
|
||||
(mm/proc-send-command "compose %s %d" (symbol-name compose-type) docid))
|
||||
|
||||
(defconst mm/update-buffer-name "*update*"
|
||||
"*internal* Name of the buffer to download mail")
|
||||
|
||||
(defun mm/proc-retrieve-mail-update-db ()
|
||||
"Try to retrieve mail (using the user-provided shell command),
|
||||
and update the database afterwards."
|
||||
(unless mm/get-mail-command
|
||||
(error "`mm/get-mail-command' is not defined"))
|
||||
(let ((buf (get-buffer-create mm/update-buffer-name)))
|
||||
(split-window-vertically -8)
|
||||
(switch-to-buffer-other-window buf)
|
||||
(with-current-buffer buf
|
||||
(erase-buffer))
|
||||
(message "Retrieving mail...")
|
||||
(call-process mm/get-mail-command nil buf t)
|
||||
(message "Updating the database...")
|
||||
(mm/proc-index mm/maildir)
|
||||
(with-current-buffer buf
|
||||
(kill-buffer-and-window))))
|
||||
|
||||
|
||||
(provide 'mm-proc)
|
||||
420
emacs/mm-send.el
Normal file
420
emacs/mm-send.el
Normal file
@ -0,0 +1,420 @@
|
||||
;; mm-send.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, various functions to compose/send messages, piggybacking on
|
||||
;; gnus' message mode
|
||||
|
||||
;; mm
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
;; we use some stuff from gnus...
|
||||
(require 'message)
|
||||
(require 'mail-parse)
|
||||
|
||||
|
||||
;; internal variables / constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defconst mm/msg-draft-name "*mm-draft*"
|
||||
"Name for draft messages.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; FIXME
|
||||
(defun mm/mu-binary-version () "0.98pre")
|
||||
|
||||
|
||||
(defun mm/msg-user-agent ()
|
||||
"Return the User-Agent string for mm. This is either the value
|
||||
of `mm/user-agent', or, if not set, a string based on the
|
||||
version of mm and emacs."
|
||||
(or mm/user-agent
|
||||
(format "mu %s; emacs %s" (mm/mu-binary-version) emacs-version)))
|
||||
|
||||
(defun mm/view-body (msg)
|
||||
"Get the body for this message, which is either :body-txt,
|
||||
or if not available, :body-html converted to text)."
|
||||
(or (plist-get msg :body-txt)
|
||||
(with-temp-buffer
|
||||
(plist-get msg :body-html)
|
||||
(html2text)
|
||||
(buffer-string))
|
||||
"No body found"))
|
||||
|
||||
(defun mm/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 `mm/msg-citation-prefix' to each line. If there is
|
||||
no body in MSG, return nil."
|
||||
(let* ((from (plist-get msg :from))
|
||||
;; first try plain-text, then html
|
||||
(body (or (plist-get msg :body-txt)
|
||||
(with-temp-buffer
|
||||
(plist-get msg :body-html)
|
||||
(html2text)
|
||||
(buffer-string))))
|
||||
(body (and body (replace-regexp-in-string "[\r\240]" " " body))))
|
||||
(when body
|
||||
(concat
|
||||
(format "On %s, %s wrote:"
|
||||
(format-time-string "%c" (plist-get 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 mm/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 mm/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\."
|
||||
(when lst
|
||||
(mapconcat
|
||||
(lambda (recip)
|
||||
(let ((name (car recip)) (email (cdr recip)))
|
||||
(if name
|
||||
(format "%s <%s>" name email)
|
||||
(format "%s" email)))) lst ", ")))
|
||||
|
||||
|
||||
(defun mm/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 mm/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 (plist-get msg :references))
|
||||
(old-msgid (plist-get msg :message-id)))
|
||||
(when old-msgid
|
||||
(setq refs (append refs (list old-msgid)))
|
||||
(mapconcat
|
||||
(lambda (msgid) (format "<%s>" msgid))
|
||||
refs ","))))
|
||||
|
||||
(defun mm/msg-to-create (msg)
|
||||
"Construct the To: header for a reply-message based on some
|
||||
message MSG. This takes the Reply-To address of MSG if it exist, or
|
||||
the From:-address otherwise. The result is either nil or a string
|
||||
which can be used for the To:-field. Note, when it's present,
|
||||
Reply-To contains a string of one or more addresses,
|
||||
comma-separated."
|
||||
(or
|
||||
(plist-get msg :reply-to)
|
||||
(mm/msg-recipients-to-string (plist-get msg :from))))
|
||||
|
||||
|
||||
(defun mm/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 old CC-list
|
||||
together with the old TO-list, 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 (plist-get msg :cc))
|
||||
(to-lst (plist-get msg :to)))
|
||||
(when reply-all
|
||||
(setq cc-lst (append cc-lst to-lst)))
|
||||
;; remove myself from cc
|
||||
(setq cc-lst (mm/msg-recipients-remove cc-lst user-mail-address))
|
||||
(mm/msg-recipients-to-string cc-lst)))
|
||||
|
||||
|
||||
(defun mm/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 mm/msg-create-reply (msg)
|
||||
"Create a draft message as a reply to MSG.
|
||||
|
||||
A reply message has fields:
|
||||
From: - see `mu-msg-from-create'
|
||||
To: - see `mm/msg-to-create'
|
||||
Cc: - see `mm/msg-cc-create'
|
||||
Subject: - `mm/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 `mm/msg-references-create'
|
||||
In-Reply-To: - message-id of MSG
|
||||
User-Agent - see `mm/msg-user-agent'
|
||||
|
||||
Then follows `mail-header-separator' (for `message-mode' to separate
|
||||
body from headers)
|
||||
|
||||
And finally, the cited body of MSG, as per `mm/msg-cite-original'."
|
||||
(let* ((recipnum (+ (length (plist-get msg :to))
|
||||
(length (plist-get msg :cc))))
|
||||
(reply-all (when (> recipnum 1)
|
||||
(yes-or-no-p
|
||||
(format "Reply to all ~%d recipients? "
|
||||
(+ recipnum))))))
|
||||
(concat
|
||||
(mm/msg-header "From" (or (mm/msg-from-create) ""))
|
||||
(when (boundp 'mail-reply-to)
|
||||
(mm/msg-header "Reply-To" mail-reply-to))
|
||||
|
||||
(mm/msg-header "To" (or (mm/msg-to-create msg) ""))
|
||||
(mm/msg-header "Cc" (mm/msg-cc-create msg reply-all))
|
||||
|
||||
(mm/msg-header "User-agent" (mm/msg-user-agent))
|
||||
(mm/msg-header "References" (mm/msg-references-create msg))
|
||||
|
||||
(mm/msg-header "In-reply-to" (format "<%s>" (plist-get msg :message-id)))
|
||||
|
||||
(mm/msg-header "Subject"
|
||||
(concat mm/msg-reply-prefix (plist-get msg :subject)))
|
||||
|
||||
(propertize mail-header-separator 'read-only t 'intangible t) '"\n"
|
||||
|
||||
"\n\n"
|
||||
(mm/msg-cite-original msg))))
|
||||
|
||||
;; TODO: attachments
|
||||
(defun mm/msg-create-forward (msg)
|
||||
"Create a draft forward message for MSG.
|
||||
|
||||
A forward message has fields:
|
||||
From: - see `mm/msg-from-create'
|
||||
To: - empty
|
||||
Subject: - `mm/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 `mm/msg-references-create'
|
||||
User-Agent - see `mm/msg-user-agent'
|
||||
|
||||
Then follows `mail-header-separator' (for `message-mode' to separate
|
||||
body from headers)
|
||||
|
||||
And finally, the cited body of MSG, as per `mm/msg-cite-original'."
|
||||
(concat
|
||||
(mm/msg-header "From" (or (mm/msg-from-create) ""))
|
||||
(when (boundp 'mail-reply-to)
|
||||
(mm/msg-header "Reply-To" mail-reply-to))
|
||||
|
||||
(mm/msg-header "To" "")
|
||||
(mm/msg-header "User-agent" (mm/msg-user-agent))
|
||||
(mm/msg-header "References" (mm/msg-references-create msg))
|
||||
(mm/msg-header"Subject"
|
||||
(concat mm/msg-forward-prefix (plist-get msg :subject)))
|
||||
(propertize mail-header-separator 'read-only t 'intangible t) "\n"
|
||||
|
||||
"\n\n"
|
||||
(mm/msg-cite-original msg)))
|
||||
|
||||
(defun mm/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 `mm/msg-user-agent'
|
||||
|
||||
Then follows `mail-header-separator' (for `message-mode' to separate
|
||||
body from headers)."
|
||||
(concat
|
||||
(mm/msg-header "From" (or (mm/msg-from-create) ""))
|
||||
(when (boundp 'mail-reply-to)
|
||||
(mm/msg-header "Reply-To" mail-reply-to))
|
||||
(mm/msg-header "To" "")
|
||||
(mm/msg-header "User-agent" (mm/msg-user-agent))
|
||||
(mm/msg-header "Subject" "")
|
||||
(propertize mail-header-separator 'read-only t 'intangible t) "\n"))
|
||||
|
||||
(defun mm/msg-open-draft (compose-type &optional msg)
|
||||
"Open a draft file for a new message, creating it if it does not
|
||||
already exist, and optionally fill it with STR. Function also adds
|
||||
the new message to the database. When the draft message is added to
|
||||
the database, `mm/path-docid-map' will be updated, so that we can
|
||||
use the new docid. Returns the full path to the new message."
|
||||
(let* ((hostname
|
||||
(downcase
|
||||
(save-match-data
|
||||
(substring system-name
|
||||
(string-match "^[^.]+" system-name) (match-end 0)))))
|
||||
(draft
|
||||
(concat mm/maildir mm/drafts-folder "/cur/"
|
||||
(format "%s-%x%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
|
||||
(format-time-string "%Y%m%d" (current-time))
|
||||
(emacs-pid) (random t) hostname)))
|
||||
(str (case compose-type
|
||||
(reply (mm/msg-create-reply msg))
|
||||
(forward (mm/msg-create-forward msg))
|
||||
(new (mm/msg-create-new))
|
||||
(t (error "unsupported compose-type %S" compose-type)))))
|
||||
(when str
|
||||
(with-temp-file draft
|
||||
(insert str)
|
||||
(write-file draft)))
|
||||
|
||||
;; save our file immediately, add add it to the db; thus, we can retrieve
|
||||
;; the new docid from `mm/path-docid-map'.
|
||||
(mm/proc-add draft mm/drafts-folder)
|
||||
draft))
|
||||
|
||||
|
||||
(defun mm/send-compose-handler (compose-type &optional msg)
|
||||
"Create a new draft message, or open an existing one.
|
||||
|
||||
COMPOSE-TYPE determines the kind of message to compose and is a
|
||||
symbol, either `reply', `forward', `edit', `new'. `edit' is for
|
||||
editing existing messages.
|
||||
|
||||
When COMPOSE-TYPE is `reply' or `forward', MSG should be a message
|
||||
plist. If COMPOSE-TYPE is `new', MSG should be nil.
|
||||
|
||||
The name of the draft folder is constructed from the concatenation
|
||||
of `mm/maildir' and `mm/drafts-folder' (therefore, these must be
|
||||
set).
|
||||
|
||||
The message file name is a unique name determined by
|
||||
`mm/msg-draft-file-name'.
|
||||
|
||||
The initial STR would be created from either `mm/msg-create-reply',
|
||||
ar`mm/msg-create-forward' or `mm/msg-create-new'. The editing buffer is
|
||||
using Gnus' `message-mode'."
|
||||
(unless mm/maildir (error "mm/maildir not set"))
|
||||
(unless mm/drafts-folder (error "mm/drafts-folder not set"))
|
||||
(let ((draft
|
||||
(if (member compose-type '(reply forward new))
|
||||
(mm/msg-open-draft compose-type msg)
|
||||
(if (eq compose-type 'edit)
|
||||
(plist-get msg :path)
|
||||
(error "unsupported compose-type %S" compose-type)))))
|
||||
|
||||
(unless (file-readable-p draft)
|
||||
(error "Cannot read %s" path))
|
||||
|
||||
(find-file draft)
|
||||
(message-mode)
|
||||
|
||||
(make-local-variable 'write-file-functions)
|
||||
|
||||
;; update the db when the file is saved...]
|
||||
(add-to-list 'write-file-functions
|
||||
(lambda() (mm/proc-add (buffer-file-name) mm/drafts-folder)))
|
||||
|
||||
;; hook our functions up with sending of the message
|
||||
(add-hook 'message-sent-hook 'mm/msg-save-to-sent nil t)
|
||||
(add-hook 'message-sent-hook 'mm/send-set-parent-flag nil t)
|
||||
|
||||
(let ((message-hidden-headers
|
||||
`("^References:" "^Face:" "^X-Face:" "^X-Draft-From:"
|
||||
"^User-agent:")))
|
||||
(message-hide-headers))
|
||||
|
||||
(if (eq compose-type 'new)
|
||||
(message-goto-to)
|
||||
(message-goto-body))))
|
||||
|
||||
|
||||
(defun mm/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'."
|
||||
(unless mm/sent-folder (error "mm/sent-folder not set"))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
;; remove the --text follows this line-- separator
|
||||
(if (search-forward-regexp (concat "^" mail-header-separator "\n"))
|
||||
(replace-match "")
|
||||
(error "cannot find mail-header-separator"))
|
||||
|
||||
(save-buffer)
|
||||
(let ((docid (gethash (buffer-file-name) mm/path-docid-map)))
|
||||
(unless docid (error "unknown message (%S)" (buffer-file-name)))
|
||||
;; ok, all seems well, well move the message to the sent-folder
|
||||
(mm/proc-move-msg docid mm/sent-folder "-T-D+S")
|
||||
;; we can remove the value from the hash now, if we can establish there
|
||||
;; are not other compose buffers using this very same docid...
|
||||
|
||||
;; mark the buffer as read-only, as its pointing at a non-existing file
|
||||
;; now...
|
||||
(kill-buffer-and-window)
|
||||
(message "Message has been sent"))))
|
||||
|
||||
|
||||
|
||||
(defun mm/send-set-parent-flag ()
|
||||
"Set the 'replied' flag on messages we replied to, and the
|
||||
'passed' flag on message we have forwarded.
|
||||
|
||||
If a message has a 'in-reply-to' header, it is considered a reply
|
||||
to the message with the corresponding message id. If it does not
|
||||
have an 'in-reply-to' header, but does have a 'references' header,
|
||||
it is considered to be a forward message for the message
|
||||
corresponding with the /last/ message-id in the references header.
|
||||
|
||||
Now, if the message has been determined to be either a forwarded
|
||||
message or a reply, we instruct the server to update that message
|
||||
with resp. the 'P' (passed) flag for a forwarded message, or the
|
||||
'R' flag for a replied message.
|
||||
|
||||
This is meant to be called from message mode's
|
||||
`message-sent-hook'."
|
||||
(let ((in-reply-to (message-fetch-field "in-reply-to"))
|
||||
(forwarded-from)
|
||||
(references (message-fetch-field "references")))
|
||||
(unless in-reply-to
|
||||
(when references
|
||||
(with-temp-buffer ;; inspired by `message-shorten-references'.
|
||||
(insert references)
|
||||
(goto-char (point-min))
|
||||
(let ((refs))
|
||||
(while (re-search-forward "<[^ <]+@[^ <]+>" nil t)
|
||||
(push (match-string 0) refs))
|
||||
(setq forwarded-from (car-safe (last refs)))))))
|
||||
;; remove the <>
|
||||
(when (and in-reply-to (string-match "<\\(.*\\)>" in-reply-to))
|
||||
(mm/proc-flag (match-string 1 in-reply-to) "+R"))
|
||||
(when (and forwarded-from (string-match "<\\(.*\\)>" forwarded-from))
|
||||
(mm/proc-flag (match-string 1 forwarded-from) "+P"))))
|
||||
|
||||
(provide 'mm-send)
|
||||
119
emacs/mm-tech.org
Normal file
119
emacs/mm-tech.org
Normal file
@ -0,0 +1,119 @@
|
||||
* mm
|
||||
|
||||
I haven't written many =emacs-fu= posts recently, but that doesn't mean I
|
||||
haven't used emacs a lot. In fact, over the last few months I've been working on
|
||||
a bigger emacs-related project; the working title is =mm=, and it's an
|
||||
emacs-based e-mail client based on my [[http://www.djcbsoftware.nl/code/mu][mu]] maildir searcher/indexer that I
|
||||
discussed before. Even though I've been using =mm= myself for about two months,
|
||||
it's not really ready from prime-time yet - but I'm planning to have something
|
||||
ready this year still.
|
||||
|
||||
In this post, let me discuss some of the technical background, which may be
|
||||
interesting for others planning emacs-based front-ends to other tools.
|
||||
|
||||
* How to make an emacs-based e-mail client
|
||||
|
||||
Emacs does not (as of today) support threads; but one way to do asynchronous
|
||||
processing is to start another process, and let emacs deal with its
|
||||
output. Let us see how...
|
||||
|
||||
** Getting output from =mu=
|
||||
|
||||
One way to implement this (for =mu=), is to call the =mu= command-line tool
|
||||
with some parameters and then parse its output. In fact, that is how some
|
||||
tools do it, and it was my first approach - so I would invoke =mu find= and
|
||||
then process the output in emacs (more about that in a minute).
|
||||
|
||||
However, then I realized that I'd need to load the entire e-mail Xapian
|
||||
database for each invocation. Wouldn't it be nicer to keep a running =mu=
|
||||
instance around? Indeed, it would - so I implemented the =mu server=
|
||||
sub-command. Now, when you run =mu server=, you get a shell, in which you can
|
||||
give commands to =mu=, and which will then spit out the results. =mu server=
|
||||
is not really meant for humans, but still I can use it manually, which is
|
||||
great for debugging.
|
||||
|
||||
The next question was what format mu should use for its output for emacs to
|
||||
process. Some other programs use =JSON= here, but I figured that it would be
|
||||
easier (and possibly, more efficient) just to use emacs' native
|
||||
=s-expressions= (=plists= to be precise). So that is what I did - and I can
|
||||
easily evaluate them using =read-from-string=.
|
||||
|
||||
** Processing the output in emacs
|
||||
|
||||
So, now let's look how we process the data from =mu server= in emacs.
|
||||
|
||||
First you create a process with, for example, =start-process=, and then
|
||||
register a filter function for it, which will be invoked whenever the process
|
||||
has some chunk of output. Something like:
|
||||
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(let ((proc (start-process <arguments>)))
|
||||
(set-process-filter proc 'my-process-filter)
|
||||
(set-process-sentinel proc 'my-process-sentinel))
|
||||
#+END_SRC
|
||||
|
||||
Note, the process sentinel is invoked when the process is terminated -- so there
|
||||
you can clean things up.
|
||||
|
||||
The function =my-process-filter= is a user-defined function that takes the
|
||||
process and the chunk of output as arguments; in =mm= it looks something like
|
||||
(pseudo-lisp):
|
||||
#+begin_SRC emacs-lisp
|
||||
(defun my-process-filter (proc str)
|
||||
(setq mm/buf (concat mm/buf str)) ;; a global var updated with the new chunk
|
||||
(when <we-have-received-a-full-expression>
|
||||
<eat-expression-from mm/buf>
|
||||
<evaluate-expression>))
|
||||
#+end_src
|
||||
|
||||
The =<evaluate-expression>= de-multiplexes the s-expression we got. For example,
|
||||
if the s-expression looks like an e-mail message header, it will be processed by
|
||||
the header-handling function, which will append it to the header list. If the
|
||||
s-expression looks like an error message, it will be reported to the user. And
|
||||
so on.
|
||||
|
||||
Finally, let me try to answer some anticipated questions:
|
||||
|
||||
* Why does the world need yet another e-mail client?
|
||||
|
||||
I don't the world needs another client, but I spend a *lot* of time
|
||||
(professionally and privately) with my e-mail client, so I'd like it to behave
|
||||
exactly like I want it to. An even more important goal for me was to write
|
||||
some bigger program in emacs lisp, to better understand the language and its
|
||||
idioms.
|
||||
|
||||
Specifically, when it comes to emacs-based clients, I have tried a few of
|
||||
them. I never really got into =gnus=; I think it is by far the most popular
|
||||
emacs-based mail client, but I found it hard to make behave the way I like it;
|
||||
and in particular, I do not like its indirect approach to Maildirs.
|
||||
|
||||
Then, for some years I've been using Wanderlust; a fine, very feature-rich
|
||||
client, but it shows its age - and especially with emacs-24, its cache file
|
||||
got corrupted very often, requiring me to delete them etc. Still, you will
|
||||
recognize some Wanderlust features in =mm/mu=.
|
||||
|
||||
* Why not use [[http://notmuchmail.org/][notmuch]]? It seems similar.
|
||||
|
||||
There are certainly similarities with =notmuch= (and to some lesser extent,
|
||||
with [[https://github.com/nicferrier/md][md]]) -- the overall architecture is similar: both are scanning maildirs,
|
||||
using [[http://spruce.sourceforge.net/gmime/][GMime]] and [[http://xapian.org/][Xapian]]. (=mu= precedes =notmuch= by a year or so; but
|
||||
=notmuch= was the first to add an emacs front-end).
|
||||
|
||||
There are some differences as well. The main thing is that in =notmuch='s
|
||||
philosophy, messages are usually not moved or deleted, but instead uses tags
|
||||
in the database. While tags are nice, I like the 'state' to be in the messages
|
||||
and the folders they are in, which it easy to synchronize with other email
|
||||
clients (or synchronize with IMAP-folders through [[http://offlineimap.org/][OfflineIMAP]]). I'd like to be
|
||||
able to move messages around, delete messages and so on. This is in fact one
|
||||
of the things I liked in [[http://www.gohome.org/wl/][Wanderlust]], and wouldn't want to live without - so
|
||||
=mu=/=mm= make this really easy.
|
||||
|
||||
Clearly, the emacs-interface to =notmuch= is more mature, and the development
|
||||
team is bigger, so I'd give it a try. On the other hand, if you happen to like
|
||||
e-mail the way I like it, =mm= may be something for you.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
672
emacs/mm-view.el
Normal file
672
emacs/mm-view.el
Normal file
@ -0,0 +1,672 @@
|
||||
;; mm-view.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:')
|
||||
|
||||
;; mm
|
||||
|
||||
;;; Code:
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'html2text)
|
||||
(require 'filladapt)
|
||||
(require 'comint)
|
||||
|
||||
(defconst mm/view-buffer-name "*mm-view*"
|
||||
"*internal* Name for the message view buffer")
|
||||
|
||||
(defconst mm/view-raw-buffer-name "*mm-view-raw*"
|
||||
"*internal* Name for the raw message view buffer")
|
||||
|
||||
;; some buffer-local variables
|
||||
(defvar mm/hdrs-buffer nil
|
||||
"*internal* Headers buffer connected to this view.")
|
||||
|
||||
(defvar mm/current-msg nil
|
||||
"*internal* The plist describing the current message.")
|
||||
|
||||
(defun mm/view (msg hdrsbuf &optional update)
|
||||
"Display the message MSG in a new buffer, and keep in sync with HDRSBUF.
|
||||
'In sync' here means that moving to the next/previous message in
|
||||
the the message view affects HDRSBUF, as does marking etc. If
|
||||
UPDATE is non-nil, the current message will be (visually) updated.
|
||||
|
||||
As a side-effect, a message that is being viewed loses its 'unread'
|
||||
marking if it still had that."
|
||||
(let ((buf (get-buffer-create mm/view-buffer-name))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(insert
|
||||
(mapconcat
|
||||
(lambda (field)
|
||||
(let ((fieldname (cdr (assoc field mm/header-names)))
|
||||
(fieldval (plist-get msg field)))
|
||||
(case field
|
||||
|
||||
(:subject (mm/view-header fieldname fieldval))
|
||||
(:path (mm/view-header fieldname fieldval))
|
||||
(:maildir (mm/view-header fieldname fieldval))
|
||||
(:flags (mm/view-header fieldname
|
||||
(if fieldval (format "%S" fieldval) "")))
|
||||
;; contact fields
|
||||
(:to (mm/view-contacts msg field))
|
||||
(:from (mm/view-contacts msg field))
|
||||
(:cc (mm/view-contacts msg field))
|
||||
(:bcc (mm/view-contacts msg field))
|
||||
|
||||
;; if we (`user-mail-address' are the From, show To, otherwise,
|
||||
;; show From
|
||||
(:from-or-to
|
||||
(let* ((from (plist-get msg :from))
|
||||
(from (and from (cdar from))))
|
||||
(if (and from (string-match mm/user-mail-address-regexp from))
|
||||
(mm/view-contacts msg :to)
|
||||
(mm/view-contacts msg :from))))
|
||||
|
||||
;; date
|
||||
(:date
|
||||
(let ((datestr
|
||||
(when fieldval (format-time-string mm/view-date-format fieldval))))
|
||||
(if datestr (mm/view-header fieldname datestr) "")))
|
||||
;; size
|
||||
(:size (mm/view-size msg)
|
||||
(let ((sizestr (when size (format "%d bytes"))))
|
||||
(if sizestr (mm/view-header fieldname sizestr))))
|
||||
;; attachments
|
||||
(:attachments (mm/view-attachments msg))
|
||||
(t (error "Unsupported field: %S" field)))))
|
||||
mm/view-fields "")
|
||||
"\n"
|
||||
(mm/view-body msg))
|
||||
|
||||
;; initialize view-mode
|
||||
(mm/view-mode)
|
||||
(setq ;; these are buffer-local
|
||||
mode-name (if (plist-get msg :subject)
|
||||
(truncate-string-to-width (plist-get msg :subject) 16 0 nil t)
|
||||
(propertize "No subject" 'face 'mm/system-face))
|
||||
mm/current-msg msg
|
||||
mm/hdrs-buffer hdrsbuf
|
||||
mm/link-map (make-hash-table :size 32 :rehash-size 2 :weakness nil))
|
||||
|
||||
(switch-to-buffer buf)
|
||||
(goto-char (point-min))
|
||||
(mm/view-beautify)
|
||||
|
||||
(unless update
|
||||
(mm/view-mark-as-read-maybe)))))
|
||||
|
||||
|
||||
(defun mm/view-body (msg)
|
||||
"Get the body for this message, which is either :body-txt,
|
||||
or if not available, :body-html converted to text)."
|
||||
(or (plist-get msg :body-txt)
|
||||
(with-temp-buffer
|
||||
(plist-get msg :body-html)
|
||||
(html2text)
|
||||
(buffer-string))
|
||||
"No body found"))
|
||||
|
||||
|
||||
(defun mm/view-header (key val &optional dont-propertize-val)
|
||||
"Show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD."
|
||||
(if val
|
||||
(concat
|
||||
(propertize key 'face 'mm/view-header-key-face) ": "
|
||||
(if dont-propertize-val
|
||||
val
|
||||
(propertize val 'face 'mm/view-header-value-face))
|
||||
"\n")
|
||||
""))
|
||||
|
||||
|
||||
(defun mm/view-contacts (msg field)
|
||||
"Add a header for a contact field (ie., :to, :from, :cc, :bcc)."
|
||||
(let* ((lst (plist-get msg field))
|
||||
(fieldname (cdr (assoc field mm/header-names)))
|
||||
(contacts
|
||||
(and lst
|
||||
(mapconcat
|
||||
(lambda(c)
|
||||
(let ((name (car c)) (email (cdr c)))
|
||||
(if name
|
||||
(format "%s <%s>" name email)
|
||||
(format "%s" email)))) lst ", "))))
|
||||
(if contacts
|
||||
(mm/view-header fieldname contacts)
|
||||
"")))
|
||||
|
||||
(defvar mm/attach-map nil
|
||||
"*internal* Hash which maps a number to a (part-id name mime-type).")
|
||||
|
||||
|
||||
(defun mm/view-attachments (msg)
|
||||
"Display attachment information; the field looks like something like:
|
||||
:attachments ((:index 4 :name \"test123.doc\"
|
||||
:mime-type \"application/msword\" :size 1234))."
|
||||
(let ((atts (plist-get msg :attachments)))
|
||||
(when atts
|
||||
(setq mm/attach-map
|
||||
(make-hash-table :size 32 :rehash-size 2 :weakness nil))
|
||||
(let* ((id 0)
|
||||
(vals
|
||||
(mapconcat
|
||||
(lambda (att)
|
||||
(let ( (index (plist-get att :index))
|
||||
(name (plist-get att :name))
|
||||
(mime-type (plist-get att :mime-type))
|
||||
(size (plist-get att :size)))
|
||||
(incf id)
|
||||
(puthash id att mm/attach-map)
|
||||
(concat
|
||||
(propertize (format "[%d]" id) 'face 'mm/view-attach-number-face)
|
||||
(propertize name 'face 'mm/view-link-face)
|
||||
(if size
|
||||
(concat
|
||||
"(" (propertize (mm/display-size size) 'face 'mm/view-header-key-face)
|
||||
")")
|
||||
"")
|
||||
)))
|
||||
atts ", ")))
|
||||
(mm/view-header (format "Attachments(%d)" id) vals t)))))
|
||||
|
||||
|
||||
(defvar mm/view-mode-map nil
|
||||
"Keymap for \"*mm-view*\" buffers.")
|
||||
(unless mm/view-mode-map
|
||||
(setq mm/view-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map "q" 'mm/view-quit-buffer)
|
||||
|
||||
(define-key map "s" 'mm/search)
|
||||
(define-key map "S" 'mm/search-full)
|
||||
|
||||
(define-key map "b" 'mm/search-bookmark)
|
||||
(define-key map "j" 'mm/jump-to-maildir)
|
||||
|
||||
(define-key map "g" 'mm/view-go-to-url)
|
||||
(define-key map "f" 'mm/compose-forward)
|
||||
(define-key map "r" 'mm/compose-reply)
|
||||
(define-key map "c" 'mm/compose-new)
|
||||
(define-key map "e" 'mm/edit-draft)
|
||||
|
||||
(define-key map "." 'mm/view-raw)
|
||||
(define-key map "|" 'mm/view-pipe)
|
||||
;; (define-key map "I" 'mm/inspect-message)
|
||||
|
||||
;; intra-message navigation
|
||||
(define-key map (kbd "SPC") 'scroll-up)
|
||||
(define-key map (kbd "<home>")
|
||||
'(lambda () (interactive) (goto-char (point-min))))
|
||||
(define-key map (kbd "<end>")
|
||||
'(lambda () (interactive) (goto-char (point-max))))
|
||||
(define-key map (kbd "RET")
|
||||
'(lambda () (interactive) (scroll-up 1)))
|
||||
(define-key map (kbd "<backspace>")
|
||||
'(lambda () (interactive) (scroll-up -1)))
|
||||
|
||||
|
||||
;; navigation between messages
|
||||
(define-key map "n" 'mm/view-next-header)
|
||||
(define-key map "p" 'mm/view-prev-header)
|
||||
|
||||
;; attachments
|
||||
(define-key map "e" 'mm/view-extract-attachment)
|
||||
(define-key map "o" 'mm/view-open-attachment)
|
||||
|
||||
;; marking/unmarking
|
||||
(define-key map (kbd "<backspace>") 'mm/mark-for-trash)
|
||||
(define-key map "d" 'mm/view-mark-for-trash)
|
||||
|
||||
(define-key map (kbd "<delete>") 'mm/view-mark-for-delete)
|
||||
(define-key map "D" 'mm/view-mark-for-delete)
|
||||
(define-key map "a" 'mm/mark-for-move-quick)
|
||||
|
||||
(define-key map "m" 'mm/view-mark-for-move)
|
||||
|
||||
;; misc
|
||||
(define-key map "w" 'mm/view-toggle-wrap-lines)
|
||||
(define-key map "h" 'mm/view-toggle-hide-cited)
|
||||
|
||||
(define-key map "R" 'mm/view-refresh)
|
||||
|
||||
;; next 3 only warn user when attempt in the message view
|
||||
(define-key map "u" 'mm/view-unmark)
|
||||
(define-key map "U" 'mm/view-unmark)
|
||||
(define-key map "x" 'mm/view-marked-execute)
|
||||
|
||||
;; menu
|
||||
(define-key map [menu-bar] (make-sparse-keymap))
|
||||
(let ((menumap (make-sparse-keymap "View")))
|
||||
(define-key map [menu-bar headers] (cons "View" menumap))
|
||||
|
||||
(define-key menumap [quit-buffer] '("Quit view" . mm/view-quit-buffer))
|
||||
|
||||
(define-key menumap [sepa0] '("--"))
|
||||
(define-key menumap [wrap-lines]
|
||||
'("Toggle wrap lines" . mm/view-toggle-wrap-lines))
|
||||
(define-key menumap [hide-cited]
|
||||
'("Toggle hide cited" . mm/view-toggle-hide-cited))
|
||||
(define-key menumap [view-raw]
|
||||
'("View raw message" . mm/view-raw))
|
||||
(define-key menumap [pipe]
|
||||
'("Pipe through shell" . mm/view-pipe))
|
||||
(define-key menumap [inspect]
|
||||
'("Inspect with guile" . mm/inspect-message))
|
||||
|
||||
(define-key menumap [sepa8] '("--"))
|
||||
(define-key menumap [open-att]
|
||||
'("Open attachment" . mm/view-open-attachment))
|
||||
(define-key menumap [extract-att]
|
||||
'("Extract attachment" . mm/view-extract-attachment))
|
||||
(define-key menumap [goto-url]
|
||||
'("Visit URL" . mm/view-go-to-url))
|
||||
|
||||
(define-key menumap [sepa1] '("--"))
|
||||
(define-key menumap [mark-delete]
|
||||
'("Mark for deletion" . mm/view-mark-for-delete))
|
||||
(define-key menumap [mark-trash]
|
||||
'("Mark for trash" . mm/view-mark-for-trash))
|
||||
(define-key menumap [mark-move]
|
||||
'("Mark for move" . mm/view-mark-for-move))
|
||||
|
||||
(define-key menumap [sepa2] '("--"))
|
||||
(define-key menumap [compose-new] '("Compose new" . mm/compose-new))
|
||||
(define-key menumap [forward] '("Forward" . mm/compose-forward))
|
||||
(define-key menumap [reply] '("Reply" . mm/compose-reply))
|
||||
(define-key menumap [sepa3] '("--"))
|
||||
|
||||
(define-key menumap [search] '("Search" . mm/search))
|
||||
(define-key menumap [jump] '("Jump to maildir" . mm/jump-to-maildir))
|
||||
|
||||
(define-key menumap [sepa4] '("--"))
|
||||
(define-key menumap [next] '("Next" . mm/view-next-header))
|
||||
(define-key menumap [previous] '("Previous" . mm/view-prev-header)))
|
||||
map)))
|
||||
|
||||
(fset 'mm/view-mode-map mm/view-mode-map)
|
||||
|
||||
|
||||
(defvar mm/wrap-lines nil
|
||||
"*internal* Whether to wrap lines or not (variable controlled by
|
||||
`mm/view-toggle-wrap-lines').")
|
||||
|
||||
(defvar mm/hide-cited nil
|
||||
"*internal* Whether to hide cited lines or not (the variable can
|
||||
be changed with `mm/view-toggle-hide-cited').")
|
||||
|
||||
|
||||
(defun mm/view-mode ()
|
||||
"Major mode for viewing an e-mail message."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map mm/view-mode-map)
|
||||
|
||||
(make-local-variable 'mm/hdrs-buffer)
|
||||
(make-local-variable 'mm/current-msg)
|
||||
(make-local-variable 'mm/link-map)
|
||||
|
||||
(make-local-variable 'mm/wrap-lines)
|
||||
(make-local-variable 'mm/hide-cited)
|
||||
|
||||
(setq major-mode 'mm/view-mode mode-name mm/view-buffer-name)
|
||||
(setq truncate-lines t buffer-read-only t))
|
||||
|
||||
;;;;;;
|
||||
|
||||
|
||||
;; we mark messages are as read when we leave the message; ie., when skipping to
|
||||
;; the next/previous one, or leaving the view buffer altogether.
|
||||
|
||||
(defun mm/view-mark-as-read-maybe ()
|
||||
"Clear the current message's New/Unread status and set it to
|
||||
Seen; if the message is not New/Unread, do nothing."
|
||||
(when mm/current-msg
|
||||
(let ((flags (plist-get mm/current-msg :flags))
|
||||
(docid (plist-get mm/current-msg :docid)))
|
||||
;; is it a new message?
|
||||
(when (or (member 'unread flags) (member 'new flags))
|
||||
(mm/proc-flag docid "+S-u-N")))))
|
||||
|
||||
|
||||
(defvar mm/link-map nil
|
||||
"*internal* A map of some number->url so we can jump to url by number.")
|
||||
|
||||
(defun mm/view-beautify ()
|
||||
"Improve the message view a bit, by making URLs clickable,
|
||||
removing '^M' etc."
|
||||
(let ((num 0))
|
||||
(save-excursion
|
||||
;; remove the stupid CRs
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "[\r\240]" nil t)
|
||||
(replace-match " " nil t))
|
||||
;; give the footer a different color...
|
||||
(goto-char (point-min))
|
||||
(let ((p (search-forward "\n-- \n" nil t)))
|
||||
(when p
|
||||
(add-text-properties p (point-max) '(face mm/view-footer-face))))
|
||||
;; this is fairly simplistic...
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(https?://[-a-zA-Z0-9?_.$%/=+&#@!~,:;]*\\)\\>"
|
||||
nil t)
|
||||
(let ((subst (propertize (match-string-no-properties 0)
|
||||
'face 'mm/view-link-face)))
|
||||
(incf num)
|
||||
(puthash num (match-string-no-properties 0) mm/link-map)
|
||||
(replace-match (concat subst
|
||||
(propertize (format "[%d]" num)
|
||||
'face 'mm/view-url-number-face))))))))
|
||||
|
||||
|
||||
;; raw mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; some buffer-local variables
|
||||
(defvar mm/view-buffer nil
|
||||
"*internal* View buffer connected to this raw view.")
|
||||
|
||||
(defun mm/view-raw-mode ()
|
||||
"Major mode for viewing of raw e-mail message."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map mm/view-raw-mode-map)
|
||||
|
||||
(make-local-variable 'mm/view-buffer)
|
||||
|
||||
(setq major-mode 'mm/view-raw-mode
|
||||
mode-name "mm: raw view")
|
||||
(setq truncate-lines t buffer-read-only t))
|
||||
|
||||
(defvar mm/view-raw-mode-map nil
|
||||
"Keymap for \"*mm-view-raw*\" buffers.")
|
||||
|
||||
(unless mm/view-raw-mode-map
|
||||
(setq mm/view-raw-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
||||
(define-key map "q" 'mm/view-raw-quit-buffer)
|
||||
(define-key map "." 'mm/view-raw-quit-buffer)
|
||||
|
||||
;; intra-message navigation
|
||||
(define-key map (kbd "SPC") 'scroll-up)
|
||||
(define-key map (kbd "<home>")
|
||||
'(lambda () (interactive) (goto-char (point-min))))
|
||||
(define-key map (kbd "<end>")
|
||||
'(lambda () (interactive) (goto-char (point-max))))
|
||||
(define-key map (kbd "RET")
|
||||
'(lambda () (interactive) (scroll-up 1)))
|
||||
(define-key map (kbd "<backspace>")
|
||||
'(lambda () (interactive) (scroll-up -1)))
|
||||
|
||||
;; menu
|
||||
(define-key map [menu-bar] (make-sparse-keymap))
|
||||
(let ((menumap (make-sparse-keymap "Raw view")))
|
||||
(define-key map [menu-bar headers] (cons "Raw view" menumap))
|
||||
(define-key menumap [quit-buffer] '("Quit" .
|
||||
mm/view-raw-quit-buffer))
|
||||
map))))
|
||||
|
||||
(fset 'mm/view-raw-mode-map mm/view-raw-mode-map)
|
||||
|
||||
|
||||
(defun mm/view-raw-message (msg view-buffer)
|
||||
"Display the raw contents of message MSG in a new buffer."
|
||||
(let ((buf (get-buffer-create mm/view-raw-buffer-name))
|
||||
(inhibit-read-only t)
|
||||
(file (plist-get msg :path)))
|
||||
(unless (and file (file-readable-p file))
|
||||
(error "Not a readable file: %S" file))
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(insert-file file)
|
||||
;; initialize view-mode
|
||||
(mm/view-raw-mode)
|
||||
(setq mm/view-buffer view-buffer)
|
||||
(switch-to-buffer buf)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
|
||||
(defun mm/view-shell-command-on-raw-message (msg view-buffer cmd)
|
||||
"Process the raw message with shell command CMD."
|
||||
(let ((buf (get-buffer-create mm/view-raw-buffer-name))
|
||||
(inhibit-read-only t)
|
||||
(file (plist-get msg :path)))
|
||||
(unless (and file (file-readable-p file))
|
||||
(error "Not a readable file: %S" file))
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(process-file-shell-command cmd file buf)
|
||||
(mm/view-raw-mode)
|
||||
(setq mm/view-buffer view-buffer)
|
||||
(switch-to-buffer buf)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
|
||||
(defun mm/view-raw-quit-buffer ()
|
||||
"Quit the raw view and return to the message."
|
||||
(interactive)
|
||||
(if (buffer-live-p mm/view-buffer)
|
||||
(switch-to-buffer mm/view-buffer)
|
||||
(kill-buffer)))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; functions for org-contacts
|
||||
|
||||
(defun mm/org-contacts-from (name-or-email)
|
||||
"Get a message field if we are in view mode; NAME-OR-EMAIL should
|
||||
be either 'name or 'email to get the corresponding field. If the
|
||||
field is not found, \"\" is returned. Use this with org-contact
|
||||
with a template like:
|
||||
|
||||
(\"c\" \"Contacts\" entry (file \"~/Org/contacts.org\")
|
||||
\"* %(mm/org-contacts-from 'name)
|
||||
:PROPERTIES:
|
||||
:EMAIL: %(mm/org-contacts-from 'email)
|
||||
:END:\")))
|
||||
|
||||
See the `org-contacts' documentation for more details."
|
||||
(with-current-buffer mm/view-buffer-name ;; hackish...
|
||||
(unless (eq major-mode 'mm/view-mode)
|
||||
(error "Not in mm/view mode."))
|
||||
(unless mm/current-msg
|
||||
(error "No current message."))
|
||||
(let ((from (car-safe (plist-get mm/current-msg :from))))
|
||||
(cond
|
||||
((not from) "") ;; nothing found
|
||||
((eq name-or-email 'name)
|
||||
(or (car-safe from) ""))
|
||||
((eq name-or-email 'email)
|
||||
(or (cdr-safe from) ""))
|
||||
(t (error "Not supported: %S" name-or-email))))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; Interactive functions
|
||||
|
||||
(defun mm/view-toggle-wrap-lines ()
|
||||
"Toggle line wrap in the message body."
|
||||
(interactive)
|
||||
(if mm/wrap-lines
|
||||
(progn
|
||||
(setq mm/wrap-lines nil)
|
||||
(mm/view-refresh)) ;; back to normal
|
||||
(save-excursion
|
||||
(let ((inhibit-read-only t))
|
||||
(setq mm/wrap-lines t)
|
||||
(goto-char (point-min))
|
||||
(when (search-forward "\n\n") ;; search for the message body
|
||||
(fill-region (point) (point-max)))))))
|
||||
|
||||
(defun mm/view-toggle-hide-cited ()
|
||||
"Toggle hiding of cited lines in the message body."
|
||||
(interactive)
|
||||
(if mm/hide-cited
|
||||
(progn
|
||||
(setq mm/hide-cited nil)
|
||||
(mm/view-refresh))
|
||||
(save-excursion
|
||||
(let ((inhibit-read-only t))
|
||||
(goto-char (point-min))
|
||||
(flush-lines "^[:blank:]*>")
|
||||
(setq mm/hide-cited t)))))
|
||||
|
||||
|
||||
(defun mm/view-refresh ()
|
||||
"Redisplay the current message."
|
||||
(interactive)
|
||||
(mm/view mm/current-msg mm/hdrs-buffer t))
|
||||
|
||||
|
||||
(defun mm/view-quit-buffer ()
|
||||
"Quit the message view and return to the headers."
|
||||
(interactive)
|
||||
(if (buffer-live-p mm/hdrs-buffer)
|
||||
(switch-to-buffer mm/hdrs-buffer)
|
||||
(kill-buffer)))
|
||||
|
||||
(defun mm/view-next-header ()
|
||||
"View the next header."
|
||||
(interactive)
|
||||
(when (mm/next-header)
|
||||
(mm/view-message)))
|
||||
|
||||
(defun mm/view-prev-header ()
|
||||
"View the previous header."
|
||||
(interactive)
|
||||
(when (mm/prev-header)
|
||||
(mm/view-message)))
|
||||
|
||||
(defun mm/view-mark-for-move ()
|
||||
"Mark the current message for moving."
|
||||
(interactive)
|
||||
(when (mm/mark-for-move)
|
||||
(mm/view-message)))
|
||||
|
||||
(defun mm/view-mark-for-trash ()
|
||||
"Mark the current message for moving to the trash folder."
|
||||
(interactive)
|
||||
(when (mm/mark-for-trash)
|
||||
(mm/view-message)))
|
||||
|
||||
(defun mm/view-mark-for-delete ()
|
||||
"Mark the current message for deletion."
|
||||
(interactive)
|
||||
(when (mm/mark-for-delete)
|
||||
(mm/view-message)))
|
||||
|
||||
(defun mm/view-extract-attachment (attnum)
|
||||
"Extract the attachment with ATTNUM."
|
||||
(unless mm/attachment-dir (error "`mm/attachment-dir' is not set"))
|
||||
(when (or (null mm/attach-map) (zerop (hash-table-count mm/attach-map)))
|
||||
(error "No attachments for this message"))
|
||||
(interactive "nAttachment to extract:")
|
||||
(let* ((att (gethash attnum mm/attach-map))
|
||||
(path (and att (concat mm/attachment-dir
|
||||
"/" (plist-get att :name))))
|
||||
(id (and att (plist-get att :index)))
|
||||
(retry t))
|
||||
(unless att (error "Not a valid attachment number"))
|
||||
(while retry
|
||||
(setq path (expand-file-name (read-string "Save as " path)))
|
||||
(setq retry
|
||||
(and (file-exists-p path)
|
||||
(not (y-or-n-p (concat "Overwrite " path "?"))))))
|
||||
(mm/proc-save (plist-get mm/current-msg :docid) id path)))
|
||||
|
||||
(defun mm/view-open-attachment (attnum)
|
||||
"Extract the attachment with ATTNUM"
|
||||
(unless mm/attach-map
|
||||
(error "No attachments for this message"))
|
||||
(interactive "nAttachment to open:")
|
||||
(let* ((att (gethash attnum mm/attach-map))
|
||||
(id (and att (plist-get att :index))))
|
||||
(unless id (error "Not a valid attachment number"))
|
||||
(mm/proc-open (plist-get mm/current-msg :docid) id)))
|
||||
|
||||
(defun mm/view-unmark ()
|
||||
"Warn user that unmarking only works in the header list."
|
||||
(interactive)
|
||||
(message "Unmarking needs to be done in the header list view"))
|
||||
|
||||
|
||||
(defun mm/view-marked-execute ()
|
||||
"Warn user that execution can only take place in n the header
|
||||
list."
|
||||
(interactive)
|
||||
(message "Execution needs to be done in the header list view"))
|
||||
|
||||
(defun mm/view-go-to-url (num)
|
||||
"Go to a numbered url."
|
||||
(interactive "nGo to url with number: ")
|
||||
(let ((url (gethash num mm/link-map)))
|
||||
(unless url (error "Invalid number for URL"))
|
||||
(browse-url url)))
|
||||
|
||||
(defun mm/view-raw ()
|
||||
"Show the the raw text of the current message."
|
||||
(interactive)
|
||||
(unless mm/current-msg
|
||||
(error "No current message"))
|
||||
(mm/view-raw-message mm/current-msg (current-buffer)))
|
||||
|
||||
(defun mm/view-pipe (cmd)
|
||||
"Pipe the message through shell command CMD, and display the
|
||||
results."
|
||||
(interactive "sShell command: ")
|
||||
(unless mm/current-msg
|
||||
(error "No current message"))
|
||||
(mm/view-shell-command-on-raw-message mm/current-msg (current-buffer) cmd))
|
||||
|
||||
(defconst mm/muile-buffer-name "*muile*"
|
||||
"Name of the buffer to execute muile.")
|
||||
|
||||
(defconst mm/muile-process-name "*muile*"
|
||||
"Name of the muile process.")
|
||||
|
||||
;; note, implementation is very basic/primitive; we probably need comint to do
|
||||
;; something like geiser does (http://www.nongnu.org/geiser/). Desirable
|
||||
;; features: a) the output is not editable b) tab-completions work
|
||||
(defun mm/inspect-message ()
|
||||
"Inspect the current message in the Guile/Muile shell."
|
||||
(interactive)
|
||||
(unless mm/muile-binary (error "`mm/muile-binary' is not defined"))
|
||||
(unless (or (file-executable-p mm/muile-binary)
|
||||
(executable-find mm/muile-binary))
|
||||
(error "%S not found" mm/muile-binary))
|
||||
(unless mm/current-msg
|
||||
(error "No current message"))
|
||||
(get-buffer-create mm/muile-buffer-name)
|
||||
(start-process mm/muile-buffer-name mm/muile-process-name
|
||||
mm/muile-binary "--msg" (plist-get mm/current-msg :path))
|
||||
(switch-to-buffer mm/muile-buffer-name)
|
||||
(shell-mode))
|
||||
|
||||
(provide 'mm-view)
|
||||
479
emacs/mm.el
Normal file
479
emacs/mm.el
Normal file
@ -0,0 +1,479 @@
|
||||
;;; 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))
|
||||
|
||||
(require 'mm-hdrs)
|
||||
(require 'mm-view)
|
||||
(require 'mm-main)
|
||||
(require 'mm-send)
|
||||
(require 'mm-proc)
|
||||
|
||||
(require 'mm-version) ;; auto-generated
|
||||
|
||||
;; mm-version.el is autogenerated, and defines mm/mu-version
|
||||
(require 'mm-version)
|
||||
|
||||
;; Customization
|
||||
|
||||
(defgroup mm nil
|
||||
"mm - the mu mail client"
|
||||
: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 specify 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)
|
||||
|
||||
(defcustom mm/get-mail-command nil
|
||||
"Shell command to run to retrieve new mail; e.g. 'offlineimap' or
|
||||
'fetchmail'."
|
||||
:type 'string
|
||||
:group 'mm
|
||||
:safe 'stringp)
|
||||
|
||||
(defcustom mm/attachment-dir (expand-file-name "~/")
|
||||
"Default directory for saving attachments."
|
||||
:type 'string
|
||||
:group 'mm
|
||||
:safe 'stringp)
|
||||
|
||||
(defvar mm/user-mail-address-regexp "$^"
|
||||
"Regular expression matching the user's mail address(es). This is
|
||||
used to distinguish ourselves from others, e.g. when replying and
|
||||
in :from-or-to headers. By default, match nothing.")
|
||||
|
||||
(defvar mm/date-format-long "%c"
|
||||
"Date format to use in the message view, in the format of
|
||||
`format-time-string'.")
|
||||
|
||||
(defvar mm/search-results-limit 500
|
||||
"Maximum number of search results (or -1 for unlimited). Since
|
||||
limiting search results speeds up searches significantly, it's
|
||||
useful to limit this. Note, to ignore the limit, use a prefix
|
||||
argument (C-u) before invoking the search.")
|
||||
|
||||
|
||||
(defvar mm/debug nil
|
||||
"When set to non-nil, log debug information to the *mm-log* buffer.")
|
||||
|
||||
(defvar mm/bookmarks
|
||||
'( ("flag:unread AND NOT flag:trashed" "Unread messages" ?u)
|
||||
("date:today..now" "Today's messages" ?t)
|
||||
("date:7d..now" "Last 7 days" ?w)
|
||||
("mime:image/*" "Messages with images" ?p))
|
||||
"A list of pre-defined queries; these will show up in the main
|
||||
screen. Each of the list elements is a three-element list of the
|
||||
form (QUERY DESCRIPTION KEY), where QUERY is a string with a mu
|
||||
query, DESCRIPTION is a short description of the query (this will
|
||||
show up in the UI), and KEY is a shortcut key for the query.")
|
||||
|
||||
|
||||
;; Folders
|
||||
|
||||
(defgroup mm/folders nil
|
||||
"Special folders for mm."
|
||||
:group 'mm)
|
||||
|
||||
;; (defcustom mm/inbox-folder nil
|
||||
;; "Your Inbox folder, relative to `mm/maildir', e.g. \"/Inbox\"."
|
||||
;; :type 'string
|
||||
;; :safe 'stringp
|
||||
;; :group 'mm/folders)
|
||||
|
||||
(defcustom mm/sent-folder nil
|
||||
"Your folder for sent messages, relative to `mm/maildir',
|
||||
e.g. \"/Sent Items\"."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/draft-folder nil
|
||||
"Your folder for draft messages, relative to `mm/maildir',
|
||||
e.g. \"/drafts\""
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/trash-folder nil
|
||||
"Your folder for trashed messages, relative to `mm/maildir',
|
||||
e.g. \"/trash\"."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
|
||||
(defcustom mm/maildir-shortcuts nil
|
||||
"A list of maildir shortcuts to enable quickly going to the
|
||||
particular for, or quickly moving messages towards them (i.e.,
|
||||
archiving or refiling). The list contains elements of the form
|
||||
(maildir . shortcut), where MAILDIR is a maildir (such as
|
||||
\"/archive/\"), and shortcut a single shortcut character. With
|
||||
this, in the header buffer and view buffer you can execute
|
||||
`mm/mark-for-move-quick' (or 'm', by default) or
|
||||
`mm/jump-to-maildir-quick' (or 'j', by default), followed by the
|
||||
designated shortcut character for the maildir.")
|
||||
|
||||
;; the headers view
|
||||
(defgroup mm/headers nil
|
||||
"Settings for the headers view."
|
||||
:group 'mm)
|
||||
|
||||
|
||||
(defcustom mm/headers-fields
|
||||
'( (:date . 25)
|
||||
(:flags . 6)
|
||||
(:from . 22)
|
||||
(:subject . 40))
|
||||
"A list of header fields to show in the headers buffer, and their
|
||||
respective widths in characters. A width of `nil' means
|
||||
'unrestricted', and this is best reserved fo the rightmost (last)
|
||||
field. For the complete list of available headers, see `mm/header-names'"
|
||||
:type (list 'symbol)
|
||||
:group 'mm/headers)
|
||||
|
||||
(defcustom mm/headers-date-format "%x %X"
|
||||
"Date format to use in the headers view, in the format of
|
||||
`format-time-string'."
|
||||
:type 'string
|
||||
:group 'mm/headers)
|
||||
|
||||
|
||||
;; the message view
|
||||
(defgroup mm/view nil
|
||||
"Settings for the message view."
|
||||
:group 'mm)
|
||||
|
||||
(defcustom mm/view-fields
|
||||
'(:from :to :cc :subject :flags :date :maildir :path :attachments)
|
||||
"Header fields to display in the message view buffer. For the
|
||||
complete list of available headers, see `mm/header-names'."
|
||||
:type (list 'symbol)
|
||||
:group 'mm/view)
|
||||
|
||||
(defcustom mm/view-date-format "%c"
|
||||
"Date format to use in the message view, in the format of
|
||||
`format-time-string'."
|
||||
:type 'string
|
||||
:group 'mm/headers)
|
||||
|
||||
;; Composing / Sending messages
|
||||
(defgroup mm/compose nil
|
||||
"Customizations for composing/sending messages."
|
||||
:group 'mm)
|
||||
|
||||
(defcustom mm/msg-citation-prefix "> "
|
||||
"String to prefix cited message parts with."
|
||||
:type 'string
|
||||
:group 'mm/compose)
|
||||
|
||||
(defcustom mm/msg-reply-prefix "Re: "
|
||||
"String to prefix the subject of replied messages with."
|
||||
:type 'string
|
||||
:group 'mm/compose)
|
||||
|
||||
(defcustom mm/msg-forward-prefix "Fwd: "
|
||||
"String to prefix the subject of forwarded messages with."
|
||||
:type 'string
|
||||
:group 'mm/compose)
|
||||
|
||||
(defcustom mm/user-agent nil
|
||||
"The user-agent string; leave at `nil' for the default."
|
||||
:type 'string
|
||||
:group 'mm/compose)
|
||||
|
||||
|
||||
|
||||
;; 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 :slant italic))
|
||||
"Face for an mm message header that has been moved to some
|
||||
folder (it's still visible in the search results, since we cannot
|
||||
be sure it no longer matches)."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/trashed-face
|
||||
'((t :inherit font-lock-comment-face :strike-through t))
|
||||
"Face for an message header in the trash folder."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/draft-face
|
||||
'((t :inherit font-lock-string-face))
|
||||
"Face for a draft message header (i.e., a message with the draft
|
||||
flag set)."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/header-face
|
||||
'((t :inherit default))
|
||||
"Face for an mm header without any special flags."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/title-face
|
||||
'((t :inherit font-lock-type-face))
|
||||
"Face for an mm title."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-header-key-face
|
||||
'((t :inherit font-lock-builtin-face))
|
||||
"Face for the header title (such as \"Subject\" in the message view)."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-header-value-face
|
||||
'((t :inherit font-lock-doc-face))
|
||||
"Face for the header value (such as \"Re: Hello!\" in the message view)."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-link-face
|
||||
'((t :inherit font-lock-type-face :underline t))
|
||||
"Face for showing URLs and attachments in the message view."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/highlight-face
|
||||
'((t :inherit font-lock-pseudo-keyword-face :bold t))
|
||||
"Face for highlighting things."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-url-number-face
|
||||
'((t :inherit font-lock-reference-face :bold t))
|
||||
"Face for the number tags for URLs."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-attach-number-face
|
||||
'((t :inherit font-lock-variable-name-face :bold t))
|
||||
"Face for the number tags for attachments."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/view-footer-face
|
||||
'((t :inherit font-lock-comment-face))
|
||||
"Face for message footers (signatures)."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/hdrs-marks-face
|
||||
'((t :inherit font-lock-preprocessor-face))
|
||||
"Face for the mark in the headers list."
|
||||
:group 'mm/faces)
|
||||
|
||||
(defface mm/system-face
|
||||
'((t :inherit font-lock-comment-face :slant italic))
|
||||
"Face for system message (such as the footers for message
|
||||
headers)."
|
||||
:group 'mm/faces)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; internal variables / constants
|
||||
|
||||
(defconst mm/header-names
|
||||
'( (:attachments . "Attach")
|
||||
(:bcc . "Bcc")
|
||||
(:cc . "Cc")
|
||||
(:date . "Date")
|
||||
(:flags . "Flags")
|
||||
(:from . "From")
|
||||
(:from-or-to . "From/To")
|
||||
(:maildir . "Maildir")
|
||||
(:path . "Path")
|
||||
(:subject . "Subject")
|
||||
(:to . "To"))
|
||||
"A alist of all possible header fields; this is used in the UI (the
|
||||
column headers in the header list, and the fields the message
|
||||
view). Most fields should be self-explanatory. A special one is
|
||||
`:from-or-to', which is equal to `:from' unless `:from' matches ,
|
||||
in which case it will be equal to `:to'.)")
|
||||
|
||||
|
||||
;; mm startup function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun mm ()
|
||||
"Start mm. We do this by sending a 'ping' to the mu server
|
||||
process, and start the main view if the 'pong' we receive from the
|
||||
server has the expected values."
|
||||
(interactive)
|
||||
(if (buffer-live-p mm/main-buffer-name)
|
||||
(switch-to-buffer mm/main-buffer-name)
|
||||
(setq mm/proc-pong-func
|
||||
(lambda (version doccount)
|
||||
(unless (string= version mm/mu-version)
|
||||
(error "mu server has version %s, but we need %s"
|
||||
version mm/mu-version))
|
||||
(mm/main-view)))
|
||||
(mm/proc-ping)))
|
||||
|
||||
(defun mm/ask-maildir (prompt)
|
||||
"Ask the user for a shortcut (using PROMPT) as defined in
|
||||
`mm/maildir-shortcuts', then return the corresponding folder
|
||||
name. If the special shortcut 'o' (for _o_ther) is used, or if
|
||||
`mm/maildir-shortcuts is not defined, let user choose from all
|
||||
maildirs under `mm/maildir."
|
||||
(unless mm/maildir (error "`mm/maildir' is not defined"))
|
||||
(if (not mm/maildir-shortcuts)
|
||||
(ido-completing-read prompt (mm/get-sub-maildirs mm/maildir))
|
||||
(let* ((mlist (append mm/maildir-shortcuts '(("ther" . ?o))))
|
||||
(fnames
|
||||
(mapconcat
|
||||
(lambda (item)
|
||||
(concat
|
||||
"["
|
||||
(propertize (make-string 1 (cdr item)) 'face 'mm/view-link-face)
|
||||
"]"
|
||||
(car item)))
|
||||
mlist ", "))
|
||||
(kar (read-char (concat prompt fnames))))
|
||||
(if (= kar ?o) ;; user chose 'other'?
|
||||
(ido-completing-read prompt (mm/get-sub-maildirs mm/maildir))
|
||||
(or
|
||||
(car-safe (find-if (lambda (item) (= kar (cdr item))) mm/maildir-shortcuts))
|
||||
(error "Invalid shortcut '%c'" kar))))))
|
||||
|
||||
|
||||
|
||||
(defun mm/ask-bookmark (prompt)
|
||||
"Ask the user for a bookmark (using PROMPT) as defined in
|
||||
`mm/bookmarks', then return the corresponding query."
|
||||
(unless mm/bookmarks (error "`mm/bookmarks' is not defined"))
|
||||
(let* ((bmarks
|
||||
(mapconcat
|
||||
(lambda (bm)
|
||||
(let ((query (nth 0 bm)) (title (nth 1 bm)) (key (nth 2 bm)))
|
||||
(concat
|
||||
"[" (propertize (make-string 1 key) 'face 'mm/view-link-face) "]"
|
||||
title))) mm/bookmarks ", "))
|
||||
(kar (read-char (concat prompt bmarks)))
|
||||
(chosen-bm
|
||||
(find-if (lambda (bm) (= kar (nth 2 bm))) mm/bookmarks)))
|
||||
(unless chosen-bm (error "Invalid shortcut '%c'" kar))
|
||||
(nth 0 chosen-bm)))
|
||||
|
||||
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
|
||||
;;; 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)
|
||||
('attach ?a)
|
||||
('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))))))
|
||||
|
||||
|
||||
(defun mm/display-size (size)
|
||||
"Get a string representation of SIZE (in bytes)."
|
||||
(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))
|
||||
(t "<unknown>")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(provide 'mm)
|
||||
38
emacs/mm.org
Normal file
38
emacs/mm.org
Normal file
@ -0,0 +1,38 @@
|
||||
* mm
|
||||
|
||||
** Introduction
|
||||
|
||||
Welcome to *mu mail* - an emacs client for the [[http://www.djcbsoftware.nl/code/mu][mu]] maildir indexing/searching
|
||||
tool. It turns mu into an e-mail-client.
|
||||
|
||||
Mu Mail has things in common with programs such as 'notmuch' and 'md', but -
|
||||
in the opinion of it's author - it offers some unique features as
|
||||
well. Basically, the mail handling (deleting, moving etc.) is inspired by
|
||||
*Wanderlust* (another emacs-based e-mail client) and *dired*, while it takes
|
||||
some cues from GMail with respect to being search-based. In practice this
|
||||
means that mu mail provides a 'traditional' folder-based e-mail client, on
|
||||
top of a search based back-end.
|
||||
|
||||
** How does it work
|
||||
|
||||
While not necessarily interesting for all users of mu mail, for some it may
|
||||
be interesting to know how mu mail does its job.
|
||||
|
||||
Since version 0.9.8, mu has a special =server= command, which drops you into
|
||||
a command line where you can give certain commands to mu (see the =mu-server=
|
||||
man page). While it would certainly be possible to have specific commands to
|
||||
get lists of messages, move them, delete them etc., having a running instance
|
||||
around gets rid of the startup time of mu and especially the message
|
||||
database.
|
||||
|
||||
So, when running mu mail inside emacs, it fires up an instance of 'mu
|
||||
server', and communicates with it as long as it runs.
|
||||
|
||||
mu mail shows its results only after the mu server reports their
|
||||
completion. Still, the execution is asynchronous, so you do not need wait for
|
||||
anything. We found that, for example, deleting messages is fast enough to
|
||||
allow us to wait for the results. An alternative design would be to update
|
||||
the user-interface already; so far we are quite content with the performance.
|
||||
|
||||
Regarding performance, showing large numbers (thousands) of message can still
|
||||
be a bit slower than is desirable. This is an area for improvement still.
|
||||
Reference in New Issue
Block a user