X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-maildir-fcc.el;h=ae8f5140f34d2b2283bc9507b0744c6f30640700;hp=5de03cc23416e6f5370da66b24264e2e3156542d;hb=HEAD;hpb=2ca941163da06aed564dab1990fb333fd7457ec2 diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el index 5de03cc2..51020788 100644 --- a/emacs/notmuch-maildir-fcc.el +++ b/emacs/notmuch-maildir-fcc.el @@ -1,4 +1,4 @@ -;;; notmuch-maildir-fcc.el --- inserting using a fcc handler +;;; notmuch-maildir-fcc.el --- inserting using a fcc handler -*- lexical-binding: t -*- ;; Copyright © Jesse Rosenthal ;; @@ -21,7 +21,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'seq) (require 'message) @@ -41,16 +41,17 @@ Three types of values are permitted: - a string: the value of `notmuch-fcc-dirs' is the Fcc header to be used. -- a list: the folder is chosen based on the From address of the - current message using a list of regular expressions and - corresponding folders: +- an alist: the folder is chosen based on the From address of + the current message according to an alist mapping regular + expressions to folders or nil: ((\"Sebastian@SSpaeth.de\" . \"privat\") (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\") (\".*\" . \"defaultinbox\")) - If none of the regular expressions match the From address, no - Fcc header will be added. + If none of the regular expressions match the From address, or + if the cdr of the matching entry is nil, then no Fcc header + will be added. If `notmuch-maildir-use-notmuch-insert' is set (the default) then the header should be of the form \"folder +tag1 -tag2\" where @@ -74,7 +75,8 @@ directory if it does not exist yet when sending a mail." (const :tag "No FCC header" nil) (string :tag "A single folder") (repeat :tag "A folder based on the From header" - (cons regexp (string :tag "Folder")))) + (cons regexp (choice (const :tag "No FCC header" nil) + (string :tag "Folder"))))) :require 'notmuch-fcc-initialization :group 'notmuch-send) @@ -90,10 +92,8 @@ directory if it does not exist yet when sending a mail." (defun notmuch-fcc-header-setup () "Add an Fcc header to the current message buffer. -Sets the Fcc header based on the values of `notmuch-fcc-dirs'. - -Originally intended to be use a hook function, but now called directly -by notmuch-mua-mail." +If the Fcc header is already set, then keep it as-is. +Otherwise set it according to `notmuch-fcc-dirs'." (let ((subdir (cond ((or (not notmuch-fcc-dirs) @@ -107,16 +107,14 @@ by notmuch-mua-mail." ;; Old style - no longer works. (error "Invalid `notmuch-fcc-dirs' setting (old style)")) ((listp notmuch-fcc-dirs) - (let* ((from (message-field-value "From")) - (match - (catch 'first-match - (dolist (re-folder notmuch-fcc-dirs) - (when (string-match-p (car re-folder) from) - (throw 'first-match re-folder)))))) - (if match - (cdr match) - (message "No Fcc header added.") - nil))) + (if-let ((match (seq-some (let ((from (message-field-value "From"))) + (pcase-lambda (`(,regexp . ,folder)) + (and (string-match-p regexp from) + (cons t folder)))) + notmuch-fcc-dirs))) + (cdr match) + (message "No Fcc header added.") + nil)) (t (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)"))))) (when subdir @@ -128,9 +126,9 @@ by notmuch-mua-mail." ;; Notmuch insert does not accept absolute paths, so check the user ;; really want this header inserted. (when (or (not (= (elt subdir 0) ?/)) - (y-or-n-p - (format "Fcc header %s is an absolute path and notmuch insert is requested. -Insert header anyway? " subdir))) + (y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir + "and notmuch insert is requested." + "Insert header anyway? "))) (message-add-header (concat "Fcc: " subdir)))) (defun notmuch-maildir-add-file-style-fcc-header (subdir) @@ -151,15 +149,20 @@ Insert header anyway? " subdir))) (buf (current-buffer)) (mml-externalize-attachments message-fcc-externalize-attachments)) (with-current-buffer (get-buffer-create " *message temp*") + (message-clone-locals buf) ;; for message-encoded-mail-cache (erase-buffer) (insert-buffer-substring buf) ,@body))) (defun notmuch-maildir-setup-message-for-saving () - "Setup message for saving. Should be called on a temporary copy. + "Setup message for saving. +This should be called on a temporary copy. This is taken from the function message-do-fcc." - (message-encode-message-body) + (if (not message-encoded-mail-cache) + (message-encode-message-body) + (erase-buffer) + (insert message-encoded-mail-cache)) (save-restriction (message-narrow-to-headers) (mail-encode-encoded-word-buffer)) @@ -173,23 +176,21 @@ This is taken from the function message-do-fcc." "Process Fcc headers in the current buffer. This is a rearranged version of message mode's message-do-fcc." - (let (list file) + (let (files file) (save-excursion (save-restriction (message-narrow-to-headers) (setq file (message-fetch-field "fcc" t))) (when file (with-temporary-notmuch-message-buffer + (notmuch-maildir-setup-message-for-saving) (save-restriction (message-narrow-to-headers) (while (setq file (message-fetch-field "fcc" t)) - (push file list) + (push file files) (message-remove-header "fcc" nil t))) - (notmuch-maildir-setup-message-for-saving) ;; Process FCC operations. - (while list - (setq file (pop list)) - (notmuch-fcc-handler file)) + (mapc #'notmuch-fcc-handler files) (kill-buffer (current-buffer))))))) (defun notmuch-fcc-handler (fcc-header) @@ -201,7 +202,8 @@ normal fcc." (message "Doing Fcc...") (if notmuch-maildir-use-notmuch-insert (notmuch-maildir-fcc-with-notmuch-insert fcc-header) - (notmuch-maildir-fcc-file-fcc fcc-header))) + (notmuch-maildir-fcc-file-fcc fcc-header)) + (message "Doing Fcc...done")) ;;; Functions for saving a message using notmuch insert. @@ -212,11 +214,11 @@ This inserts the current buffer as a message into the notmuch database in folder FOLDER. If CREATE is non-nil it will supply the --create-folder flag to create the folder if necessary. TAGS should be a list of tag changes to apply to the inserted message." - (let* ((args (append (and create (list "--create-folder")) - (list (concat "--folder=" folder)) - tags))) - (apply 'notmuch-call-notmuch-process - :stdin-string (buffer-string) "insert" args))) + (apply 'notmuch-call-notmuch-process + :stdin-string (buffer-string) "insert" + (append (and create (list "--create-folder")) + (list (concat "--folder=" folder)) + tags))) (defun notmuch-maildir-fcc-with-notmuch-insert (fcc-header &optional create) "Store message with notmuch insert. @@ -230,9 +232,8 @@ quoting each space with an immediately preceding backslash or surrounding the entire folder name in double quotes. If CREATE is non-nil then create the folder if necessary." - (let* ((args (split-string-and-unquote fcc-header)) - (folder (car args)) - (tags (cdr args))) + (pcase-let ((`(,folder . ,tags) + (split-string-and-unquote fcc-header))) (condition-case nil (notmuch-maildir-notmuch-insert-current-buffer folder create tags) ;; Since there are many reasons notmuch insert could fail, e.g., @@ -265,7 +266,7 @@ If CREATE is non-nil then create the folder if necessary." (let* ((ftime (float-time)) (microseconds (mod (* 1000000 ftime) 1000000)) (hostname (notmuch-maildir-fcc-host-fixer (system-name)))) - (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1)) + (cl-incf notmuch-maildir-fcc-count) (format "%d.%d_%d_%d.%s" ftime (emacs-pid) @@ -298,9 +299,7 @@ if successful, nil if not." (write-file (concat destdir "/tmp/" msg-id)) msg-id) (t - (error (format "Can't write to %s. Not a maildir." - destdir)) - nil)))) + (error "Can't write to %s. Not a maildir." destdir))))) (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id) (add-name-to-file @@ -315,8 +314,8 @@ if successful, nil if not." (defun notmuch-maildir-fcc-file-fcc (fcc-header) "Write the message to the file specified by FCC-HEADER. -It offers the user a chance to correct the header, or filesystem, -if needed." +If that fails, then offer the user a chance to correct the header +or filesystem." (if (notmuch-maildir-fcc-dir-is-maildir-p fcc-header) (notmuch-maildir-fcc-write-buffer-to-maildir fcc-header t) ;; The fcc-header is not a valid maildir see if the user wants to @@ -336,25 +335,23 @@ if needed." (read-from-minibuffer "Fcc header: " fcc-header))))))) (defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen) - "Writes the current buffer to maildir destdir. If mark-seen is -non-nil, it will write it to cur/, and mark it as read. It should -return t if successful, and nil otherwise." + "Write the current buffer to maildir destdir. + +If mark-seen is non-nil, then write it to \"cur/\", and mark it +as read, otherwise write it to \"new/\". Return t if successful, +and nil otherwise." (let ((orig-buffer (buffer-name))) (with-temp-buffer (insert-buffer-substring orig-buffer) (catch 'link-error (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir))) (when msg-id - (cond (mark-seen - (condition-case err - (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t) - (file-already-exists - (throw 'link-error nil)))) - (t - (condition-case err - (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id) - (file-already-exists - (throw 'link-error nil)))))) + (condition-case nil + (if mark-seen + (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t) + (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)) + (file-already-exists + (throw 'link-error nil)))) (delete-file (concat destdir "/tmp/" msg-id)))) t)))