* mua updates

This commit is contained in:
Dirk-Jan C. Binnema 2011-08-16 23:44:08 +03:00
parent a84d72e7cf
commit 43b1edbbe5
5 changed files with 183 additions and 197 deletions

View File

@ -53,8 +53,8 @@
"*internal* The mu-find process.")
(defvar mua/hdrs-hash nil
"*internal* The bol->uid hash.")
(defvar mua/hdrs-marks-hash nil
"*internal* The hash for marked messages.")
(defconst mua/eom "\n;;eom\n"
"*internal* Marker for the end of message in the mu find
@ -191,8 +191,8 @@
(defun mua/hdrs-set-path (path)
"Map the bol of the current header to an entry in
`mua/msg-file-map', and return the uid"
(let ((uid (mua/msg-file-register path)))
`mua/msg-map', and return the uid."
(let ((uid (mua/msg-map-add path)))
(puthash (line-beginning-position 1) uid mua/hdrs-hash)
uid))
@ -202,9 +202,7 @@
(defun mua/hdrs-get-path ()
"Get the current path for the header at point."
(let ((uid (mua/hdrs-get-uid)))
(mua/msg-file-get-path uid)))
(mua/msg-map-get-path (mua/hdrs-get-uid)))
(defun mua/hdrs-append-message (msg)
"append a message line to the buffer and register the message"
@ -370,7 +368,7 @@ if the search process is not already running"
(defun mua/hdrs-change-sort ()
"Change thee sort field and direction."
"Change thee sort field and dirtrection."
(interactive)
(and (call-interactively 'mua/hdrs-change-sort-order)
(call-interactively 'mua/hdrs-change-sort-direction)))
@ -379,48 +377,89 @@ if the search process is not already running"
;;; functions for marking
(defun mua/hdrs-add-marked (uid &optional dst)
"Add the message at point to the markings hash"
(let ((bol (line-beginning-position 1)))
(if (gethash bol mua/hdrs-marks-hash)
(mua/warn "Message is already marked")
(progn (puthash bol (cons uid dst) mua/hdrs-marks-hash) t))))
(defvar mua/hdrs-marks-hash nil
"*internal* The hash for marked messages. The hash maps
bol (beginning-of-line) to a 3-tuple: [UID TARGET FLAGS], where UID is the
the UID of the message file (see `mua/msg-map'), TARGET is the
target maildir (ie., \"/inbox\", but can also be nil (for 'delete);
and finally FLAGS is the flags to set when the message is moved.")
(defun mua/hdrs-remove-marked ()
"Remove the message at point from the markings hash"
(let ((bol (line-beginning-position 1)))
(if (not (gethash bol mua/hdrs-marks-hash))
(mua/warn "Message is not marked")
(progn (remhash bol mua/hdrs-marks-hash) t))))
(defun mua/hdrs-set-mark-ui (bol action)
"Display (or undisplay) the mark for BOL for action ACTION."
(unless (member action '(delete trash move unmark))
(error "Invalid action %S" action))
(save-excursion
(let ((inhibit-read-only t))
(delete-char 2)
(insert
(case action
(delete "d ")
(trash "D ")
(move "m ")
(unmark " "))))))
(defun mua/hdrs-set-mark (bol uid &optional target flags)
"Add a mark to `mua/hdrs-marks-hash', with BOL being the beginning of the line
of the marked message and (optionally) TARGET the target for the trash or move,
and FLAGS the flags to set for the message, either as a string or as a list (see
`mua/msg-move' for a discussion of the format)."
(if (gethash bol mua/hdrs-marks-hash)
(mua/warn "Message is already marked")
(let ((tuple `[,uid ,target ,flags]))
(puthash bol tuple mua/hdrs-marks-hash) ;; add to the hash...
(mua/hdrs-set-mark-ui bol action))))
(defun mua/hdrs-remove-mark (bol)
"Remove the mark for the message at BOL from the markings
hash. BOL must be the point at the beginning of the line."
(if (not (gethash bol mua/hdrs-marks-hash))
(mua/warn "Message is not marked")
(progn
(remhash bol mua/hdrs-marks-hash) ;; remove from the hash...
(mua/hdrs-set-mark-ui bol 'unmark))))
(defun mua/hdrs-marks-execute ()
"Execute the corresponding actions for all marked messages in
`mua/hdrs-marks-hash'."
(interactive)
(let ((n-marked (hash-table-count mua/hdrs-marks-hash)))
(if (= 0 n-marked)
(mua/warn "No marked messages")
(when (y-or-n-p
(format "Execute actions for %d marked message(s)? " n-marked))
(save-excursion
(maphash
(lambda(bol tuple)
(let* ((uid (aref tuple 0)) (target (aref tuple 1))
(flags (aref tuple 2)) (inhibit-read-only t))
(when (mua/msg-move uid target flags)
;; remember the updated path -- for now not too useful
;; as we're hiding the header, but...
(save-excursion
(mua/hdrs-remove-mark bol)
(goto-char bol)
;; when it succeedes, hide msg..)
(put-text-property (line-beginning-position 1)
(line-beginning-position 2) 'invisible t)))))
mua/hdrs-marks-hash))))))
(defun mua/hdrs-set-marker (kar)
"Set the marker at the beginning of this line."
(beginning-of-line 1)
(let ((inhibit-read-only t))
(delete-char 2)
(insert (if kar (format "%c " kar) " "))))
(defun mua/hdrs-mark (action)
"Mark the message at point with one of the symbols: move,
delete, trash, unmark, unmark-all; the latter two are
pseudo-markings."
(let ((uid (mua/hdrs-get-uid)))
"Mark the message at point BOL (the beginning of the line) with
one of the symbols: move, delete, trash, unmark, unmark-all; the
latter two are pseudo-markings."
(let* ((bol (line-beginning-position 1)) (uid (mua/hdrs-get-uid)))
(when uid
(case action
(move
(when (mua/hdrs-add-marked uid
(mua/ask-maildir "Target maildir: " t)) ;; t->return fullpath
(mua/hdrs-set-marker ?m)))
(mua/hdrs-set-mark bol uid (mua/ask-maildir "Target maildir: " t)))
(trash
(when (mua/hdrs-add-marked uid
(concat mua/maildir mua/trash-folder))
(mua/hdrs-set-marker ?d)))
(if (member 'trashed (mua/msg-flags-from-path (mua/hdrs-get-path)))
(mua/warn "Message is already trashed")
(mua/hdrs-set-mark bol uid (concat mua/maildir mua/trash-folder) "+T")))
(delete
(when (mua/hdrs-add-marked uid "/dev/null")
(mua/hdrs-set-marker ?D)))
(mua/hdrs-set-mark bol action uid "/dev/null"))
(unmark
(when (mua/hdrs-remove-marked)
(mua/hdrs-set-marker nil)))
(mua/hdrs-remove-mark bol))
(unmark-all
(when (y-or-n-p (format "Sure you want to remove all (%d) marks? "
(hash-table-count mua/hdrs-marks-hash)))
@ -430,28 +469,6 @@ pseudo-markings."
(t (error "Unsupported mark type")))
(move-beginning-of-line 2))))
(defun mua/hdrs-marks-execute ()
"execute the actions for all marked messages"
(interactive)
(let ((n-marked (hash-table-count mua/hdrs-marks-hash)))
(if (= 0 n-marked)
(mua/warn "No marked messages")
(when (y-or-n-p
(format "Execute actions for %d marked message(s)? " n-marked))
(save-excursion
(maphash
(lambda(bol v)
(let* ((uid (car v)) (target (cdr v)) (inhibit-read-only t))
(when (mua/msg-file-move-uid uid target)
;; remember the updated path -- for now not too useful
;; as we're hiding the header, but...
(goto-char bol)
(mua/hdrs-remove-marked)
(put-text-property (line-beginning-position 1)
(line-beginning-position 2)
'invisible t)))) ;; when it succeedes, hide msg..)
mua/hdrs-marks-hash))))))
;; functions for creating new message -- reply, forward, and new

View File

@ -31,7 +31,7 @@
(eval-when-compile (require 'cl))
(defvar mua/msg-file-map nil
(defvar mua/msg-map nil
"*internal* a map of uid->message.
This map adds a level of indirection for message files; many
@ -42,99 +42,115 @@ message in the system (in practice, the lifetime of a particular
headers buffer).
When creating the headers buffer, the file names are registered
with `mua/msg-file-register'.
with `mua/msg-map-add'.
All operation that change file names ultimately (should) end up
in `mua/msg-file-move', which will update the map after the
moving (using `mua/msg-file-update')
in `mua/msg-move', which will update the map after the
moving (using `mua/msg-map-update')
Other places of the code can use the uid to get the *current*
path of the file using `mua/msg-file-get-path'.
path of the file using `mua/msg-map-get-path'.
")
(defun mua/msg-file-register (path)
"Register a message PATH in the `mua/msg-file-map', and return
the uid for it."
(unless mua/msg-file-map
(setq mua/msg-file-map (make-hash-table :size 256 :rehash-size 2)))
(defun mua/msg-map-add (path)
"Add a message PATH to the `mua/msg-map', and return the uid
for it."
(unless mua/msg-map
(setq mua/msg-map (make-hash-table :size 256 :rehash-size 2 :weakness t)))
(let ((uid (sha1 path)))
(puthash uid path mua/msg-file-map)
(puthash uid path mua/msg-map)
uid))
(defun mua/msg-file-update (uid path)
"Set the new path for the message identified by UID to
PATH."
(if (gethash uid mua/msg-file-map)
(puthash uid path mua/msg-file-map)
(defun mua/msg-map-update (uid path)
"Set the new path for the message identified by UID to PATH."
(if (gethash uid mua/msg-map)
(puthash uid path mua/msg-map)
(mua/warn "No message file registered for uid")))
(defun mua/msg-file-get-path (uid)
(defun mua/msg-map-get-path (uid)
"Get the current path for the message identified by UID."
(gethash uid mua/msg-file-map))
(gethash uid mua/msg-map))
(defun mua/msg-file-move-uid (uid targetdir &optional flags)
(defun mua/msg-move (uid &optional targetdir flags ignore-already)
"Move message identified by UID to TARGETDIR using 'mu mv', and
update the database with the new situation. SRC must be the full,
absolute path to a message file, while TARGETDIR must be a
maildir - that is, the part _without_ cur/ or new/. 'mu mv' will
calculate the target directory and the exact file name. See
`mua/msg-file-map' for a discussion about UID.
`mua/msg-map' for a discussion about UID.
After the file system move (rename) has been done, 'mu remove'
and/or 'mu add' are invoked asynchronously to update the database
with the changes.
Optionally, you can specify the FLAGS for the new file; this must
be a list consisting of one or more of DFNPRST, mean
resp. Deleted, Flagged, New, Passed Replied, Seen and g, as
defined in [1]. See `mua/msg-file-string-to-flags' and
`mua/msg-file-flags-to-string'.
Optionally, you can specify the FLAGS for the new file. The FLAGS
parameter can have the following forms:
1. a list of flags such as '(passed replied seen)
2. a string containing the one-char versions of the flags, e.g. \"PRS\"
3. a delta-string specifying the changes with +/- and the one-char flags,
e.g. \"+S-N\" to set Seen and remove New.
The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or
`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See
`mua/msg-string-to-flags' and `mua/msg-flags-to-string'.
If TARGETDIR is '/dev/null', remove SRC. After the file system
move, the database will be updated as well, using the 'mu add'
and 'mu remove' commands.
If IGNORE-ALREADY is non-nil, don't consider it an error when the target file is
the same as the source file.
Function returns t the move succeeds, in other cases, it returns
`nil'.
nil.
\[1\] http://cr.yp.to/proto/maildir.html."
(let ((src (mua/msg-file-get-path uid)))
(unless src (error "Source path not registered."))
(let ((fulltarget (mua/mu-mv src targetdir flags)))
(when (and fulltarget (not (string= src fulltarget)))
(mua/msg-file-update uid fulltarget) ;; update the path
(mua/mu-remove-async src)
(unless (string= targetdir "/dev/null")
(mua/mu-add-async fulltarget)))))
t)
\[1\] URL `http://cr.yp.to/proto/maildir.html'."
(condition-case err
(let ((src (mua/msg-map-get-path uid)))
(unless src (error "Source path not registered for %S" uid))
(unless (or targetdir src) (error "Either targetdir or flags required"))
(unless (file-readable-p src) (error "Source is unreadable (%S)" src))
(let* ((flagstr
(if (stringp flags) flags (mua/msg-flags-to-string flags)))
(argl (append ;; build-up the command line
'("mv" "--print-target" "--ignore-dups")
(when flagstr (list (concat "--flags=" flagstr)))
(list src)
(when targetdir (list targetdir))))
;; execute it, and get the results
(rv (apply 'mua/mu-run argl))
(code (car rv)) (output (cdr rv)))
(unless (= 0 code)
(error "Moving message failed: %S" output))
;; success!
(let ((targetpath (substring output 0 -1)))
(defun mua/msg-file-mark-as-read (uid)
"Mark the message identified by UID as read if it is not so
already. In Maildir terms, this means moving the message from
\"new/\" to \"cur/\" (if it's not yet there), and setting the
\"S\" flag."
(let* ((path (mua/msg-file-get-path uid))
(flags (and path (mua/msg-file-flags-from-path path))))
(when (or (member 'new flags) (not (member 'seen flags)))
(let* ((newflags (delq 'new (cons 'seen flags)))
(target (mua/msg-file-maildir-from-path path t)))
(unless (mua/msg-file-move-uid uid target newflags)
(mua/warn "Failed to mark message as read"))))))
(when (and targetpath (not (string= src targetpath)))
;; update the UID-map
(mua/msg-map-update uid targetpath)
;; remove the src file
(mua/mu-remove-async src)
;; and add the target file, unless it's dead now
(unless (string= targetdir "/dev/null")
(mua/mu-add-async targetpath)))
t)))
(error (mua/warn "error: %s" (error-message-string err)))))
(defun mua/msg-file-flags-from-path (path)
(defun mua/msg-flags-from-path (path)
"Get the flags for the message at PATH, which does not have to exist.
The flags are returned as a list consisting of one or more of
DFNPRST, mean resp. Deleted, Flagged, New, Passed Replied, Seen
and Trash, as defined in [1]. See `mua/msg-file-string-to-flags'
and `mua/msg-file-flags-to-string'.
and Trash, as defined in [1]. See `mua/msg-string-to-flags'
and `mua/msg-flags-to-string'.
\[1\] http://cr.yp.to/proto/maildir.html."
(when (string-match ",\\(\[A-Z\]*\\)$" path)
(mua/msg-file-string-to-flags (match-string 1 path))))
(mua/msg-string-to-flags (match-string 1 path))))
(defun mua/msg-file-maildir-from-path (path &optional dont-strip-prefix)
(defun mua/msg-maildir-from-path (path &optional dont-strip-prefix)
"Get the maildir from PATH; in this context, 'maildir' is the
part between the `mua/maildir' and the /cur or /new; so
e.g. \"/home/user/Maildir/foo/bar/cur/12345:2,S\" would have
@ -151,23 +167,21 @@ determined, return `nil'."
mdir
(substring mdir (length mua/maildir)))))))
(defun mua/msg-file-flags-to-string (flags)
"Remove duplicates and sort the output of `mua/msg-file-flags-to-string-1'"
(defun mua/msg-flags-to-string (flags)
"Remove duplicates and sort the output of `mua/msg-flags-to-string-1'."
(concat
(sort
(remove-duplicates
(append (mua/msg-file-flags-to-string-1 flags) nil)) '>)))
(append (mua/msg-flags-to-string-1 flags) nil)) '>)))
(defun mua/msg-file-flags-to-string-1 (flags)
(defun mua/msg-flags-to-string-1 (flags)
"Convert a list of flags into a string as seen in Maildir
message files; flags are symbols draft, flagged, new, passed,
replied, seen, trashed and the string is the concatenation of the
uppercased first letters of these flags, as per [1]. Other flags
than the ones listed here are ignored.
Also see `mua/msg-file-string-to-flags'.
Also see `mua/msg-string-to-flags'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when flags
@ -180,20 +194,20 @@ Also see `mua/msg-file-string-to-flags'.
('seen ?S)
('trashed ?T))))
(concat (and kar (string kar))
(mua/msg-file-flags-to-string-1 (cdr flags))))))
(mua/msg-flags-to-string-1 (cdr flags))))))
(defun mua/msg-file-string-to-flags (str)
"Remove duplicates from the output of `mua/msg-file-string-to-flags-1'"
(remove-duplicates (mua/msg-file-string-to-flags-1 str)))
(defun mua/msg-string-to-flags (str)
"Remove duplicates from the output of `mua/msg-string-to-flags-1'"
(remove-duplicates (mua/msg-string-to-flags-1 str)))
(defun mua/msg-file-string-to-flags-1 (str)
(defun mua/msg-string-to-flags-1 (str)
"Convert a string with message flags as seen in Maildir
messages into a list of flags in; flags are symbols draft,
flagged, new, passed, replied, seen, trashed and the string is
the concatenation of the uppercased first letters of these flags,
as per [1]. Other letters than the ones listed here are ignored.
Also see `mua/msg-file-flags-to-string'.
Also see `mua/msg-flags-to-string'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when (/= 0 (length str))
@ -206,6 +220,6 @@ Also see `mua/msg-file-flags-to-string'.
(?S 'seen)
(?T 'trashed))))
(append (when flag (list flag))
(mua/msg-file-string-to-flags-1 (substring str 1))))))
(mua/msg-string-to-flags-1 (substring str 1))))))
(provide 'mua-msg-file)

View File

@ -94,7 +94,7 @@ or if not available, :body-html converted to text)."
(mua/msg-body-txt-or-html msg))
(:maildir ;; messages gotten from mu-view don't have their maildir set...
(or (plist-get msg :maildir)
(mua/msg-file-maildir-from-path (mua/msg-field msg :path))))
(mua/msg-maildir-from-path (mua/msg-field msg :path))))
(t (plist-get msg field))))
@ -334,7 +334,7 @@ body from headers)."
(mua/msg-header "Subject" "")
mua/msg-separator))
(defconst mua/msg-file-prefix "mua" "prefix for mua-generated
(defconst mua/msg-prefix "mua" "prefix for mua-generated
mail files; we use this to ensure that our hooks don't mess
with non-mua-generated messages")
@ -343,7 +343,7 @@ with non-mua-generated messages")
message.
[1]: see http://cr.yp.to/proto/maildir.html"
(format "%s-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
mua/msg-file-prefix
mua/msg-prefix
(format-time-string "%Y%m%d" (current-time))
(emacs-pid)
(random t)
@ -414,14 +414,14 @@ meant to be called from message mode's `message-sent-hook'."
(unless mua/sent-folder (error "mua/sent-folder not set"))
(let* ;; TODO: remove duplicate flags
((newflags ;; remove Draft; maybe set 'Seen' as well?
(delq 'draft (mua/msg-file-flags-from-path (buffer-file-name))))
(delq 'draft (mua/msg-flags-from-path (buffer-file-name))))
;; so, we register path => uid, then we move uid, then check the name
;; uid is referring to
(uid (mua/msg-file-register (buffer-file-name)))
(uid (mua/msg-register (buffer-file-name)))
(if (mua/msg-move uid
(concat mua/maildir mua/sent-folder)
(mua/msg-file-flags-to-string newflags))
(set-visited-file-name (mua/msg-file-get-path uid) t t)
(mua/msg-flags-to-string newflags))
(set-visited-file-name (mua/msg-get-path uid) t t)
(mua/warn "Failed to save message to the Sent-folder"))))))
@ -438,16 +438,15 @@ This is meant to be called from message mode's
`message-sent-hook'."
;; handle the replied-to message
(when mua/msg-reply-uid
(let* ((oldflags (mua/msg-file-flags-from-path (mua/msg-file-get-path uid)))
(newflags (cons 'replied oldflags)))
(mua/msg-file-move uid nil newflags)))
(unless (mua/msg-move mua/msg-reply-uid nil "+R")
(mua/warn "Failed to marked parent message as 'Replied'")))
;; handle the forwarded message
(when mua/msg-forward-uid
(let* ((oldflags (mua/msg-file-flags-from-path (mua/msg-file-get-path uid)))
(newflags (cons 'passed oldflags)))
(mua/msg-file-move uid nil newflags))))
(unless (mua/msg-move mua/msg-forward-uid nil "+P")
(mua/warn "Failed to marked parent message as 'Passed'"))))
;; hook our functions up with sending of the message
(add-hook 'message-sent-hook 'mua/msg-save-to-sent)
(add-hook 'message-sent-hook 'mua/msg-set-replied-or-passed-flag)

View File

@ -59,52 +59,6 @@ to get it"
(match-string 1 (cdr rv))
(mua/warn "Failed to get version string"))))
(defun mua/mu-mv (src target 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/. FLAGS sets
the flags of the message.
TARGET can be nil, in which case only the flags are
changed (which on the file-system level still implies a rename or
even a move if directory if the 'new' flags is added or
removed). FLAGS can also be nil, in which they are not changed.
If both TARGET and FLAGS are nil, nothing happens.
'mu mv' will calculate the full path to target directory and file
based on SRC, TARGET and FLAGS.
FLAGS must be either nil or a list consisting of one or more of
DFNPRST, mean resp. Deleted, Flagged, New, Passed Replied, Seen
and Trash, as defined in [1]. See `mua/msg-file-string-to-flags'
and `mua/msg-file-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."
;; precondition
(unless (or target flags) (error "Either target or flags must
be provided."))
(if (not (file-readable-p src))
(mua/warn "Cannot move unreadable file %s" src)
(let ((argl '("mv" "--printtarget")))
(when flags (add-to-list 'argl (concat "--flags="
(mua/msg-file-flags-to-string flags)) t))
(add-to-list 'argl src t)
(when target (add-to-list 'argl target t))
(let* ((rv (apply 'mua/mu-run argl))
(code (car rv)) (output (cdr rv)))
;; we ignore the error where the target file already exists, as it is
;; likely due to the database not being fully up-to-date and/or sync'ed
;; with what we have on the screen
(if (not (member code `(0 ,mu-error-file-target-equals-source)))
(mua/warn "Moving message file failed: %s" (if output output "error"))
(substring output 0 -1)))))) ;; the full target path, minus the \n
(defun mua/mu-view-sexp (path)
"Return a string with an s-expression representing the message

View File

@ -59,9 +59,9 @@ commands (navigation, marking etc.) to be applied to this
buffer.
For the reasoning to use UID here instead of just the path, see
`mua/msg-file-map'.
`mua/msg-map'.
"
(let* ((path (mua/msg-file-get-path uid))
(let* ((path (mua/msg-map-get-path uid))
(sexp (and path (mua/mu-view-sexp path)))
(msg (and sexp (mua/msg-from-string sexp))))
(if (not msg)
@ -78,9 +78,11 @@ For the reasoning to use UID here instead of just the path, see
mua/view-uid uid
mua/hdrs-buffer headersbuf
mua/parent-buffer headersbuf)
(goto-char (point-min))
(mua/msg-file-mark-as-read uid)))))
;; mark as read
(unless (mua/msg-move uid nil "+S-N" t)
(mua/warn "Failed to mark message as read"))))))
(defun mua/view-message (msg)
"construct a display string for the message"