* mua updates

This commit is contained in:
Dirk-Jan C. Binnema
2011-08-09 22:52:49 +03:00
parent 56086b2f4b
commit 6cdd0f0571
3 changed files with 140 additions and 59 deletions

View File

@ -72,9 +72,9 @@ old one first"
(switch-to-buffer parentbuf)))) (switch-to-buffer parentbuf))))
(defun mua/ask-maildir (prompt &optional fullpath) (defun mua/ask-maildir (prompt &optional fullpath)
"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 (ie, mu-maildir prepended to the non-nill, return the fulpath (ie, mu-maildir prepended to the
maildir" maildir."
(interactive) (interactive)
(let* ((showfolders (let* ((showfolders
(delete-dups (delete-dups
@ -89,11 +89,14 @@ where <exit-code> is the exit code of the program, or 1 if the
process was killed. <str> contains whatever the command wrote on process was killed. <str> contains whatever the command wrote on
standard output/error, or nil if there was none or in case of standard output/error, or nil if there was none or in case of
error. Basically, `mua/mu-run' is like `shell-command-to-string', error. Basically, `mua/mu-run' is like `shell-command-to-string',
but with better possibilities for error handling" but with better possibilities for error handling. The --muhome=
parameter is added automatically if `mua/mu-home' is non-nil."
(let* ((rv) (let* ((rv)
(args (append args (when mua/mu-home
(list (concat "--muhome=" mua/mu-home)))))
(str (with-output-to-string (str (with-output-to-string
(with-current-buffer standard-output ;; but we also get stderr... (with-current-buffer standard-output ;; but we also get stderr...
(setq rv (apply 'call-process mua/mu-binary nil t nil (setq rv (apply 'call-process mua/mu-binary nil t nil
args)))))) args))))))
`(,(if (numberp rv) rv 1) . ,str))) `(,(if (numberp rv) rv 1) . ,str)))
@ -105,18 +108,71 @@ to get it"
(match-string 1 (cdr rv)) (match-string 1 (cdr rv))
(mua/warn "Failed to get version string")))) (mua/warn "Failed to get version string"))))
(defun mua/mu-mv (src target &optional flags)) (defun mua/mu-mv (src target &optional flags)
"Move a message at PATH to TARGET using 'mu mv'. SRC must be
the full, absolute path to a message file, while TARGET must
be a maildir - that is, the part _without_ cur/ or new/. 'mu mv'
will calculate the target directory and the exact file name.
(defun mua/mu-add (src target &optional flags)) Optionally, you can specify the FLAGS for the new file; this must
be a list consisting of one or more of DFNPRST, mean
resp. Deleted, Flagged, New, Passed Replied, Seen and Trash, as
defined in [1]. See `mua/maildir-string-to-flags' and
`mua/maildir-flags-to-string'.
Function returns the target filename if the move succeeds, or
/dev/null if TARGETDIR was /dev/null; in other cases, it returns
`nil'.
\[1\] http://cr.yp.to/proto/maildir.html."
(let ((flagstr
(and flags (mua/maildir-flags-to-string flags))))
(if (not (file-readable-p path))
(mua/warn "Path is note a readable file")
(let ((rv (if flagstr
(mua/run "mv" "--printtarget" path target)
(mua/run "mv" "--printtarget"
(concat "--flags=" flagstr) path target))))
(if (/= 0 (car rv))
(mua/warn "Moving message file failed: %s"
(if (car rv) (car rv) "error"))
(car rv))))))
(defun mua/mu-get-flags (path)
"Get the flags for the message at PATH, which does not have to exist.
The flags are returned as a list consisting of one or more of
DFNPRST, mean resp. Deleted, Flagged, New, Passed Replied, Seen
and Trash, as defined in [1]. See `mua/maildir-string-to-flags'
and `mua/maildir-flags-to-string'.
\[1\] http://cr.yp.to/proto/maildir.html."
(when (string-match ",\\(\[A-Z\]*\\)$" path)
(mua/maildir-string-to-flags (match-string 1 path))))
;; TODO: make this async, but somehow serialize database access
(defun mua/mu-add (path)
"Add message file at PATH to the mu database (using the 'mu
add') command. Return t if it succeed or nil in case of error."
(if (not (file-readable-p path))
(mua/warn "Path is note a readable file")
(let ((rv (mua/mu-run "add" path)))
(if (=/ (car rv) 0)
(mua/warn "mu add failed (%d): %s"
code (if (cdr rv) (cdr rv) "error"))
t))))
;; TODO: make this async, but somehow serialize database access
(defun mua/mu-remove (path) (defun mua/mu-remove (path)
"Remove message at PATH from the database" "Remove message with PATH from the mu database (using the 'mu
remove') command. PATH does not have to exist. Return t if it
succeed or nil in case of error."
) (let ((rv (mua/mu-run "remove" path)))
(when (=/ (car rv) 0)
(defun mua/mu-mv (src target &optional flags)) (mua/warn "mu remove failed (%d): %s"
code (if (cdr rv) (cdr rv) "error"))
t)))
(defun mua/mu-view-sexp (path) (defun mua/mu-view-sexp (path)
"Return a string with an s-expression representing the message "Return a string with an s-expression representing the message
@ -131,5 +187,49 @@ that function converts the string into a Lisp object (plist)"
(mua/warn "mu view failed (%d): %s" (mua/warn "mu view failed (%d): %s"
code (if str str "error")))))) code (if str str "error"))))))
(defun mua/maildir-flags-to-string (flags)
"Convert a list of flags into a string as seen in Maildir
message files; flags are symbols draft, flagged, new, passed,
replied, seen, trashed and the string is the concatenation of the
uppercased first letters of these flags, as per [1]. Other flags
than the ones listed here are ignored.
Also see `mua/maildir-string-to-flags'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when flags
(let ((kar
(case (car flags)
('draft ?D)
('flagged ?F)
('new ?N)
('passed ?P)
('replied ?R)
('seen ?S)
('trashed ?T))))
(concat (and kar (string kar))
(mua/maildir-flags-to-string (cdr flags))))))
(defun mua/maildir-string-to-flags (str)
"Convert a string with message flags as seen in Maildir
messages into a list of flags in; flags are symbols draft,
flagged, new, passed, replied, seen, trashed and the string is
the concatenation of the uppercased first letters of these flags,
as per [1]. Other letters than the ones listed here are ignored.
Also see `mua/maildir-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)
(?N 'new)
(?P 'passed)
(?R 'replied)
(?S 'seen)
(?T 'trashed))))
(append (when flag (list flag))
(mua/maildir-string-to-flags (substring str 1))))))
(provide 'mua-common) (provide 'mua-common)

View File

@ -456,7 +456,8 @@ pseudo-markings."
"Reply to message at point." "Reply to message at point."
(interactive) (interactive)
(let* ((path (mua/hdrs-get-path)) (let* ((path (mua/hdrs-get-path))
(msg (when path (mua/msg-from-path path)))) (str (when path (mua/mu-view-sexp path)))
(msg (and str (mua/msg-from-string str))))
(if msg (if msg
(mua/msg-compose (mua/msg-create-reply msg (mua/msg-compose (mua/msg-create-reply msg
(yes-or-no-p "Reply to all? "))) (yes-or-no-p "Reply to all? ")))

View File

@ -78,7 +78,7 @@ text, using `html2text'."
(insert body) (insert body)
(html2text) (html2text)
(buffer-string))))) (buffer-string)))))
body)) body))
(defun mua/msg-field (msg field) (defun mua/msg-field (msg field)
"Get a field from this message, or nil. The fields are the "Get a field from this message, or nil. The fields are the
@ -92,9 +92,6 @@ or if not available, :body-html converted to text)."
(t (plist-get msg field)))) (t (plist-get msg field))))
;; TODO: add better error-reporting to mua/msg-move, and make flag handling a
;; bit more lispy
(defun mua/msg-move (src targetdir &optional flags) (defun mua/msg-move (src targetdir &optional flags)
"Move message at SRC to TARGETDIR using 'mu mv'; SRC must be "Move message at SRC to TARGETDIR using 'mu mv'; SRC must be
the full, absolute path to a message file, while TARGETDIR must the full, absolute path to a message file, while TARGETDIR must
@ -102,9 +99,10 @@ be a maildir - that is, the part _without_ cur/ or new/. 'mu mv'
will calculate the target directory and the exact file name. will calculate the target directory and the exact file name.
Optionally, you can specify the FLAGS for the new file; this must Optionally, you can specify the FLAGS for the new file; this must
be a string consisting of one or more of DFNPRST, mean be a list consisting of one or more of DFNPRST, mean
resp. Deleted, Flagged, New, Passed Replied, Seen and Trash, as resp. Deleted, Flagged, New, Passed Replied, Seen and Trash, as
defined in [1]. defined in [1]. See `mua/maildir-string-to-flags' and
`mua/maildir-flags-to-string'.
If TARGETDIR is '/dev/null', remove SRC. After the file system If TARGETDIR is '/dev/null', remove SRC. After the file system
move, the database will be updated as well, using the 'mu add' move, the database will be updated as well, using the 'mu add'
@ -115,32 +113,12 @@ Function returns the target filename if the move succeeds, or
`nil'. `nil'.
\[1\] http://cr.yp.to/proto/maildir.html." \[1\] http://cr.yp.to/proto/maildir.html."
(let ((fulltarget (mua/mu-mv str target flags)))
;; require the flags to be kosher (when fulltarget
(when (and flags (let ((case-fold-search nil)) (mua/mu-remove src)
(string-match "[^DFNPRST]" flags))) (error Illegal flags))
(let* ((cmd (concat
mua/mu-binary " mv --printtarget "
(when flags (concat "--flags=" flags " "))
(shell-quote-argument src) " "
(shell-quote-argument targetdir)))
(fulltarget (shell-command-to-string cmd)))
(mua/log cmd)
(mua/log
(if fulltarget (concat "Message has been moved to " fulltarget)
"Message moving failed"))
;; now, if saving worked, anynchronously try to update the database
(when fulltarget ;; note, we don't check the result of the db output
(mua/log "Removing from database: %s" src)
(start-process " *mu-remove*" nil mua/mu-binary "remove" src)
(unless (string= targetdir "/dev/null") (unless (string= targetdir "/dev/null")
(mua/log "Adding to database: %s" fulltarget) mua/mu-add fulltarget))
(start-process " *mu-add*" nil mua/mu-binary "add" fulltarget) t)
)
fulltarget)) fulltarget))
@ -170,18 +148,21 @@ version of mua and emacs."
line (with the %s's replaced with the date of MSG and the name 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 or e-mail address of its sender (or 'someone' if nothing
else)), followed of the quoted body of MSG, constructed by by else)), followed of the quoted body of MSG, constructed by by
prepending `mua/msg-citation-prefix' to each line." prepending `mua/msg-citation-prefix' to each line. If there is
(let ((from (mua/msg-field msg :from))) no body in MSG, return nil."
(concat (let* ((from (mua/msg-field msg :from))
(format "On %s, %s wrote:" (body (mua/msg-body-txt-or-html msg)))
(format-time-string "%c" (mua/msg-field msg :date)) (when body
(if (and from (car from)) ;; a list ((<name> . <email>)) (concat
(or (caar from) (cdar from) "someone") (format "On %s, %s wrote:"
"someone")) (format-time-string "%c" (mua/msg-field msg :date))
"\n\n" (if (and from (car from)) ;; a list ((<name> . <email>))
(replace-regexp-in-string "^" " > " (or (caar from) (cdar from) "someone")
(mua/msg-body-txt-or-html msg))))) "someone"))
"\n\n"
(replace-regexp-in-string "^" " > " body)))))
(defun mua/msg-recipients-remove (lst email-to-remove) (defun mua/msg-recipients-remove (lst email-to-remove)
"Remove the recipient with EMAIL from the recipient list (of "Remove the recipient with EMAIL from the recipient list (of
form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))." form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))."
@ -390,7 +371,7 @@ with non-mua-generated messages")
"Create a Maildir-compatible[1], unique file name for a draft "Create a Maildir-compatible[1], unique file name for a draft
message. message.
[1]: see http://cr.yp.to/proto/maildir.html" [1]: see http://cr.yp.to/proto/maildir.html"
(format "%s-%x-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available (format "%s-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
mua/msg-file-prefix mua/msg-file-prefix
(format-time-string "%Y%m%d" (current-time)) (format-time-string "%Y%m%d" (current-time))
(emacs-pid) (emacs-pid)
@ -424,7 +405,6 @@ using Gnus' `message-mode'."
(message-goto-body))) (message-goto-body)))
(defun mua/msg-is-mua-message () (defun mua/msg-is-mua-message ()
"Check whether the current buffer refers a mua-message based on "Check whether the current buffer refers a mua-message based on
the buffer file name; this is used in hooks we install on the buffer file name; this is used in hooks we install on