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

* many updates to `mm', the mu-based MUA for emacs

Browse Source
This commit is contained in:
Dirk-Jan C. Binnema
2011-09-18 14:39:36 +03:00
parent 462f5f5247
commit 288a5763a6
6 changed files with 1274 additions and 467 deletions
Download Patch File Download Diff File Expand all files Collapse all files

242
toys/mm/mm-common.el
View File

@ -30,56 +30,6 @@
(require 'ido) (require 'ido)
(defun mm/eval-msg-string (str)
"Get the plist describing an email message, from STR containing
a message sexp.
a message sexp looks something like:
\(
:from ((\"Donald Duck\" . \"donald@example.com\"))
:to ((\"Mickey Mouse\" . \"mickey@example.com\"))
:subject \"Wicked stuff\"
:date (20023 26572 0)
:size 15165
:references (\"200208121222.g7CCMdb80690@msg.id\")
:in-reply-to \"200208121222.g7CCMdb80690@msg.id\"
:message-id \"foobar32423847ef23@pluto.net\"
:maildir: \"/archive\"
:path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\"
:priority high
:flags (new unread)
:attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\"))
:body-txt \" <message body>\"
\)
other fields are :cc, :bcc, :body-html
When the s-expression comes from the database ('mu find'), the
fields :attachments, :body-txt, :body-html, :references, :in-reply-to
are missing (because that information is not stored in the
database -- at least not in a usable way."
(condition-case nil
(car (read-from-string str));; read-from-string returns a cons
(error "Failed to parse message")))
(defun mm/msg-field (msg field)
"Get a field from this message, or nil. The fields are the
fields of the message, which are the various items of the plist
as described in `mm/eval-msg-string'
There is also the special field :body (which is either :body-txt,
or if not available, :body-html converted to text)."
(case field
(:body
(let* ((body (mm/msg-field msg :body-txt))
(body (or body (with-temp-buffer
(mm/msg-field msg :body-html)
(html2text)
(buffer-string)))))))
(t (plist-get msg field))))
@ -203,176 +153,29 @@ nil.
(mm/db-update-execute) (mm/db-update-execute)
t)))) t))))
;;; some functions for *asyncronously* updating the database
(defvar mm/db-update-proc nil
"*internal* Process for async db updates.")
(defvar mm/db-update-name "*mm-db-update*"
"*internal* name of the db-update process")
(defvar mm/db-add-paths nil
"*internal* List of message paths to add to the database.")
(defvar mm/db-remove-paths nil
"*internal* List of message paths to remove from the database.")
(defun mm/db-update-proc-sentinel (proc msg)
"Check the database update process upon completion."
(let ((procbuf (process-buffer proc))
(status (process-status proc))
(exit-status (process-exit-status proc)))
(when (and (buffer-live-p procbuf) (memq status '(exit signal)))
(case status
('signal (mm/log "Process killed"))
('exit
(case exit-status
(mm/log "Result: %s" (mm/error-string exit-status))))))
;; try to update again, maybe there are some new updates
(mm/db-update-execute)))
(defun mm/db-update-execute ()
"Update the database; remove paths in `mm/db-remove-paths',
and add paths in `mm/db-add-paths'. Updating is ansynchronous."
;; when it's already running, do nothing
(unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run))
(when mm/db-remove-paths
(let ((remove-paths (copy-list mm/db-remove-paths)))
(mm/log (concat mm/mu-binary " remove "
(mapconcat 'identity remove-paths " ")))
(setq mm/db-remove-paths nil) ;; clear the old list
(setq mm/db-update-proc
(apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary
"remove" remove-paths))
(set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel)))))
;; when it's already running, do nothing
(unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run))
(when mm/db-add-paths
(let ((add-paths (copy-list mm/db-add-paths)))
(mm/log (concat mm/mu-binary " add " (mapconcat 'identity add-paths " ")))
(setq mm/db-add-paths nil) ;; clear the old list
(setq mm/db-update-proc
(apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary
"add" add-paths))
(set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel))))
(defun mm/db-add-async (path-or-paths)
"Asynchronously add msg at PATH-OR-PATHS to
database. PATH-OR-PATHS is either a single path or a list of them."
(setq mm/db-add-paths
(append mm/db-add-paths
(if (listp path-or-paths) path-or-paths `(,path-or-paths)))))
;; (mm/db-update-execute))
(defun mm/db-remove-async (path-or-paths)
"Asynchronously remove msg at PATH-OR-PATHS from
database. PATH-OR-PATHS is either a single path or a list of
them."
(setq mm/db-remove-paths
(append mm/db-remove-paths
(if (listp path-or-paths) path-or-paths `(,path-or-paths)))))
;; (mm/db-update-execute))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; error codes / names ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generated with:
;; cat mu-util.h | sed 's/\([A-Z_]\+\).*=\(.*\),/(defconst \L\1 \2)/' < "$<" \
;; | sed 's/_/-/g' > mu-errors.el
(defconst mm/err 1)
(defconst mm/err-in-parameters 2)
(defconst mm/err-internal 3)
(defconst mm/err-no-matches 4)
(defconst mm/err-xapian 11)
(defconst mm/err-xapian-query 13)
(defconst mm/err-xapian-dir-not-accessible 14)
(defconst mm/err-xapian-not-up-to-date 15)
(defconst mm/err-xapian-missing-data 16)
(defconst mm/err-xapian-corruption 17)
(defconst mm/err-xapian-cannot-get-writelock 18)
(defconst mm/err-gmime 30)
(defconst mm/err-contacts 50)
(defconst mm/err-contacts-cannot-retrieve 51)
(defconst mm/err-file 70)
(defconst mm/err-file-invalid-name 71)
(defconst mm/err-file-cannot-link 72)
(defconst mm/err-file-cannot-open 73)
(defconst mm/err-file-cannot-read 74)
(defconst mm/err-file-cannot-create 75)
(defconst mm/err-file-cannot-mkdir 76)
(defconst mm/err-file-stat-failed 77)
(defconst mm/err-file-readdir-failed 78)
(defconst mm/err-file-invalid-source 79)
(defconst mm/err-file-target-equals-source 80)
;; TODO: use 'case' instead...
(defun mm/error-string (err)
"Convert an exit code from mu into a string."
(cond
((eql err mm/err) "General error")
((eql err mm/err-in-parameters) "Error in parameters")
((eql err mm/err-internal) "Internal error")
((eql err mm/err-no-matches) "No matches")
((eql err mm/err-xapian) "Xapian error")
((eql err mm/err-xapian-query) "Error in query")
((eql err mm/err-xapian-dir-not-accessible) "Database dir not accessible")
((eql err mm/err-xapian-not-up-to-date) "Database is not up-to-date")
((eql err mm/err-xapian-missing-data) "Missing data")
((eql err mm/err-xapian-corruption) "Database seems to be corrupted")
((eql err mm/err-xapian-cannot-get-writelock)"Database is locked")
((eql err mm/err-gmime) "GMime-related error")
((eql err mm/err-contacts) "Contacts-related error")
((eql err mm/err-contacts-cannot-retrieve) "Failed to retrieve contacts")
((eql err mm/err-file) "File error")
((eql err mm/err-file-invalid-name) "Invalid file name")
((eql err mm/err-file-cannot-link) "Failed to link file")
((eql err mm/err-file-cannot-open) "Cannot open file")
((eql err mm/err-file-cannot-read) "Cannot read file")
((eql err mm/err-file-cannot-create) "Cannot create file")
((eql err mm/err-file-cannot-mkdir) "mu-mkdir failed")
((eql err mm/err-file-stat-failed) "stat(2) failed")
((eql err mm/err-file-readdir-failed) "readdir failed")
((eql err mm/err-file-invalid-source) "Invalid source file")
((eql err mm/err-file-target-equals-source) "Source is same as target")
(t (format "Unknown error (%d)" err))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/mu-run (&rest args) ;; TODO: make this recursive
"Run 'mu' synchronously with ARGS as command-line argument;, (defun mm/get-sub-maildirs (maildir)
where <exit-code> is the exit code of the program, or 1 if the "Get all readable sub-maildirs under MAILDIR."
process was killed. <str> contains whatever the command wrote on (let ((maildirs (remove-if
standard output/error, or nil if there was none or in case of (lambda (dentry)
error. `mm/mu-run' is like `shell-command-to-string', but with (let ((path (concat maildir "/" dentry)))
better possibilities for error handling. The --muhome= parameter is (or
added automatically if `mm/mu-home' is non-nil." (string= dentry ".")
(let* ((rv) (string= dentry "..")
(allargs (remove-if 'not (not (file-directory-p path))
(append args (when mm/mu-home (concat "--muhome=" mm/mu-home))))) (not (file-readable-p path))
(cmdstr (concat mm/mu-binary " " (mapconcat 'identity allargs " "))) (file-exists-p (concat path "/.noindex")))))
(str (with-output-to-string (directory-files maildir))))
(with-current-buffer standard-output ;; but we also get stderr... (map 'list (lambda (dir) (concat "/" dir)) maildirs)))
(setq rv (apply 'call-process mm/mu-binary nil t nil
args))))))
(mm/log "%s %s => %S" mm/mu-binary (mapconcat 'identity args " ") rv)
(when (and (numberp rv) (/= 0 rv))
(error (mm/error-string rv)))
`(,(if (numberp rv) rv 1) . ,str)))
(defun mm/ask-maildir (prompt &optional fullpath) (defun mm/ask-maildir (prompt)
"Ask user with PROMPT for a maildir name, if fullpath is "Ask user with PROMPT for a maildir name, if fullpath is
non-nill, return the fulpath (i.e., `mm/maildir' prepended to the non-nill, return the fulpath (i.e., `mm/maildir' prepended to the
chosen folder)." chosen folder)."
@ -381,11 +184,7 @@ chosen folder)."
`mm/sent-folder' must be set")) `mm/sent-folder' must be set"))
(unless mm/maildir (error "`mm/maildir' must be set")) (unless mm/maildir (error "`mm/maildir' must be set"))
(interactive) (interactive)
(let* ((showfolders (ido-completing-read prompt (mm/get-sub-maildirs mm/maildir)))
(append (list mm/inbox-folder mm/drafts-folder mm/sent-folder)
mm/working-folders))
(chosen (ido-completing-read prompt showfolders)))
(concat (if fullpath mm/maildir "") chosen)))
(defun mm/new-buffer (bufname) (defun mm/new-buffer (bufname)
@ -398,15 +197,6 @@ old one first."
(get-buffer-create bufname)) (get-buffer-create bufname))
(defconst mm/log-buffer-name "*mm-log*"
"*internal* Name of the logging buffer.")
(defun mm/log (frm &rest args)
"Write something in the *mm-log* buffer - mainly useful for debugging."
(with-current-buffer (get-buffer-create mm/log-buffer-name)
(goto-char (point-max))
(insert (apply 'format (concat (format-time-string "%x %X " (current-time))
frm "\n") args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

246
toys/mm/mm-hdrs.el
View File

@ -28,7 +28,7 @@
;; descriptions of emails, aka 'headers' (not to be confused with headers like ;; descriptions of emails, aka 'headers' (not to be confused with headers like
;; 'To:' or 'Subject:') ;; 'To:' or 'Subject:')
;; mu ;; mm
;;; Code: ;;; Code:
@ -53,7 +53,7 @@
"*internal Whether to sort in descending order") "*internal Whether to sort in descending order")
(defconst mm/hdrs-buffer-name "*headers*" (defconst mm/hdrs-buffer-name "*mm-headers*"
"*internal* Name of the buffer for message headers.") "*internal* Name of the buffer for message headers.")
(defvar mm/hdrs-buffer nil (defvar mm/hdrs-buffer nil
@ -63,62 +63,101 @@
"Search in the mu database for EXPR, and switch to the output "Search in the mu database for EXPR, and switch to the output
buffer for the results." buffer for the results."
(interactive "s[mu] search for: ") (interactive "s[mu] search for: ")
;; make sure we get a brand new buffer (let ((buf (get-buffer-create mm/hdrs-buffer-name))
(setq mm/hdrs-buffer (mm/new-buffer mm/hdrs-buffer-name)) (inhibit-read-only t))
(switch-to-buffer mm/hdrs-buffer) (with-current-buffer buf
(erase-buffer)
(mm/hdrs-mode) (mm/hdrs-mode)
(setq mm/last-expr expr) (setq mm/msg-map nil mm/mm/marks-map nil)
(mm/msg-map-init) (mm/msg-map-init)
(let ((inhibit-read-only t)) (erase-buffer)) ;; FIXME -- why is this needed?! (setq
mode-name expr
;; all set -- now execute the search mm/last-expr expr
mm/hdrs-buffer buf)))
(switch-to-buffer mm/hdrs-buffer)
(mm/proc-find expr)) (mm/proc-find expr))
(defun mm/hdrs-message-handler (msg) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(message "Received message %d (%s)" ;; handler functions
(plist-get msg :docid) ;;
(plist-get msg :subject))) ;; 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) (defun mm/hdrs-error-handler (err)
(message "Error %d: %s" "Handler function for showing an error."
(plist-get err :error) (let ((errcode (plist-get err :error))
(plist-get err :error-message))) (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 (update) (defun mm/hdrs-update-handler (msg is-move)
"Update handler, will be called when we get '(:update ... )' from "Update handler, will be called when a message has been updated
the mu server process. This function will update the current list in the database. This function will update the current list of
of headers." headers."
(message "We received a database update: %S" update) (when (buffer-live-p mm/hdrs-buffer)
(let* ((type (plist-get update :update)) (docid (plist-get update :docid)) (with-current-buffer mm/hdrs-buffer
(let* ((docid (plist-get msg :docid))
(marker (mm/msg-map-get-marker docid))) (marker (mm/msg-map-get-marker docid)))
(unless docid (error "Invalid update %S" update)) (unless docid (error "Invalid update %S" update))
(unless marker (error "Message %d not found" docid)) (unless marker (error "Message %d not found" docid))
(with-current-buffer mm/hdrs-buffer
(save-excursion (save-excursion
(goto-char (marker-position marker)) (goto-char (marker-position marker))
;; sanity check ;; sanity check
(unless (eq docid (get-text-property (point) 'docid)) (unless (eq docid (get-text-property (point) 'docid))
(error "Unexpected docid")) (error "Unexpected docid"))
(mm/hdrs-mark 'unmark) ;; if it's marked, unmark it now
(when (mm/hdrs-docid-is-marked docid)
(mm/hdrs-mark 'unmark))
(let ((inhibit-read-only t) (bol (line-beginning-position)) (let ((inhibit-read-only t) (bol (line-beginning-position))
(eol (line-beginning-position 2))) (eol (line-beginning-position 2)))
(case type ;; hide the old line (removing it causes some problems)
(remove (put-text-property bol eol 'invisible t)) (put-text-property bol eol 'invisible t)
(move (put-text-property bol eol 'face 'mm/moved-face)) ;; now, if this update was about *moving* a message, we don't show it
(t (error "Invalid update %S" update)))))))) ;; 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 bol))))))))
(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 (mm/msg-map-get-marker docid)))
(unless marker (error "Message %d not found" docid))
(save-excursion
(goto-char (marker-position marker))
;; sanity check
(unless (eq docid (get-text-property (point) 'docid))
(error "Unexpected docid"))
;; if it's marked, unmark it now
(when (mm/hdrs-docid-is-marked docid)
(mm/hdrs-mark 'unmark))
(let ((inhibit-read-only t) (bol (line-beginning-position))
(eol (line-beginning-position 2)))
;; hide the message
(set-text-properties bol eol '(invisible t)))))))
(defun mm/hdrs-header-handler (msg) (defun mm/hdrs-header-handler (msg &optional point)
"Function to insert a line for a message. This will be called by "Function to add a line for a message. This will be called by
`mm/proc-find'. Function expects to be in the output buffer `mm/proc-find'. Function expects to be in the output buffer
already." already. Normally, msg is appended to the end of the buffer, but if
(let* ((docid (mm/msg-field msg :docid)) POINT is given, message is insert at POINT."
(let* ((docid (plist-get msg :docid))
(line (propertize (concat " " (mm/hdrs-line msg) "\n") (line (propertize (concat " " (mm/hdrs-line msg) "\n")
'docid docid))) 'docid docid)))
;; add message to the docid=>path map, see `mm/msg-map'. ;; add message to the docid=>path map, see `mm/msg-map'.
(with-current-buffer mm/hdrs-buffer (with-current-buffer mm/hdrs-buffer
(save-excursion (save-excursion
(goto-char (point-max)) ;; append to end, or insert at POINT if that was provided
(goto-char (if point point (point-max)))
(mm/msg-map-add msg (point-marker)) (mm/msg-map-add msg (point-marker))
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(insert line)))))) (insert line))))))
@ -126,9 +165,9 @@ already."
(defun mm/hdrs-line (msg) (defun mm/hdrs-line (msg)
"Get the one-line description of MSG (as per `mm/hdrs-raw-line'), and "Get the one-line description of MSG (as per `mm/hdrs-raw-line'), and
apply text-properties based on the message flags." apply text-properties based on the message flags."
(let ((line (mm/hdrs-raw-line msg)) (let ((line (mm/hdrs-raw-line msg)) (flags (plist-get msg :flags)))
(flags (plist-get msg :flags)))
(cond (cond
((member 'trashed flags) (propertize line 'face 'mm/trashed-face))
((member 'unread flags) (propertize line 'face 'mm/unread-face)) ((member 'unread flags) (propertize line 'face 'mm/unread-face))
(t (propertize line 'face 'mm/header-face))))) (t (propertize line 'face 'mm/header-face)))))
@ -189,9 +228,9 @@ point. Line does not include a newline or any text-properties."
(define-key map "x" 'mm/execute-marks) (define-key map "x" 'mm/execute-marks)
;; message composition ;; message composition
;; (define-key map "r" 'mua/hdrs-reply) (define-key map "r" 'mm/compose-reply)
;; (define-key map "f" 'mua/hdrs-forward) (define-key map "f" 'mm/compose-forward)
;; (define-key map "c" 'mua/hdrs-compose) (define-key map "c" 'mm/compose-new)
(define-key map (kbd "RET") 'mm/view-message) (define-key map (kbd "RET") 'mm/view-message)
map) map)
@ -205,7 +244,6 @@ point. Line does not include a newline or any text-properties."
(kill-all-local-variables) (kill-all-local-variables)
(use-local-map mm/hdrs-mode-map) (use-local-map mm/hdrs-mode-map)
(make-local-variable 'mm/buf)
(make-local-variable 'mm/last-expr) (make-local-variable 'mm/last-expr)
(make-local-variable 'mm/hdrs-proc) (make-local-variable 'mm/hdrs-proc)
(make-local-variable 'mm/marks-map) (make-local-variable 'mm/marks-map)
@ -215,7 +253,10 @@ point. Line does not include a newline or any text-properties."
(setq mm/proc-error-func 'mm/hdrs-error-handler) (setq mm/proc-error-func 'mm/hdrs-error-handler)
(setq mm/proc-update-func 'mm/hdrs-update-handler) (setq mm/proc-update-func 'mm/hdrs-update-handler)
(setq mm/proc-header-func 'mm/hdrs-header-handler) (setq mm/proc-header-func 'mm/hdrs-header-handler)
(setq mm/proc-message-func 'mm/hdrs-message-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 (setq
mm/marks-map (make-hash-table :size 16 :rehash-size 2) mm/marks-map (make-hash-table :size 16 :rehash-size 2)
@ -317,9 +358,6 @@ The following marks are available, and the corresponding props:
(delete-char 2) (delete-char 2)
(insert (propertize (concat markkar " ") 'docid docid)))))) (insert (propertize (concat markkar " ") 'docid docid))))))
(defun mm/hdrs-marks-execute () (defun mm/hdrs-marks-execute ()
"Execute the actions for all marked messages in this "Execute the actions for all marked messages in this
buffer. buffer.
@ -332,31 +370,21 @@ 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 automatically, as it may be too slow and/or break the users
flow. Therefore, we hide the message, which in practice seems to flow. Therefore, we hide the message, which in practice seems to
work well." work well."
(unless (/= 0 (hash-table-count mm/marks-map)) (if (= 0 (hash-table-count mm/marks-map))
(error "Nothing is marked")) (message "Nothing is marked")
(maphash (maphash
(lambda (docid val) (lambda (docid val)
(let* ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)) (let*
((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val))
(ok (case mark (ok (case mark
(move (move
(mm/proc-move-msg docid target)) (mm/proc-move-msg docid target))
(trash (trash
(unless mm/maildir "`mm/maildir' not set")
(unless mm/trash-folder "`mm/trash-folder' not set") (unless mm/trash-folder "`mm/trash-folder' not set")
(mm/proc-move-msg docid (concat mm/maildir "/" mm/trash-folder) "+T")) (mm/proc-move-msg docid mm/trash-folder "+T"))
(delete (delete
(mm/proc-remove-msg docid))))) (mm/proc-remove-msg docid)))))))
;; (when ok mm/marks-map)) )
;; (save-excursion
;; (goto-char (marker-position marker))
;; (mm/hdrs-mark 'unmark)
;; ;; hide the line
;; (let ((inhibit-read-only t))
;; (put-text-property (line-beginning-position) (line-beginning-position 2)
;; 'invisible t))))))
))
mm/marks-map))
(defun mm/hdrs-unmark-all () (defun mm/hdrs-unmark-all ()
"Unmark all marked messages." "Unmark all marked messages."
@ -370,13 +398,22 @@ work well."
mm/marks-map)) mm/marks-map))
(defun mm/hdrs-view () (defun mm/hdrs-view ()
"View message at point" "View message at point."
(let ((docid (get-text-property (point) 'docid))) (let ((docid (get-text-property (point) 'docid)))
(unless docid (error "No message at point.")) (unless docid (error "No message at point."))
(mm/proc-view-msg docid))) (mm/proc-view-msg docid)))
(defun mm/hdrs-compose (reply-or-forward)
"Compose either a reply or a forward based on the message at
point."
(let ((docid (get-text-property (point) 'docid)))
(unless docid (error "No message at point."))
(mm/proc-compose-msg docid reply-or-forward)))
(defun mm/hdrs-docid-is-marked (docid)
"Is the given docid marked?"
(when (gethash docid mm/marks-map) t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -384,19 +421,29 @@ work well."
;;; interactive functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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))
;; TODO warn if marks exist
(defun mm/search () (defun mm/search ()
"Start a new mu search." "Start a new mu search."
(interactive) (interactive)
(call-interactively 'mm/hdrs-search)) (when (mm/ignore-marks)
(call-interactively 'mm/hdrs-search)))
;; TODO warn if marks exist
;; TODO: return to previous buffer
(defun mm/quit-buffer () (defun mm/quit-buffer ()
"Quit the current buffer." "Quit the current buffer."
(interactive) (interactive)
(kill-buffer (current-buffer))) (when (mm/ignore-marks)
(mm/kill-proc) ;; hmmm...
(kill-buffer)
(mm)))
;; TODO implement ;; TODO implement
(defun mm/change-sort () (defun mm/change-sort ()
@ -409,9 +456,10 @@ work well."
"Rerun the search for the last search expression; if none exists, "Rerun the search for the last search expression; if none exists,
do a new search." do a new search."
(interactive) (interactive)
(when (mm/ignore-marks)
(if mm/last-expr (if mm/last-expr
(mm/hdrs-search mm/last-expr) (mm/hdrs-search mm/last-expr)
(mm/search))) (mm/search))))
(defun mm/view-message () (defun mm/view-message ()
"View the message at point." "View the message at point."
@ -419,16 +467,28 @@ do a new search."
(mm/hdrs-view)) (mm/hdrs-view))
(defun mm/next-header () (defun mm/next-header ()
"Move point to the next header." "Move point to the next message header. If this succeeds, return
the new docid. Otherwise, return nil."
(interactive) (interactive)
(when (or (/= 0 (forward-line 1)) (not (get-text-property (point) 'docid))) (if (= 0 (forward-line 1))
(error "No header after this one"))) (let ((docid (get-text-property (point) 'docid)))
(if docid
docid
(mm/next-header))) ;; skip non-headers
(progn (message "No next message available") nil)))
(defun mm/prev-header () (defun mm/prev-header ()
"Move point to the previous header." "Move point to the previous message header. If this succeeds,
return the new docid. Otherwise, return nil."
(interactive) (interactive)
(when (or (/= 0 (forward-line -1)) (not (get-text-property (point) 'docid))) (if (= 0 (forward-line -1))
(error "No header before this one"))) (let ((docid (get-text-property (point) 'docid)))
(if docid
docid
(mm/prev-header))) ;; skip non-headers
(progn (message "No previous message available") nil)))
(defun mm/jump-to-maildir () (defun mm/jump-to-maildir ()
"Show the messages in one of the standard folders." "Show the messages in one of the standard folders."
@ -436,14 +496,16 @@ do a new search."
(let ((fld (mm/ask-maildir "Jump to maildir: "))) (let ((fld (mm/ask-maildir "Jump to maildir: ")))
(mm/hdrs-search (concat "maildir:" fld)))) (mm/hdrs-search (concat "maildir:" fld))))
(defun mm/mark-for-move () (defun mm/mark-for-move ()
"Mark message at point for moving to a maildir." "Mark message at point for moving to a maildir."
(interactive) (interactive)
(let ((target (mm/ask-maildir "Target maildir for move: "))) (let* ((target (mm/ask-maildir "Target maildir for move: "))
(when (or (file-directory-p target) (fulltarget (concat mm/maildir target)))
(when (or (file-directory-p fulltarget)
(and (yes-or-no-p (and (yes-or-no-p
(format "%s does not exist. Create now?" target)) (format "%s does not exist. Create now?" fulltarget))
(mm/proc-mkdir target))) (mm/proc-mkdir fulltarget)))
(mm/hdrs-mark 'move target) (mm/hdrs-mark 'move target)
(mm/next-header)))) (mm/next-header))))
@ -470,24 +532,34 @@ folder (`mm/trash-folder')."
(defun mm/unmark-all () (defun mm/unmark-all ()
"Unmark all messages." "Unmark all messages."
(interactive) (interactive)
(unless (/= 0 (hash-table-count mm/marks-map)) (if (= 0 (hash-table-count mm/marks-map))
(error "Nothing is marked")) (message "Nothing is marked")
(when (y-or-n-p (format "Sure you want to unmark %d message(s)?" (when (mm/ignore-marks)
(hash-table-count mm/marks-map))) (mm/hdrs-unmark-all))))
(mm/hdrs-unmark-all)))
(defun mm/execute-marks () (defun mm/execute-marks ()
"Execute the actions for the marked messages." "Execute the actions for the marked messages."
(interactive) (interactive)
(unless (/= 0 (hash-table-count mm/marks-map)) (if (= 0 (hash-table-count mm/marks-map))
(error "Nothing is marked")) (message "Nothing is marked")
(when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?" (when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?"
(hash-table-count mm/marks-map))) (hash-table-count mm/marks-map)))
(mm/hdrs-marks-execute))) (mm/hdrs-marks-execute)
(message nil))))
(defun mm/compose-reply ()
"Start composing a reply to the current message."
(interactive)
(mm/hdrs-compose 'reply))
(defun mm/compose-forward ()
"Start composing a forward to the current message."
(interactive)
(mm/hdrs-compose 'forward))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'mm-hdrs) (provide 'mm-hdrs)

293
toys/mm/mm-proc.el
View File

@ -35,33 +35,64 @@
(defvar mm/mu-proc nil (defvar mm/mu-proc nil
"*internal* The mu-server process") "*internal* The mu-server process")
(defvar mm/proc-header-func nil
"*internal* A function called for each message returned from the
server process; the function is passed a msg plist as argument. See
`mm/proc-eval-server-output' for the format.")
(defvar mm/proc-error-func nil (defvar mm/proc-error-func nil
"*internal* A function called for each error returned from the "*internal* A function called for each error returned from the
server process; the function is passed an error plist as server process; the function is passed an error plist as
argument. See `mm/proc-eval-server-output' for the format.") argument. See `mm/proc-filter' for the format.")
(defvar mm/proc-update-func nil (defvar mm/proc-update-func nil
"*internal* A function called for each update sexp returned from "*internal* A function called for each :update sexp returned from
the server process; the function is passed an update plist as the server process; the function is passed a msg sexp as
argument. See `mm/proc-eval-server-output' for the format.") argument. See `mm/proc-filter' for the format.")
(defvar mm/proc-message-func nil (defvar mm/proc-remove-func nil
"*internal* A function called for each message sexp returned from "*internal* A function called for each :remove sexp returned from
the server process. This is designed for viewing a message. See the server process, when some message has been deleted. The
`mm/proc-eval-server-output' for the format.") function is passed the docid of the removed message.")
(defvar mm/proc-view-func nil
"*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 nil
"*internal* A function called for each message returned from the
server process; the function is passed a msg plist as argument. See
`mm/proc-filter' for the format.")
(defvar mm/proc-compose-func nil
"*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 nil
"*internal* A function called for each (:info type ....) sexp
received from the server process.")
(defconst mm/eox-mark "\n;;eox\n" (defvar mm/buf nil
"*internal* Marker for the end of a sexp")
(defvar mm/buf ""
"*internal* Buffer for results data.") "*internal* Buffer for results data.")
(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 'version) (setq mm/mu-version (plist-get info :version)))
((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))))))))
(defun mm/start-proc () (defun mm/start-proc ()
"Start the mu server process." "Start the mu server process."
;; TODO: add version check ;; TODO: add version check
@ -71,8 +102,11 @@ the server process. This is designed for viewing a message. See
(args '("server")) (args '("server"))
(args (append args (when mm/mu-home (args (append args (when mm/mu-home
(list (concat "--muhome=" mm/mu-home)))))) (list (concat "--muhome=" mm/mu-home))))))
(setq mm/buf "")
(setq mm/mu-proc (apply 'start-process "*mu-server*" "*mu-server*" (setq mm/mu-proc (apply 'start-process "*mu-server*" "*mu-server*"
mm/mu-binary args)) mm/mu-binary args))
;; register a function for (:info ...) sexps
(setq mm/proc-info-func 'mm/proc-info-handler)
(when mm/mu-proc (when mm/mu-proc
(set-process-filter mm/mu-proc 'mm/proc-filter) (set-process-filter mm/mu-proc 'mm/proc-filter)
(set-process-sentinel mm/mu-proc 'mm/proc-sentinel)))) (set-process-sentinel mm/mu-proc 'mm/proc-sentinel))))
@ -82,66 +116,44 @@ the server process. This is designed for viewing a message. See
(when (mm/proc-is-running) (when (mm/proc-is-running)
(let ((delete-exited-processes t)) (let ((delete-exited-processes t))
(kill-process mm/mu-proc) (kill-process mm/mu-proc)
(setq mm/mu-proc nil)))) (setq
mm/mu-proc nil
mm/buf nil))))
(defun mm/proc-is-running () (defun mm/proc-is-running ()
(and mm/mu-proc (eq (process-status mm/mu-proc) 'run))) (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."
(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)))
(let ((objcons (read-from-string mm/buf)))
(setq mm/buf (substring mm/buf sexp-len))
(car objcons)))))
(defun mm/proc-filter (proc str) (defun mm/proc-filter (proc str)
"A process-filter for the 'mu server' output; it accumulates the "A process-filter for the 'mu server' output; it accumulates the
strings into valid sexps by checking of the ';;eox' end-of-msg strings into valid sexps by checking of the ';;eox' end-of-sexp
marker, and then evaluating them." marker, and then evaluating them.
(setq mm/buf (concat mm/buf str)) ;; update our buffer
(let ((eox (string-match mm/eox-mark mm/buf)))
(while eox
;; Process the sexp in `mm/buf', and remove it if it worked and return
;; t. If no complete sexp is found, return nil."
(let ( (after-eox (match-end 0))
(sexp (mm/proc-eval-server-output (substring mm/buf 0 eox))))
;; the sexp we get can either be a message or an error
(message "[%S]" sexp)
(cond
((plist-get sexp :error) (funcall mm/proc-error-func sexp))
;; if it has :docid, it's a message; if it's dbonly prop is `t', it's
;; a header, otherwise it's a message (for viewing)
((eq (plist-get sexp :msgtype) 'header)
(funcall mm/proc-header-func sexp))
((eq (plist-get sexp :msgtype) 'view)
(funcall mm/proc-message-func sexp))
((plist-get sexp :update) (funcall mm/proc-update-func sexp))
(t (message "%S" sexp)))
;;(t (error "Unexpected data from server"))))
(setq mm/buf (substring mm/buf after-eox)))
(setq eox (string-match mm/eox-mark mm/buf)))))
(defun mm/proc-sentinel (proc msg) The server output is as follows:
"Function that will be called when the mu-server process
terminates."
(let ((status (process-status proc)) (code (process-exit-status proc)))
(setq mm/mu-proc nil)
(setq mm/buf "") ;; clear any half-received sexps
(cond
((eq status 'signal)
(message (format "mu server process received signal %d" code)))
((eq status 'exit)
(cond
((eq code 11) (message "Database is locked by another process"))
(t (message (format "mu server process ended with exit code %d" code)))))
(t
(message "something bad happened to the mu server process")))))
(defun mm/proc-eval-server-output (str)
"Evaluate a blob of server output; the output describe either a
message, a database update or an error.
An error sexp looks something like:
1. an error
(:error 2 :error-message \"unknown command\") (:error 2 :error-message \"unknown command\")
;; eox ;; eox
=> this will be passed to `mm/proc-error-func'.
a message sexp looks something like:
2. a message sexp looks something like:
\( \(
:docid 1585 :docid 1585
:from ((\"Donald Duck\" . \"donald@example.com\")) :from ((\"Donald Duck\" . \"donald@example.com\"))
@ -160,34 +172,96 @@ a message sexp looks something like:
:body-txt \" <message body>\" :body-txt \" <message body>\"
\) \)
;; eox ;; eox
=> this will be passed to `mm/proc-header-func'.
a database update looks like: 3. a view looks like:
\(:update 1585 :path \"/home/user/Maildir/foo/cur/12323213:,R\") (:view <msg-sexp>)
when a message has been moved to a new location, or => the <msg-sexp> (see 2.) will be passed to `mm/proc-view-func'.
\(:update 1585 :path \"/dev/null\")
when it has been removed.
other fields are :cc, :bcc, :body-html 4. a database update looks like:
(:update <msg-sexp> :move <nil-or-t>)
When the s-expression comes from the database ('mu find'), the => the <msg-sexp> (see 2.) will be passed to
fields :attachments, :body-txt, :body-html, :references, :in-reply-to `mm/proc-update-func', :move tells us whether this is a move to
are missing (because that information is not stored in the another maildir, or merely a flag change.
database).
On the other hand, if the information comes from the message file, 5. a remove looks like:
there won't be a :docid field." (:remove <docid>)
(condition-case nil => the docid will be passed to `mm/proc-remove-func'
(car (read-from-string str));; read-from-string returns a cons
(error "Failed to parse sexp [%S]" str))) 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'."
(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
((eq (plist-get sexp :msgtype) 'header)
(funcall mm/proc-header-func sexp))
((plist-get sexp :view)
(funcall mm/proc-view-func (plist-get sexp :view)))
((plist-get sexp :update)
(funcall mm/proc-update-func
(plist-get sexp :update) (plist-get sexp :move)))
((plist-get sexp :remove)
(funcall mm/proc-remove-func (plist-get sexp :remove)))
((plist-get sexp :compose)
(funcall mm/proc-compose-func
(plist-get sexp :compose)
(plist-get sexp :action)))
((plist-get sexp :info)
(funcall mm/proc-info-func sexp))
((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 "the mu server process has been stopped"))
(t (message (format "mu server process received signal %d" code)))))
((eq status 'exit)
(cond
((eq code 11) (message "Database is locked by another process"))
(t (message (format "mu server process ended with exit code %d" code)))))
(t
(message "something bad happened to the mu server process")))))
(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."
(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 cmd)
(process-send-string mm/mu-proc (concat cmd "\n"))))
(defun mm/proc-remove-msg (docid) (defun mm/proc-remove-msg (docid)
"Remove message identified by DOCID. The results are reporter "Remove message identified by DOCID. The results are reporter
through either (:update ... ) or (:error ) sexp, which are handled through either (:update ... ) or (:error ) sexp, which are handled
my `mm/proc-update-func' and `mm/proc-error-func', respectively." my `mm/proc-update-func' and `mm/proc-error-func', respectively."
(unless (mm/proc-is-running) (mm/start-proc)) (mm/proc-send-command "remove %d" docid))
(when mm/mu-proc
(process-send-string mm/mu-proc (format "remove %d\n" docid))))
(defun mm/proc-find (expr) (defun mm/proc-find (expr)
@ -196,17 +270,16 @@ function is called, depending on the kind of result. The variables
`mm/proc-header-func' and `mm/proc-error-func' contain the function `mm/proc-header-func' and `mm/proc-error-func' contain the function
that will be called for, resp., a message (header row) or an that will be called for, resp., a message (header row) or an
error." error."
(unless (mm/proc-is-running) (mm/start-proc)) (mm/proc-send-command "find \"%s\"" expr))
(when mm/mu-proc
(process-send-string mm/mu-proc (format "find %s\n" expr))))
(defun mm/proc-move-msg (docid targetdir flags) (defun mm/proc-move-msg (docid targetmdir &optional flags)
"Move message identified by DOCID to TARGETDIR, setting FLAGS in "Move message identified by DOCID to TARGETMDIR, optionally
the process. setting FLAGS in the process.
TARGETDIR must be a maildir, that is, the part _without_ cur/ or TARGETDIR must be a maildir, that is, the part _without_ cur/ or
new/. new/ or the root-maildir-prefix. E.g. \"/archive\". This directory
must already exist.
The FLAGS parameter can have the following forms: The FLAGS parameter can have the following forms:
1. a list of flags such as '(passed replied seen) 1. a list of flags such as '(passed replied seen)
@ -225,32 +298,38 @@ The results are reported through either (:update ... )
or (:error ) sexp, which are handled my `mm/proc-update-func' and or (:error ) sexp, which are handled my `mm/proc-update-func' and
`mm/proc-error-func', respectively." `mm/proc-error-func', respectively."
(let (let
((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))
(unless (and (file-directory-p targetdir) (file-writable-p targetdir)) (fullpath (concat mm/maildir targetmdir)))
(error "Not a writable directory: %s" targetdir)) (unless (and (file-directory-p fullpath) (file-writable-p fullpath))
(error "Not a writable directory: %s" fullpath))
(unless (mm/proc-is-running) (mm/start-proc)) (mm/proc-send-command "move %d %s %s" docid targetmdir flagstr)))
(when mm/mu-proc
(process-send-string mm/mu-proc
(format "move %d %s %s\n" docid targetdir flagstr)))))
(defun mm/proc-flag-msg (docid flags) (defun mm/proc-flag-msg (docid flags)
"Set FLAGS for the message identified by DOCID." "Set FLAGS for the message identified by DOCID."
(let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) (let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags))))
(unless (mm/proc-is-running) (mm/start-proc)) (mm/proc-send-command "flag %d %s" docid flagstr)))
(when mm/mu-proc
(process-send-string mm/mu-proc
(format "flag %d %s\n" docid flagstr)))))
(defun mm/proc-index (maildir)
"Update the message database."
(mm/proc-send-command "index %s" maildir))
(defun mm/proc-view-msg (docid) (defun mm/proc-view-msg (docid)
"Get one particular message based on its DOCID. The result will "Get one particular message based on its DOCID. The result will
be delivered to the function registered as `mm/proc-message-func'." be delivered to the function registered as `mm/proc-message-func'."
(unless (mm/proc-is-running) (mm/start-proc)) (mm/proc-send-command "view %d" docid))
(when mm/mu-proc
(process-send-string mm/mu-proc (defun mm/proc-compose-msg (docid reply-or-forward)
(format "view %d\n" docid)))) "Start composing a message as either a forward or reply to
message with DOCID. REPLY-OR-FORWARD is either 'reply or 'forward.
The result will be delivered to the function registered as
`mm/proc-compose-func'."
(let ((action (cond
((eq reply-or-forward 'forward) "forward")
((eq reply-or-forward 'reply) "reply")
(t (error "symbol must be eiter 'reply or 'forward")))))
(mm/proc-send-command "compose %s %d" action docid)))
(provide 'mm-proc) (provide 'mm-proc)

436
toys/mm/mm-send.el Normal file
View File

@ -0,0 +1,436 @@
;; 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
;; 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.")
(defconst mm/msg-separator "--text follows this line--\n\n"
"separator between headers and body, needed for `message-mode'")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)))))
(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\."
(mapconcat
(lambda (recip)
(let ((name (car recip)) (email (cdr recip)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))
(defun mm/msg-hidden-header (hdr val)
"Return user-invisible header to the message (HDR: VAL\n)."
;; (format "%s: %s\n" hdr val))
(propertize (format "%s: %s\n" hdr val) 'invisible t))
(defun 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))
(msgid (plist-get msg :message-id)))
(if msgid ;; every received message should have one...
(mapconcat 'identity (append refs (list msgid)) ",")
(mapconcat 'identity refs ","))))
(defun mm/msg-to-create (msg reply-all)
"Construct the To: header for a reply-message based on some
message MSG. If REPLY-ALL is nil, this the the Reply-To addresss of
MSG if it exist, or the From:-address othewise. If reply-all is
non-nil, the To: is what was in the old To: with either the
Reply-To: or From: appended, and then the
receiver (i.e. `user-mail-address') removed.
So:
reply-all nil: Reply-To: or From: of MSG
reply-all t : Reply-To: or From: of MSG + To: of MSG - `user-mail-address'
The result is either nil or a string which can be used for the To:-field."
(let ((to-lst (plist-get msg :to))
(reply-to (plist-get msg :reply-to))
(from (plist-get msg :from)))
(if reply-all
(progn ;; reply-all
(setq to-lst ;; append Reply-To:, or if not set, From: if set
(if reply-to (cons `(nil . ,reply-to) to-lst)
(if from (append to-lst from)
to-lst)))
;; and remove myself from To:
(setq to-lst (mm/msg-recipients-remove to-lst user-mail-address))
(mm/msg-recipients-to-string to-lst))
;; reply single
(progn
(or reply-to (mm/msg-recipients-to-string 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 same list as the
one in MSG, minus `user-mail-address'. The result of this function
is either nil or a string to be used for the Cc: field."
(let ((cc-lst (plist-get msg :cc)))
(when (and reply-all cc-lst)
(mm/msg-recipients-to-string
(mm/msg-recipients-remove cc-lst
user-mail-address)))))
(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 reply-all)
"Create a draft message as a reply to MSG; if REPLY-ALL is
non-nil, reply to all recipients.
A reply message has fields:
From: - see `mu-msg-from-create'
To: - see `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 `mm/msg-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" (or (mm/msg-to-create msg reply-all) ""))
(mm/msg-header "Cc" (mm/msg-cc-create msg reply-all))
(mm/msg-hidden-header "User-agent" (mm/msg-user-agent))
(mm/msg-hidden-header "References" (mm/msg-references-create msg))
(mm/msg-hidden-header "In-reply-to" (plist-get msg :message-id))
(mm/msg-header"Subject"
(concat mm/msg-reply-prefix (plist-get msg :subject)))
mm/msg-separator
(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 `mm/msg-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-for-new) ""))
(when (boundp 'mail-reply-to)
(mm/msg-header "Reply-To" mail-reply-to))
(mm/msg-header "To" "")
(mm/msg-hidden-header "User-agent" (mm/msg-user-agent))
(mm/msg-hidden-header "References" (mm/msg-references-for-reply msg))
(mm/msg-header"Subject"
(concat mm/msg-forward-prefix (plist-get msg :subject)))
mm/msg-separator
(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 `mm/msg-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-hidden-header "User-agent" (mm/msg-user-agent))
(mm/msg-header "Subject" "")
mm/msg-separator))
(defconst mm/msg-prefix "mm" "prefix for mm-generated
mail files; we use this to ensure that our hooks don't mess
with non-mm-generated messages")
(defun mm/msg-draft-file-name ()
"Create a Maildir-compatible[1], unique file name for a draft
message.
[1]: see http://cr.yp.to/proto/maildir.html"
(format "%s-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
mm/msg-prefix
(format-time-string "%Y%m%d" (current-time))
(emacs-pid)
(random t)
(replace-regexp-in-string "[:/]" "_" (system-name))))
(defvar mm/send-reply-docid nil "Docid of the message this is a reply to.")
(defvar mm/send-forward-docid nil "Docid of the message being forwarded.")
(defun mm/msg-compose (str &optional parent-docid reply-or-forward)
"Create a new draft message in the drafts folder with STR as
its contents, and open this message file for editing.
For replies/forewards, you can specify PARENT-DOCID so the
corresponding message can get its Passed or Replied flag set when
this one is sent. If PARENT-DOCID is specified, also
reply-or-forward should be specified, which is a symbol, either
'reply or 'forward.
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',
`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"))
;; write our draft message to the the drafts folder
(let ((draftfile (concat mm/maildir "/" mm/drafts-folder "/cur/"
(mm/msg-draft-file-name))))
(with-temp-file draftfile (insert str))
(find-file draftfile) (rename-buffer mm/msg-draft-name t)
(message-mode)
(make-local-variable 'mm/send-reply-docid)
(make-local-variable 'mm/send-forward-docid)
(if (eq reply-or-forward 'reply)
(setq mm/send-reply-docid parent-docid)
(setq mm/send-forward-docid parent-docid))
(message-goto-body)))
(defun mm/send-compose-handler (msg reply-or-forward)
"This function is registered as the compose handler in
`mm/proc-compose-func', and will be called when a new message is to
be composed, based on some existing one. MSG is a message sexp,
while REPLY-OR-FORWARD is a symbol, either 'reply or 'forward.
In case of 'forward, create a draft forward for MSG, and switch to
an edit buffer with the draft message.
In case of 'reply, create a draft reply to MSG, and swith to an
edit buffer with the draft message"
(unless (member reply-or-forward '(reply forward))
(error "unexpected type in compose handler"))
(let ((parent-docid (plist-get msg :docid)))
(if (eq reply-or-forward 'forward)
;; forward
(when (mm/msg-compose (mm/msg-create-forward msg) parent-docid 'forward)
(message-goto-to))
;; reply
(let* ((recipnum (+ (length (plist-get msg :to))
(length (plist-get msg :cc))))
(replyall (when (> recipnum 1)
(yes-or-no-p
(format "Reply to all ~%d recipients (y) or only the sender (n)? "
(+ recipnum))))))
;; exact num depends on some more things
(when (mm/msg-compose (mm/msg-create-reply msg replyall) parent-docid 'reply)
(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'."
(when (mm/msg-is-mm-message) ;; only if we are mm
(unless mm/sent-folder (error "mm/sent-folder not set"))
;; we don't know the draft message is already in the database...
;;
;; ;; TODO: remove duplicate flags
;; ((newflags ;; remove Draft; maybe set 'Seen' as well?
;; (delq 'draft (mm/msg-flags-from-path (buffer-file-name))))
;; ;; so, we register path => uid, then we move uid, then check the name
;; ;; uid is referring to
;; (uid (mm/msg-register (buffer-file-name)))
;; (if (mm/msg-move uid
;; (concat mm/maildir mm/sent-folder)
;; (mm/msg-flags-to-string newflags))
;; (set-visited-file-name (mm/msg-get-path uid) t t)
;; (error "Failed to save message to the Sent-folder"))))))
))
(defun mm/send-set-parent-flag ()
"Set the 'replied' flag on messages we replied to, and the
'passed' flag on message we have forwarded.
NOTE: This does not handle the case yet of message which are
edited from drafts. That case could be solved by searching for
the In-Reply-To message-id for replies.
This is meant to be called from message mode's
`message-sent-hook'."
;; handle the replied-to message
(when mm/send-reply-docid (mm/proc-flag-msg mm/send-reply-docid "+R"))
(when mm/send-forward-docid (mm/proc-flag-msg mm/send-forward-docid "+P")))
;; hook our functions up with sending of the message
;;(add-hook 'message-sent-hook 'mm/msg-save-to-sent)
(add-hook 'message-sent-hook 'mm/send-set-parent-flag)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; some interactive function
(defun mm/compose-new ()
"Create a draft message, and switch to an edit buffer with the
draft message."
(interactive)
(when (mm/msg-compose (mm/msg-create-new))
(message-goto-to)))
(provide 'mm-send)

253
toys/mm/mm-view.el Normal file
View File

@ -0,0 +1,253 @@
;; 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 'mm-common)
(require 'html2text)
(defconst mm/view-buffer-name "*mm-view*"
"*internal* Name for the 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)
"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.
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)
(case field
(:subject (mm/view-header "Subject" (plist-get msg :subject)))
(:path (mm/view-header "Path" (plist-get msg :path)))
(:to (mm/view-contacts msg field))
(:from (mm/view-contacts msg field))
(:cc (mm/view-contacts msg field))
(:bcc (mm/view-contacts msg field))
(:date
(let* ((date (plist-get msg :date))
(datestr (when date (format-time-string "%c" date))))
(if datestr (mm/view-header "Date" datestr) "")))
(:flags "") ;; TODO
(:maildir (mm/view-header "Maildir" (plist-get msg :maildir)))
(:size (mm/view-size msg)
(let* ((size (plist-get msg :size))
(sizestr (when size (format "%d bytes"))))
(if sizestr (mm/view-header "Size" sizestr))))
(:attachments "") ;; TODO
(t (error "Unsupported field: %S" field))))
mm/view-headers "")
"\n"
(mm/view-body msg))
(mm/view-mode)
(setq
mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid))
;; these are buffer-local
mm/current-msg msg
mm/hdrs-buffer hdrsbuf)
(switch-to-buffer buf)
(goto-char (point-min)))))
(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)
"Show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD\n."
(if val
(concat
(propertize key 'face 'mm/view-header-key-face) ": "
(propertize val 'face 'mm/view-header-value-face) "\n")
""))
(defun mm/view-contacts (msg field)
(unless (member field '(:to :from :bcc :cc)) (error "Wrong type"))
(let* ((lst (plist-get msg field))
(contacts
(when lst
(mapconcat
(lambda(c)
(let ((name (car c)) (email (cdr c)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))))
(if contacts
(mm/view-header
(case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc"))
contacts)
"")))
(defvar 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 "j" 'mm/jump-to-maildir)
;; (define-key map "f" 'mua/view-forward)
;; (define-key map "r" 'mua/view-reply)
;; (define-key map "c" 'mua/view-compose)
;; navigation between messages
(define-key map "n" 'mm/view-next)
(define-key map "p" 'mm/view-prev)
;; marking/unmarking
(define-key map "d" 'mm/view-mark-for-trash)
(define-key map "D" 'mm/view-mark-for-delete)
(define-key map "m" 'mm/view-mark-for-move)
;; next two only warn user
(define-key map "u" 'mm/view-unmark)
(define-key map "U" 'mm/view-unmark)
(define-key map "x" 'mm/view-marked-execute)
map)
"Keymap for \"*mm-view*\" buffers.")
(fset 'mm/view-mode-map mm/view-mode-map)
(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)
(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))
;; if so, mark it as non-new and read
(mm/proc-flag-msg docid "+S-u-N")))))
;; Interactive functions
(defun mm/view-quit-buffer ()
"Quit the message view and return to the headers."
(interactive)
(mm/view-mark-as-read-maybe)
(let ((inhibit-read-only t))
(kill-buffer)
(switch-to-buffer mm/hdrs-buffer)))
(defun mm/view-next ()
"View the next message."
(interactive)
(mm/view-mark-as-read-maybe)
(with-current-buffer mm/hdrs-buffer
(when (mm/next-header)
(mm/hdrs-view))))
(defun mm/view-prev ()
"View the previous message."
(interactive)
(mm/view-mark-as-read-maybe)
(with-current-buffer mm/hdrs-buffer
(when (mm/prev-header)
(mm/hdrs-view))))
(defun mm/view-mark-for-trash ()
"Mark the viewed message to be moved to the trash folder."
(interactive)
(with-current-buffer mm/hdrs-buffer
(when (mm/mark-for-trash)
(mm/hdrs-view))))
(defun mm/view-mark-for-delete ()
"Mark the viewed message to be deleted."
(interactive)
(with-current-buffer mm/hdrs-buffer
(when (mm/mark-for-trash)
(mm/hdrs-view))))
(defun mm/view-mark-for-move ()
"Mark the viewed message to be moved to some folder."
(interactive)
(with-current-buffer mm/hdrs-buffer
(when (mm/mark-for-move)
(mm/view-next))))
(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"))
(provide 'mm-view)

233
toys/mm/mm.el
View File

@ -1,4 +1,4 @@
;;; mm.el -- part of mm, the mu mail user agent
;; ;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema ;; Copyright (C) 2011 Dirk-Jan C. Binnema
@ -28,9 +28,9 @@
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(add-to-list 'load-path "/home/djcb/Sources/mu/toys/mm")
(require 'mm-hdrs) (require 'mm-hdrs)
(require 'mm-view)
(require 'mm-send)
(require 'mm-common) (require 'mm-common)
(require 'mm-proc) (require 'mm-proc)
@ -60,6 +60,15 @@ PATH, you can specifiy the full path."
:group 'mm) :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)
;; Folders ;; Folders
(defgroup mm/folders nil (defgroup mm/folders nil
@ -97,6 +106,47 @@ PATH, you can specifiy the full path."
:safe 'stringp :safe 'stringp
:group 'mm/folders) :group 'mm/folders)
(defgroup mm/view nil
"Settings for the message view."
:group 'mm)
;; the message view
(defcustom mm/view-headers
'(:from :to :cc :subject :flags :date :maildir :path :attachments)
"Header fields to display in the message view buffer."
:type (list 'symbol)
:group 'mm/view)
;; 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 ;; Faces
(defgroup mm/faces nil (defgroup mm/faces nil
@ -110,43 +160,170 @@ PATH, you can specifiy the full path."
:group 'mm/faces) :group 'mm/faces)
(defface mm/moved-face (defface mm/moved-face
'((t :inherit font-lock-comment-face :italic t)) '((t :inherit font-lock-comment-face :slant italic))
"Face for an mm message header that has been moved from the "Face for an mm message header that has been moved to some
search results." 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-though t))
"Face for an message header in the trash folder."
:group 'mm/faces) :group 'mm/faces)
(defface mm/header-face (defface mm/header-face
'((t :inherit default)) '((t :inherit default))
"Face for an mm header without any special flags." "Face for an mm header without any special flags."
:group 'deft-faces) :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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FIXME
(setq
mm/maildir "/home/djcb/Maildir"
mm/inbox-folder "/inbox"
mm/outbox-folder "/outbox"
mm/sent-folder "/sent"
mm/drafts-folder "/drafts"
mm/trash-folder "/trash")
(defvar mm/working-folders nil)
(setq mm/working-folders
'("/bulk" "/archive" "/bulkarchive" "/todo"))
(setq mm/header-fields
'( (:date . 25)
(:flags . 6)
(:from . 22)
(:subject . 40)))
;;; my stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq mm/mu-binary "/home/djcb/Sources/mu/src/mu") ;; internal variables / constant
(setq mm/mu-home "/home/djcb/.mu") (defconst mm/mm-buffer-name "*mm*"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; "*internal* Name of the mm main buffer.")
(defvar mm/mu-version nil
"*interal* version of the mu binary")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mm mode + keybindings
(defvar mm/mm-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "I" 'mm/jump-to-inbox)
(define-key map "S" 'mm/search-today)
(define-key map "W" 'mm/search-last-7-days)
(define-key map "U" 'mm/search-unread)
(define-key map "s" 'mm/search)
(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 "r" 'mm/retrieve-mail)
(define-key map "u" 'mm/update-database)
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*"
truncate-lines t
buffer-read-only t
overwrite-mode 'overwrite-mode-binary))
(defun mm()
"Start mm."
(interactive)
(let ((buf (get-buffer-create mm/mm-buffer-name))
(inhibit-read-only t))
(with-current-buffer buf
(erase-buffer)
(insert
"* "
(propertize "mm - mail for emacs\n" 'face 'mm/title-face)
"\n"
" Watcha wanna do?\n\n"
" * Show me some messages:\n"
" - In your " (propertize "I" 'face 'highlight) "nbox\n"
" - " (propertize "U" 'face 'highlight) "nread messages\n"
" - Received " (propertize "T" 'face 'highlight) "oday\n"
" - Received this " (propertize "W" 'face 'highlight) "eek\n"
"\n"
" * " (propertize "j" 'face 'highlight) "ump to a folder\n"
" * " (propertize "s" 'face 'highlight) "earch for a specific message\n"
"\n"
" * " (propertize "c" 'face 'highlight) "ompose a new message\n"
"\n"
" * " (propertize "r" 'face 'highlight) "etrieve new mail\n"
" * " (propertize "u" 'face 'highlight) "update the message database\n"
"\n"
" * " (propertize "q" 'face 'highlight) "uit mm\n")
(mm/mm-mode)
(switch-to-buffer buf))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; interactive functions
(defun mm/jump-to-inbox ()
"Jump to your Inbox folder (as specified in `mm/inbox-folder')."
(interactive)
(mm/hdrs-search (concat "maildir:" mm/inbox-folder)))
(defun mm/search-unread ()
"List all your unread messages."
(interactive)
(mm/hdrs-search "flag:unread AND NOT flag:trashed"))
(defun mm/search-today ()
"List messages received today."
(interactive)
(mm/hdrs-search "date:today..now"))
(defun mm/search-last-7-days ()
"List messages received in the last 7 days."
(interactive)
(mm/hdrs-search "flag:7d..now"))
(defun mm/retrieve-mail ()
"Get new mail."
(interactive)
(unless mm/get-mail-command
(error "`mm/get-mail-command' is not set"))
(when (y-or-n-p "Sure you want to retrieve new mail?")
(shell-command mm/get-mail-command)))
(defun mm/update-database ()
"Update the database (ie., 'mu index')."
(interactive)
(unless mm/maildir (error "`mm/maildir' not set"))
(when (y-or-n-p "Sure you want to update the database?")
(mm/proc-index mm/maildir)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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) (provide 'mm)