X-Git-Url: https://git.notmuchmail.org/git?a=blobdiff_plain;ds=sidebyside;f=emacs%2Fnotmuch-maildir-fcc.el;h=cda51e7f3d07072b0c9ecdb7e0669bac34155745;hb=cf59859b2028223cdf1741a2a09eadb666ccb726;hp=84f4187aa334c932e237d53c6aba204dce2ce222;hpb=c000c4b394132536eed5cfadbeec58f9c7fb5056;p=notmuch

diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el
index 84f4187a..cda51e7f 100644
--- a/emacs/notmuch-maildir-fcc.el
+++ b/emacs/notmuch-maildir-fcc.el
@@ -1,3 +1,5 @@
+;;; notmuch-maildir-fcc.el ---
+
 ;; This file 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 2, or (at your
@@ -13,50 +15,187 @@
 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 ;; Boston, MA 02110-1301, USA.
 
-;; Commentary:
-;;
-;; This is the beginning of a solution for storing sent mail in a
-;; maildir in emacs message mode, presented because some people might
-;; find it useful. It is *not* fully tested, it *may* overwrite files,
-;; and any directories you point this at may no longer be there
-;; afterwards. Use at your own risk.
-;;
-;; To use this as the fcc handler for message-mode, put
-;; one of the following in your init file:
-;;
-;; if you want Fcc'd messages to be marked as read:
-;;
-;;     (setq message-fcc-handler-function
-;;          '(lambda (destdir)
-;;	     (notmuch-maildir-fcc-write-buffer-to-maildir destdir t)))
-;;
-;; if you want Fcc'd messages to be marked as new:
-;;
-;;     (setq message-fcc-handler-function
-;;          '(lambda (destdir)
-;;	     (notmuch-maildir-fcc-write-buffer-to-maildir destdir nil)))
+;;; Commentary:
+
+;; To use this as the fcc handler for message-mode,
+;; customize the notmuch-fcc-dirs variable
+
+;;; Code:
 
+(eval-when-compile (require 'cl))
+(require 'message)
+
+(require 'notmuch-lib)
 
 (defvar notmuch-maildir-fcc-count 0)
 
+(defcustom notmuch-fcc-dirs "sent"
+ "Determines the maildir directory in which to save outgoing mail.
+
+Three types of values are permitted:
+
+- nil: no Fcc header is added,
+
+- a string: the value of `notmuch-fcc-dirs' is the name of the
+  folder to use,
+
+- a list: the folder is chosen based on the From address of the
+  current message using a list of regular expressions and
+  corresponding folders:
+
+     ((\"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.
+
+In all cases, a relative FCC directory will be understood to
+specify a directory within the notmuch mail store, (as set by
+the database.path option in the notmuch configuration file).
+
+You will be prompted to create the directory if it does not exist
+yet when sending a mail."
+
+ :type '(choice
+	 (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"))))
+ :require 'notmuch-fcc-initialization
+ :group 'notmuch-send)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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.
+
+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"
+
+  (let ((subdir
+	 (cond
+	  ((or (not notmuch-fcc-dirs)
+	       (message-field-value "Fcc"))
+	   ;; Nothing set or an existing header.
+	   nil)
+
+	  ((stringp notmuch-fcc-dirs)
+	   notmuch-fcc-dirs)
+
+	  ((and (listp notmuch-fcc-dirs)
+		(stringp (car notmuch-fcc-dirs)))
+	   ;; 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)))
+
+	  (t
+	   (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
+
+    (when subdir
+      (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.
+
+(defmacro with-temporary-notmuch-message-buffer (&rest body)
+  "Set-up a temporary copy of the current message-mode buffer."
+  `(let ((case-fold-search t)
+	 (buf (current-buffer))
+	 (mml-externalize-attachments message-fcc-externalize-attachments))
+     (with-current-buffer (get-buffer-create " *message temp*")
+       (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.
+
+This is taken from the function message-do-fcc."
+  (message-encode-message-body)
+  (save-restriction
+    (message-narrow-to-headers)
+    (let ((mail-parse-charset message-default-charset))
+      (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 )))
+
+(defun notmuch-maildir-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)
+    (save-excursion
+      (save-restriction
+	(message-narrow-to-headers)
+	(setq file (message-fetch-field "fcc" t)))
+      (when file
+	(with-temporary-notmuch-message-buffer
+	 (save-restriction
+	   (message-narrow-to-headers)
+	   (while (setq file (message-fetch-field "fcc" t))
+	     (push file list)
+	     (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))
+	 (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)
-			         (cond ((string-equal s "/") "\\057")
-				       ((string-equal s ":") "\\072")
-				       (t s)))
+			    (lambda (s)
+			      (cond ((string-equal s "/") "\\057")
+				    ((string-equal s ":") "\\072")
+				    (t s)))
 			    hostname
 			    t
 			    t))
 
 (defun notmuch-maildir-fcc-make-uniq-maildir-id ()
-   (let* ((ct (current-time))
-	  (timeid (+ (* (car ct) 65536) (cadr ct)))
-	  (microseconds (car (cdr (cdr ct))))
+   (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))
      (format "%d.%d_%d_%d.%s"
-	     timeid
+	     ftime
 	     (emacs-pid)
 	     microseconds
 	     notmuch-maildir-fcc-count
@@ -67,6 +206,16 @@
        (file-exists-p (concat dir "/new/"))
        (file-exists-p (concat dir "/tmp/"))))
 
+(defun notmuch-maildir-fcc-create-maildir (path)
+  (cond ((or (not (file-exists-p path)) (file-directory-p path))
+	 (make-directory (concat path "/cur/") t)
+	 (make-directory (concat path "/new/") t)
+	 (make-directory (concat path "/tmp/") t))
+	((file-regular-p path)
+	 (error "%s is a file. Can't create maildir." path))
+	(t
+	 (error "I don't know how to create a maildir here"))))
+
 (defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
   "Returns the msg id of the message written to the temp directory
 if successful, nil if not."
@@ -77,8 +226,8 @@ if successful, nil if not."
 	   (write-file (concat destdir "/tmp/" msg-id))
 	   msg-id)
 	  (t
-	   (message (format "Can't write to %s. Not a maildir."
-		     destdir))
+	   (error (format "Can't write to %s. Not a maildir."
+			  destdir))
 	   nil))))
 
 (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
@@ -91,6 +240,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
@@ -115,3 +287,5 @@ return t if successful, and nil otherwise."
       t)))
 
 (provide 'notmuch-maildir-fcc)
+
+;;; notmuch-maildir-fcc.el ends here