From 76c8d21c738c8eeed3d3ee5dd8eb0efe4beb2eda Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Tue, 16 Aug 2011 00:09:34 +0300 Subject: [PATCH] * mua updates --- toys/mua/mua-common.el | 76 +------------- toys/mua/mua-hdrs.el | 81 ++++++++------- toys/mua/mua-msg-file.el | 211 +++++++++++++++++++++++++++++++++++++++ toys/mua/mua-msg.el | 113 +++++++++------------ toys/mua/mua-mu.el | 111 +++++++++++--------- toys/mua/mua-view.el | 106 +++++++++++--------- toys/mua/mua.el | 4 +- 7 files changed, 431 insertions(+), 271 deletions(-) create mode 100644 toys/mua/mua-msg-file.el diff --git a/toys/mua/mua-common.el b/toys/mua/mua-common.el index 50ac474c..ee2a1824 100644 --- a/toys/mua/mua-common.el +++ b/toys/mua/mua-common.el @@ -30,6 +30,8 @@ (eval-when-compile (require 'cl)) +(require 'ido) + (defconst mua/log-buffer-name "*mua-log*" "name of the logging buffer") (defun mua/warn (frm &rest args) @@ -82,79 +84,5 @@ maildir." (chosen (ido-completing-read prompt showfolders))) (concat (if fullpath mua/maildir "") chosen))) -(defun mua/maildir-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/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)))) - - - -(defun mua/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))))))) - -;; TODO: ensure flag string have the chars in ASCII-order (as per maildir spec) -;; TODO: filter-out duplicate flags - -(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) - ('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) - (?P 'passed) - (?R 'replied) - (?S 'seen) - (?T 'trashed)))) - (append (when flag (list flag)) - (mua/maildir-string-to-flags (substring str 1)))))) (provide 'mua-common) diff --git a/toys/mua/mua-hdrs.el b/toys/mua/mua-hdrs.el index 88bff80f..48d73c04 100644 --- a/toys/mua/mua-hdrs.el +++ b/toys/mua/mua-hdrs.el @@ -51,15 +51,15 @@ (defvar mua/hdrs-hash nil "the bol->path hash") (defvar mua/hdrs-marks-hash nil "the hash for marked messages") -(defconst mua/eom "\n;;eom\n" "marker for the end of message in -the mu find output") +(defconst mua/eom "\n;;eom\n" "*internal* Marker for the end of message in +the mu find output.") (defconst mua/hdrs-buffer-name "*mua-headers*" - "name of the mua headers buffer") + "*internal* Name of the mua headers buffer.") (defun mua/hdrs-proc-filter (proc str) - "process-filter for the 'mu find --format=sexp output; it + "A process-filter for the 'mu find --format=sexp output; it accumulates the strings into valid sexps by checking of the - ';;eom' end-of-msg marker, and then evaluating them" + ';;eom' end-of-msg marker, and then evaluating them." (let ((procbuf (process-buffer proc))) (when (buffer-live-p procbuf) (with-current-buffer procbuf @@ -73,7 +73,7 @@ the mu find output") (setq eom (string-match mua/eom mua/buf)))))))))) (defun mua/hdrs-proc-sentinel (proc msg) - "Check the process upon completion" + "Check the process upon completion." (let ((procbuf (process-buffer proc)) (status (process-status proc)) (exit-status (process-exit-status proc))) @@ -89,7 +89,7 @@ the mu find output") (with-current-buffer procbuf (save-excursion (goto-char (point-max)) - (mua/message msg))))))) + (mua/message "%s" msg))))))) (defun mua/hdrs-search-execute (expr buf) "search in the mu database; output the results in buffer BUF" @@ -100,8 +100,7 @@ the mu find output") (add-to-list args (concat "--sortfield=" mua/hdrs-sortfield))) (when mua/hdrs-sort-descending (add-to-list args "--descending")) - (mua/log (concat mua/mu-binary " find " expr - (mapconcat 'identity args " "))) + (mua/log (concat mua/mu-binary " " (mapconcat 'identity args " "))) ;; now, do it! (let ((proc (apply 'start-process "*mua-headers*" buf mua/mu-binary args))) (setq @@ -147,7 +146,7 @@ the mu find output") (make-local-variable 'mua/hdrs-marks-hash) (setq - major-mode 'mua/mua-hdrs-mode mode-name "*mua-headers*" + major-mode 'mua/mua/hdrs-mode mode-name "*mua-headers*" truncate-lines t buffer-read-only t overwrite-mode 'overwrite-mode-binary)) @@ -185,13 +184,22 @@ the mu find output") ;; (defun mua/hdrs-set-path (path) - "map the bol of the current header to a path" - (puthash (line-beginning-position 1) path mua/hdrs-hash)) - -(defun mua/hdrs-get-path () - "get the path for the header at point" + "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))) + (puthash (line-beginning-position 1) uid mua/hdrs-hash) + uid)) + +(defun mua/hdrs-get-uid () + "Get the uid for the message header at point." (gethash (line-beginning-position 1) mua/hdrs-hash)) +(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))) + + (defun mua/hdrs-append-message (msg) "append a message line to the buffer and register the message" (let ((line (mua/hdrs-line msg)) (inhibit-read-only t)) @@ -309,9 +317,9 @@ fitting in WIDTH" (defun mua/hdrs-view () (interactive) - (let ((path (mua/hdrs-get-path))) - (if path - (mua/view path (current-buffer)) + (let ((uid (mua/hdrs-get-uid))) + (if uid + (mua/view uid (current-buffer)) (mua/warn "No message at point")))) (defun mua/hdrs-jump-to-maildir () @@ -365,12 +373,12 @@ if the search process is not already running" ;;; functions for marking -(defun mua/hdrs-add-marked (src &optional dst) +(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 src dst) mua/hdrs-marks-hash) t)))) + (progn (puthash bol (cons uid dst) mua/hdrs-marks-hash) t)))) (defun mua/hdrs-remove-marked () "Remove the message at point from the markings hash" @@ -390,19 +398,19 @@ if the search process is not already running" "Mark the message at point with one of the symbols: move, delete, trash, unmark, unmark-all; the latter two are pseudo-markings." - (let ((target) (src (mua/hdrs-get-path))) - (when src + (let ((uid (mua/hdrs-get-uid))) + (when uid (case action (move - (when (mua/hdrs-add-marked src + (when (mua/hdrs-add-marked uid (mua/ask-maildir "Target maildir: " t)) ;; t->return fullpath (mua/hdrs-set-marker ?m))) (trash - (when (mua/hdrs-add-marked src + (when (mua/hdrs-add-marked uid (concat mua/maildir mua/trash-folder)) (mua/hdrs-set-marker ?d))) (delete - (when (mua/hdrs-add-marked src "/dev/null") + (when (mua/hdrs-add-marked uid "/dev/null") (mua/hdrs-set-marker ?D))) (unmark (when (mua/hdrs-remove-marked) @@ -427,12 +435,10 @@ pseudo-markings." (save-excursion (maphash (lambda(bol v) - (let* ((src (car v)) (target (cdr v)) (inhibit-read-only t) - (newpath (mua/msg-move src target))) - (when newpath + (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... - (mua/hdrs-set-path newpath) (goto-char bol) (mua/hdrs-remove-marked) (put-text-property (line-beginning-position 1) @@ -446,20 +452,23 @@ pseudo-markings." (defun mua/hdrs-reply () "Reply to message at point." (interactive) - (let* ((path (mua/hdrs-get-path)) + (let* ((uid (mua/hdrs-get-uid)) + (path (mua/hdrs-get-path)) (str (when path (mua/mu-view-sexp path))) (msg (and str (mua/msg-from-string str)))) (if msg - (mua/msg-reply msg) + (mua/msg-reply msg uid) (mua/warn "No message at point")))) - -(defun mua/hdrs-forward () + +(defun mua/hdrs-for () "Forward the message at point." (interactive) - (let* ((path (mua/hdrs-get-path)) - (msg (when path (mua/msg-from-path path)))) + (let* ((uid (mua/hdrs-get-uid)) + (path (mua/hdrs-get-path)) + (str (when path (mua/mu-view-sexp path))) + (msg (and str (mua/msg-from-string str)))) (if msg - (mua/msg-forward msg) + (mua/msg-reply msg uid) (mua/warn "No message at point")))) (defun mua/hdrs-compose () diff --git a/toys/mua/mua-msg-file.el b/toys/mua/mua-msg-file.el new file mode 100644 index 00000000..a320502c --- /dev/null +++ b/toys/mua/mua-msg-file.el @@ -0,0 +1,211 @@ +;;; mua-msg.el -- part of mua, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; 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 . + +;;; Commentary: + +;; mua + +;;; Code: + +(eval-when-compile (require 'cl)) + + +(defvar mua/msg-file-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-file-register'. + +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') + +Other places of the code can use the uid to get the *current* +path of the file using `mua/msg-file-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))) + (let ((uid (sha1 path))) + (puthash uid path mua/msg-file-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) + (mua/warn "No message file registered for uid"))) + +(defun mua/msg-file-get-path (uid) + "Get the current path for the message identified by UID." + (gethash uid mua/msg-file-map)) + +(defun mua/msg-file-move-uid (uid targetdir &optional flags) + "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. + +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'. + +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. + +Function returns t the move succeeds, in other cases, it returns +`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) + + +(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")))))) + + +(defun mua/msg-file-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'. +\[1\] http://cr.yp.to/proto/maildir.html." + (when (string-match ",\\(\[A-Z\]*\\)$" path) + (mua/msg-file-string-to-flags (match-string 1 path)))) + + +(defun mua/msg-file-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-file-flags-to-string (flags) + "Remove duplicates and sort the output of `mua/msg-file-flags-to-string-1'" + (concat + (sort + (remove-duplicates + (append (mua/msg-file-flags-to-string-1 flags) nil)) '>))) + +(defun mua/msg-file-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'. + +\[1\]: http://cr.yp.to/proto/maildir.html" + (when flags + (let ((kar + (case (car flags) + ('draft ?D) + ('flagged ?F) + ('passed ?P) + ('replied ?R) + ('seen ?S) + ('trashed ?T)))) + (concat (and kar (string kar)) + (mua/msg-file-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-file-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'. + +\[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-file-string-to-flags-1 (substring str 1)))))) + +(provide 'mua-msg-file) diff --git a/toys/mua/mua-msg.el b/toys/mua/mua-msg.el index 93a30b5f..5c6db734 100644 --- a/toys/mua/mua-msg.el +++ b/toys/mua/mua-msg.el @@ -94,38 +94,9 @@ 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/maildir-from-path (mua/msg-field msg :path)))) + (mua/msg-file-maildir-from-path (mua/msg-field msg :path)))) (t (plist-get msg field)))) - - -(defun mua/msg-move (src targetdir &optional flags) - "Move message at SRC to TARGETDIR using 'mu mv'; 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. - -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/maildir-string-to-flags' and -`mua/maildir-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. - -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 ((fulltarget (mua/mu-mv src targetdir flags))) - (when fulltarget - (mua/mu-remove-async src) - (unless (string= targetdir "/dev/null") - (mua/mu-add-async fulltarget))) - fulltarget)) - + ;; functions for composing new messages (forward, reply and new) @@ -378,10 +349,13 @@ message. (random t) (replace-regexp-in-string "[:/]" "_" (system-name)))) +(defvar mua/msg-reply-uid nil "UID of the message this is a reply to.") +(defvar mua/msg-forward-uid nil "UID of the message being forwarded.") (defun mua/msg-compose (str) "Create a new draft message in the drafts folder with STR as -its contents, and open this message file for editing +its contents, and open this message file for editing. Optionally +specify PARENT-UID, The name of the draft folder is constructed from the concatenation of `mua/maildir' and `mua/drafts-folder' (therefore, these must be set). @@ -399,14 +373,15 @@ using Gnus' `message-mode'." (let ((draftfile (concat mua/maildir "/" mua/drafts-folder "/cur/" (mua/msg-draft-file-name)))) (with-temp-file draftfile (insert str)) - (find-file draftfile) - (rename-buffer mua/msg-draft-name t) + (find-file draftfile) (rename-buffer mua/msg-draft-name t) (message-mode) + (make-local-variable 'mua/msg-forward-uid) + (message-goto-body))) -(defun mua/msg-reply (msg) +(defun mua/msg-reply (msg &optional reply-uid) "Create a draft reply to MSG, and swith to an edit buffer with -the draft message." +the draft message. PARENT-UID refers to the UID of the message wer" (let* ((recipnum (+ (length (mua/msg-field msg :to)) (length (mua/msg-field msg :cc)))) (replyall (when (> recipnum 1) @@ -414,12 +389,14 @@ the draft message." (+ recipnum)))))) ;; exact num depends on some more things (when (mua/msg-compose (mua/msg-create-reply msg replyall)) + (when reply-uid (setq mua/msg-reply-uid reply-uid)) (message-goto-body)))) -(defun mua/msg-forward (msg) +(defun mua/msg-forward (msg &optional forward-uid) "Create a draft forward for MSG, and swith to an edit buffer with the draft message." (when (mua/msg-compose (mua/msg-create-forward msg)) + (when forward-uid (setq mua/msg-forward-uid forward-uid)) (message-goto-to))) (defun mua/msg-compose-new () @@ -430,16 +407,6 @@ draft message." -(defun mua/msg-is-mua-message () - "Check whether the current buffer refers a mua-message based on -the buffer file name; this is used in hooks we install on -message-mode to ensure we only do things with mua-generated -messages (mua is not the only user of `message-mode' after all)" - (let* ((fname (buffer-file-name)) - (match (and fname (string-match mua/msg-file-prefix fname)))) - (and (numberp match) (= 0 match)))) -;; we simply check if file starts with `mu-msg-file-prefix' - (defun mua/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'." @@ -447,33 +414,43 @@ 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/maildir-flags-from-path (buffer-file-name)))) - (sent-msg - (mua/msg-move (buffer-file-name) - (concat mua/maildir mua/sent-folder) ;; mua-sent-folder is only eg. "/sent" - (mua/maildir-flags-to-string newflags)))) - (if sent-msg ;; change our buffer file-name - (set-visited-file-name sent-msg t t) - (mua/warn "Failed to save message to the Sent-folder"))))) + (delq 'draft (mua/msg-file-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))) + (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/warn "Failed to save message to the Sent-folder")))))) -(defun mua/msg-set-replied-flag () - "Find the message we replied to, and set its 'Replied' -flag. This is meant to be called from message mode's +(defun mua/msg-set-replied-or-passed-flag () + "Set the 'replied' flag on messages we replied to, and the +'passed' flag on message we have forwarded. This uses +`mua/msg-reply-uid' and `mua/msg-forward-uid', repectively. + +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'." - (if (mua/msg-is-mua-message) ;; only if we are mua - (let ((msgid (mail-header-parse-addresses - (message-field-value "In-Reply-To"))) - (path (and msgid (mua/mu-run ;; TODO: check we only get one msgid back - "find" (concat "msgid:" msgid) "--exec=echo")))) - (if path - (let ((newflags (cons 'replied (mua/maildir-flags-from-path path)))) - (mua/msg-move path (mua/maildir-from-path path t) newflags)))))) + ;; 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))) + ;; 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)))) - + ;; 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-flag) +(add-hook 'message-sent-hook 'mua/msg-set-replied-or-passed-flag) (provide 'mua-msg) diff --git a/toys/mua/mua-mu.el b/toys/mua/mua-mu.el index c971ff61..a4b0f1a5 100644 --- a/toys/mua/mua-mu.el +++ b/toys/mua/mua-mu.el @@ -44,7 +44,7 @@ parameter is added automatically if `mua/mu-home' is non-nil." (cmdstr (concat mua/mu-binary " " (mapconcat 'identity args " "))) (str (with-output-to-string (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)))))) (when (and (numberp rv) (/= 0 rv)) (mua/log "mua error: %s" (mua/mu-error rv))) @@ -59,36 +59,53 @@ to get it" (match-string 1 (cdr rv)) (mua/warn "Failed to get version string")))) -(defun mua/mu-mv (src target &optional flags) +(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/. 'mu mv' -will calculate the target directory and the exact file name. +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. -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'. +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." - (let ((flagstr - (and flags (mua/maildir-flags-to-string flags)))) - (if (not (file-readable-p src)) - (mua/warn "Cannot move unreadable file %s" src) - (let* ((rv (if flagstr - (mua/mu-run "mv" "--printtarget" - (concat "--flags=" flagstr) src target) - (mua/mu-run "mv" "--printtarget" src target))) +\[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))) - (if (/= 0 code) + ;; 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 at PATH; the format is described in `mua/msg-from-string', and @@ -198,36 +215,38 @@ them." (defconst mu-error-file-stat-failed 77) (defconst mu-error-file-readdir-failed 78) (defconst mu-error-file-invalid-source 79) +(defconst mu-error-file-target-equals-source 80) (defun mua/mu-error (err) "Convert an exit code from mu into a string." - (case err - (mu-error "General error") - (mu-error-in-parameters "Error in parameters") - (mu-error-internal "Internal error") - (mu-error-no-matches "No matches") - (mu-error-xapian "Xapian error") - (mu-error-xapian-query "Error in query") - (mu-error-xapian-dir-not-accessible "Database dir is not accessible") - (mu-error-xapian-not-up-to-date "Database is not up-to-date") - (mu-error-xapian-missing-data "Missing data") - (mu-error-xapian-corruption "Database seems to be corrupted") - (mu-error-xapian-cannot-get-writelock "Database is locked") - (mu-error-gmime "GMime-related error") - (mu-error-contacts "Contacts-related error") - (mu-error-contacts-cannot-retrieve "Failed to retrieve contacts-cache") - (mu-error-file "File error") - (mu-error-file-invalid-name "Invalid file name") - (mu-error-file-cannot-link "Failed to link file") - (mu-error-file-cannot-open "Cannot open file") - (mu-error-file-cannot-read "Cannot read file") - (mu-error-file-cannot-create "Cannot create file") - (mu-error-file-cannot-mkdir "mu-mkdir failed") - (mu-error-file-stat-failed "stat(2) failed") - (mu-error-file-readdir-failed "readdir failed") - (mu-error-file-invalid-source "Invalid source file") - (t "Unknown error"))) + (cond + ((eql err mu-error) "General error") + ((eql err mu-error-in-parameters) "Error in parameters") + ((eql err mu-error-internal) "Internal error") + ((eql err mu-error-no-matches) "No matches") + ((eql err mu-error-xapian) "Xapian error") + ((eql err mu-error-xapian-query) "Error in query") + ((eql err mu-error-xapian-dir-not-accessible) "Database dir not accessible") + ((eql err mu-error-xapian-not-up-to-date) "Database is not up-to-date") + ((eql err mu-error-xapian-missing-data) "Missing data") + ((eql err mu-error-xapian-corruption) "Database seems to be corrupted") + ((eql err mu-error-xapian-cannot-get-writelock) "Database is locked") + ((eql err mu-error-gmime) "GMime-related error") + ((eql err mu-error-contacts) "Contacts-related error") + ((eql err mu-error-contacts-cannot-retrieve) "Failed to retrieve contacts") + ((eql err mu-error-file) "File error") + ((eql err mu-error-file-invalid-name) "Invalid file name") + ((eql err mu-error-file-cannot-link) "Failed to link file") + ((eql err mu-error-file-cannot-open) "Cannot open file") + ((eql err mu-error-file-cannot-read) "Cannot read file") + ((eql err mu-error-file-cannot-create) "Cannot create file") + ((eql err mu-error-file-cannot-mkdir) "mu-mkdir failed") + ((eql err mu-error-file-stat-failed) "stat(2) failed") + ((eql err mu-error-file-readdir-failed) "readdir failed") + ((eql err mu-error-file-invalid-source) "Invalid source file") + ((eql err mu-error-file-target-equals-source) "Source is same as target") + (t (format "Unknown error (%d)" err)))) (provide 'mua-mu) diff --git a/toys/mua/mua-view.el b/toys/mua/mua-view.el index 1b288f5a..4d04a331 100644 --- a/toys/mua/mua-view.el +++ b/toys/mua/mua-view.el @@ -38,53 +38,49 @@ "buffer name for mua/view buffers") (defvar mua/view-headers - '(:from :to :cc :subject :flags :date :maildir :attachments) - "fields to display in the message view") + '(:from :to :cc :subject :flags :date :maildir :path :attachments) + "Fields to display in the message view buffer.") (defvar mua/hdrs-buffer nil - "headers buffer for the view") + "Headers buffer for the view in this buffer.") -(defun mua/view (path headersbuf) - "display message at PATH in a new buffer; note that the action -of viewing a message may cause it to be moved/renamed; this -function returns the resulting name. PARENTBUF refers to the +(defvar mua/view-uid nil + "The UID for the message being viewed in this buffer.") + + +(defun mua/view (uid headersbuf) + "display message identified by UID in a new buffer. Note that +the action of viewing a message may cause it to be moved/renamed; +this function returns the resulting name. PARENTBUF refers to the buffer who invoked this view; this allows us to return there when we quit from this view. Also, if PARENTBUF is a find buffer (ie., has mu-headers-mode as its major mode), this allows various commands (navigation, marking etc.) to be applied to this -buffer." - (let* ((sexp (mua/mu-view-sexp path)) - (msg (and sexp (mua/msg-from-string sexp)))) - (when msg - (switch-to-buffer (get-buffer-create mua/view-buffer-name)) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (mua/view-message msg))) - - (mua/view-mode) - - (setq ;; these are buffer-local - mua/hdrs-buffer headersbuf - mua/parent-buffer headersbuf) - (goto-char (point-min)) - (mua/view-mark-as-read path)))) +buffer. -(defun mua/view-mark-as-read (path) - "Mark the currently viewed 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 ((flags (mua/maildir-flags-from-path path))) - (unless (member 'seen flags) ;; do we need to do something? - (let* ((newflags (delq 'new (cons 'seen flags))) - (target (mua/maildir-from-path path t)) - (newpath (mua/msg-move path target flags))) - ;; now, attempt to update our parent header list... - (if newpath - (mua/with-hdrs-buffer - (if (string= (mua/hdrs-get-path) path) ;; doublecheck we have the right one - (mua/hdrs-set-path newpath) - (mua/warn "Headers buffer not point at correct message"))) - (mua/warn "Failed to mark message as read")))))) +For the reasoning to use UID here instead of just the path, see +`mua/msg-file-map'. +" + (let* ((path (mua/msg-file-get-path uid)) + (sexp (and path (mua/mu-view-sexp path))) + (msg (and sexp (mua/msg-from-string sexp)))) + (if (not msg) + (mua/warn "Cannot view message %S %S" uid path) + (progn + (switch-to-buffer (get-buffer-create mua/view-buffer-name)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (mua/view-message msg))) + + (mua/view-mode) + + (setq ;; these are buffer-local + mua/view-uid uid + mua/hdrs-buffer headersbuf + mua/parent-buffer headersbuf) + + (goto-char (point-min)) + (mua/msg-file-mark-as-read uid))))) (defun mua/view-message (msg) "construct a display string for the message" @@ -155,8 +151,7 @@ buffer." "" "" ;; todo ) - - + (defvar mua/view-mode-map (let ((map (make-sparse-keymap))) @@ -172,10 +167,10 @@ buffer." (define-key map "p" 'mua/view-prev) ;; marking/unmarking - (define-key map "d" '(lambda (mua/view-mark 'trash))) - (define-key map "D" '(lambda (mua/view-mark 'delete))) - (define-key map "m" '(lambda (mua/view-mark 'move))) - (define-key map "u" '(lambda (mua/view-mark 'unmark))) + (define-key map "d" '(lambda() (mua/view-mark 'trash))) + (define-key map "D" '(lambda() (mua/view-mark 'delete))) + (define-key map "m" '(lambda() (mua/view-mark 'move))) + (define-key map "u" '(lambda() (mua/view-mark 'unmark))) (define-key map "x" 'mua/view-marked-execute) map) "Keymap for \"*mua-view*\" buffers.") @@ -189,7 +184,7 @@ buffer." (make-local-variable 'mua/parent-buffer) (make-local-variable 'mua/hdrs-buffer) - (make-local-variable 'mua/path) + (make-local-variable 'mua/view-uid) (setq major-mode 'mua/view-mode mode-name "*mu-view*") (setq truncate-lines t buffer-read-only t)) @@ -208,6 +203,25 @@ etc. persist." (set-buffer oldbuf)) (mua/warn "hdrs buffer is dead")))) + +(defun mua/view-mark (action) + "Set/unset marks for the current message." + (interactive) + (mua/with-hdrs-buffer (mua/hdrs-mark action))) + +(defun mua/view-marked-execute () + "Warn user that marks cannot be executed from here (for his/her +own safety)." + (interactive) + (mua/warn "You cannot execute marks from here")) + + +(defun mua/view-search() + "Start a new search." + (interactive) + (mua/with-hdrs-buffer + (call-interactively 'mua/hdrs-search))) + (defun mua/view-next () "move to the next message; note, this will replace the current buffer" diff --git a/toys/mua/mua.el b/toys/mua/mua.el index d56e26a0..fd64eae1 100644 --- a/toys/mua/mua.el +++ b/toys/mua/mua.el @@ -35,6 +35,8 @@ (require 'mua-msg) (require 'mua-hdrs) (require 'mua-view) +(require 'mua-msg-file) + (defvar mua/mu-home nil "location of the mu homedir, or nil for the default") @@ -82,6 +84,7 @@ quitted, it switches back to its parent buffer") (defface mua/body-face '((t (:foreground "#8cd0d3"))) "") + (setq mua/hdrs-mode-map (let ((map (make-sparse-keymap))) @@ -146,7 +149,6 @@ quitted, it switches back to its parent buffer") (switch-to-buffer buf) (mua/mua-mode))) - (defvar mua/mua-mode-map (let ((map (make-sparse-keymap)))