X-Git-Url: http://rtime.felk.cvut.cz/gitweb/notmuch.git/blobdiff_plain/0cf457b73b4b666314d1a09ac3e31bd0fa2346a6..967bbc0792d8d36cdf1e110d8b9eb0aa26d8a646:/emacs/notmuch-maildir-fcc.el diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el index bbf61320..6fed11f2 100644 --- a/emacs/notmuch-maildir-fcc.el +++ b/emacs/notmuch-maildir-fcc.el @@ -65,11 +65,9 @@ yet when sending a mail." :require 'notmuch-fcc-initialization :group 'notmuch-send) -(defun notmuch-fcc-handler (destdir) - "Write buffer to `destdir', marking it as sent -Intended to be dynamically bound to `message-fcc-handler-function'" - (notmuch-maildir-fcc-write-buffer-to-maildir destdir t)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions which set up the fcc header in the message buffer. (defun notmuch-fcc-header-setup () "Add an Fcc header to the current message buffer. @@ -110,27 +108,89 @@ by notmuch-mua-mail" (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)"))))) (when subdir - (message-add-header - (concat "Fcc: " - (file-truename - ;; If the resulting directory is not an absolute path, - ;; prepend the standard notmuch database path. - (if (= (elt subdir 0) ?/) - subdir - (concat (notmuch-database-path) "/" subdir))))) - - ;; finally test if fcc points to a valid maildir - (let ((fcc-header (message-field-value "Fcc"))) - (unless (notmuch-maildir-fcc-dir-is-maildir-p fcc-header) - (cond ((not (file-writable-p fcc-header)) - (error (format "No permission to create %s, which does not exist" - fcc-header))) - ((y-or-n-p (format "%s is not a maildir. Create it? " - fcc-header)) - (notmuch-maildir-fcc-create-maildir fcc-header)) - (t - (error "Message not sent")))))))) - + (notmuch-maildir-add-file-style-fcc-header subdir)))) + +(defun notmuch-maildir-add-file-style-fcc-header (subdir) + (message-add-header + (concat "Fcc: " + (file-truename + ;; If the resulting directory is not an absolute path, + ;; prepend the standard notmuch database path. + (if (= (elt subdir 0) ?/) + subdir + (concat (notmuch-database-path) "/" subdir)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions for saving a message either using notmuch insert or file +;; fcc. First functions common to the two cases. + +(defun notmuch-maildir-message-do-fcc () + "Process Fcc headers in the current buffer. + +This is a direct copy from message-mode's message-do-fcc." + (let ((case-fold-search t) + (buf (current-buffer)) + list file + (mml-externalize-attachments message-fcc-externalize-attachments)) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (setq file (message-fetch-field "fcc" t))) + (when file + (set-buffer (get-buffer-create " *message temp*")) + (erase-buffer) + (insert-buffer-substring buf) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (while (setq file (message-fetch-field "fcc" t)) + (push file list) + (message-remove-header "fcc" nil t)) + (let ((mail-parse-charset message-default-charset) + (rfc2047-header-encoding-alist + (cons '("Newsgroups" . default) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) + ;; Process FCC operations. + (while list + (setq file (pop list)) + (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) + ;; Pipe the article to the program in question. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil shell-command-switch + (match-string 1 file)) + ;; Save the article. + (setq file (expand-file-name file)) + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (if (and message-fcc-handler-function + (not (eq message-fcc-handler-function 'rmail-output))) + (funcall message-fcc-handler-function file) + ;; FIXME this option, rmail-output (also used if + ;; message-fcc-handler-function is nil) is not + ;; documented anywhere AFAICS. It should work in Emacs + ;; 23; I suspect it does not work in Emacs 22. + ;; FIXME I don't see the need for the two different cases here. + ;; mail-use-rfc822 makes no difference (in Emacs 23),and + ;; the third argument just controls \"Wrote file\" message. + (if (and (file-readable-p file) (mail-file-babyl-p file)) + (rmail-output file 1 nil t) + (let ((mail-use-rfc822 t)) + (rmail-output file 1 t t)))))) + (kill-buffer (current-buffer)))))) + +(defun notmuch-fcc-handler (fcc-header) + "Store message with file fcc." + (notmuch-maildir-fcc-file-fcc fcc-header)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions for saving a message using file fcc. + (defun notmuch-maildir-fcc-host-fixer (hostname) (replace-regexp-in-string "/\\|:" (lambda (s) @@ -192,6 +252,29 @@ if successful, nil if not." (concat destdir "/tmp/" msg-id) (concat destdir "/cur/" msg-id ":2," (when mark-seen "S")))) +(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 (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 + ;; fix it in some way. + (let* ((prompt (format "Fcc %s is not a maildir: (r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " + fcc-header)) + (response (read-char-choice prompt '(?r ?c ?i ?e)))) + (case response + (?r (notmuch-maildir-fcc-file-fcc fcc-header)) + (?c (if (file-writable-p fcc-header) + (notmuch-maildir-fcc-create-maildir fcc-header) + (message "No permission to create %s." fcc-header) + (sit-for 2)) + (notmuch-maildir-fcc-file-fcc fcc-header)) + (?i 't) + (?e (notmuch-maildir-fcc-file-fcc + (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