mirror of
https://github.com/djcb/mu.git
synced 2024-06-29 07:51:04 +02:00
228 lines
8.1 KiB
EmacsLisp
228 lines
8.1 KiB
EmacsLisp
;;; mua-msg.el -- part of mua, 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:
|
|
|
|
;; mua
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl))
|
|
|
|
|
|
(defvar mua/msg-map nil
|
|
"*internal* a map of uid->message.
|
|
|
|
This map adds a level of indirection for message files; many
|
|
actions (such moving, responding to or even reading a message)
|
|
cause the file names to change. Here we map the initial file to a
|
|
uid, the latter which stays constant over the lifetime of a
|
|
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-map-add'.
|
|
|
|
All operation that change file names ultimately (should) end up
|
|
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-map-get-path'.
|
|
")
|
|
|
|
(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-map)
|
|
uid))
|
|
|
|
(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-map-get-path (uid)
|
|
"Get the current path for the message identified by UID."
|
|
(gethash uid mua/msg-map))
|
|
|
|
(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-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. 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.
|
|
|
|
\[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)))
|
|
|
|
(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-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-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-string-to-flags (match-string 1 path))))
|
|
|
|
|
|
(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
|
|
\"/foo/bar\" as its maildir. If DONT-STRIP-PREFIX is non-nil,
|
|
function will instead _not_ remove the `mua/maildir' from the
|
|
front - so in that case, the example would return
|
|
\"/home/user/Maildir/foo/bar/\". If the maildir cannot be
|
|
determined, return `nil'."
|
|
(when (and (string-match "^\\(.*\\)/\\(cur\\|new\\)/\[^/\]*$" path))
|
|
(let ((mdir (match-string 1 path)))
|
|
(when (and (< (length mua/maildir) (length mdir))
|
|
(string= (substring mdir 0 (length mua/maildir)) mua/maildir))
|
|
(if dont-strip-prefix
|
|
mdir
|
|
(substring mdir (length mua/maildir)))))))
|
|
|
|
(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-flags-to-string-1 flags) nil)) '>)))
|
|
|
|
(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-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)
|
|
('encrypted ?x)
|
|
('signed ?s)
|
|
('unread ?u))))
|
|
(concat (and kar (string kar))
|
|
(mua/msg-flags-to-string-1 (cdr flags))))))
|
|
|
|
|
|
(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-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-flags-to-string'.
|
|
|
|
\[1\]: http://cr.yp.to/proto/maildir.html"
|
|
(when (/= 0 (length str))
|
|
(let ((flag
|
|
(case (string-to-char str)
|
|
(?D 'draft)
|
|
(?F 'flagged)
|
|
(?P 'passed)
|
|
(?R 'replied)
|
|
(?S 'seen)
|
|
(?T 'trashed))))
|
|
(append (when flag (list flag))
|
|
(mua/msg-string-to-flags-1 (substring str 1))))))
|
|
|
|
(provide 'mua-msg-file)
|