X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-maildir-fcc.el;h=aede753702d01e8d2de62984690d676824cffce2;hp=979428e44e616dddbcbe46d6cdc7eea97e351116;hb=a0f09b4942b7fdb852b45856e3439acac2649035;hpb=177589372092a51073b880d9ae79ea3909563d17

diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el
index 979428e4..aede7537 100644
--- a/emacs/notmuch-maildir-fcc.el
+++ b/emacs/notmuch-maildir-fcc.el
@@ -12,104 +12,208 @@
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 ;; 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)
-;;	     (jkr/maildir-write-buffer-to-maildir destdir t)))
-;;
-;; if you want Fcc'd messages to be marked as new:
-;;
-;;     (setq message-fcc-handler-function
-;;          '(lambda (destdir)
-;;	     (jkr/maildir-write-buffer-to-maildir destdir nil)))
+;; To use this as the fcc handler for message-mode,
+;; customize the notmuch-fcc-dirs variable
+
+(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.
 
-(defvar jkr/maildir-count 0)
+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).
 
-(defun jkr/maildir-host-fixer (hostname)
+You will be prompted to create the directory if it does not exist
+yet when sending a mail."
+
+ :require 'notmuch-fcc-initialization
+ :group 'notmuch
+ :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")))))
+
+(defun notmuch-fcc-initialization ()
+  "If notmuch-fcc-directories is set,
+   hook them into the message-fcc-handler-function"
+    ;; Set up the message-fcc-handler to move mails to the maildir in Fcc
+    ;; The parameter is set to mark messages as "seen"
+    (setq message-fcc-handler-function
+          '(lambda (destdir)
+             (notmuch-maildir-fcc-write-buffer-to-maildir destdir t)))
+    ;; add a hook to actually insert the Fcc header when sending
+    (add-hook 'message-header-setup-hook 'notmuch-fcc-header-setup))
+
+(defun notmuch-fcc-header-setup ()
+  "Add an Fcc header to the current message buffer.
+
+Can be added to `message-send-hook' and will set the Fcc header
+based on the values of `notmuch-fcc-dirs'. An existing Fcc header
+will NOT be removed or replaced."
+
+  (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)
+		(= 1 (length (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
+      (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"))))))))
+ 
+(defun notmuch-maildir-fcc-host-fixer (hostname)
   (replace-regexp-in-string "/\\|:"
 			    '(lambda (s)
-			         (cond ((string-equal s "/") "\\057")
-				       ((string-equal s ":") "\\072")
-				       (t s)))
+                               (cond ((string-equal s "/") "\\057")
+                                     ((string-equal s ":") "\\072")
+                                     (t s)))
 			    hostname
 			    t
 			    t))
 
-(defun jkr/maildir-make-uniq-maildir-id ()
+(defun notmuch-maildir-fcc-make-uniq-maildir-id ()
    (let* ((ct (current-time))
 	  (timeid (+ (* (car ct) 65536) (cadr ct)))
-	  (microseconds (caddr ct))
-	  (hostname (jkr/maildir-host-fixer system-name)))
-     (setq jkr/maildir-count (+ jkr/maildir-count 1))
+	  (microseconds (car (cdr (cdr ct))))
+	  (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
 	     (emacs-pid)
 	     microseconds
-	     jkr/maildir-count
+	     notmuch-maildir-fcc-count
 	     hostname)))
 
-(defun jkr/maildir-dir-is-maildir-p (dir)
+(defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
   (and (file-exists-p (concat dir "/cur/"))
        (file-exists-p (concat dir "/new/"))
        (file-exists-p (concat dir "/tmp/"))))
 
-(defun jkr/maildir-save-buffer-to-tmp (destdir)
+(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 creat 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."
-  (let ((msg-id (jkr/maildir-make-uniq-maildir-id)))
+  (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
     (while (file-exists-p (concat destdir "/tmp/" msg-id))
-      (setq msg-id (jkr/maildir-make-uniq-maildir-id)))
-    (cond ((jkr/maildir-dir-is-maildir-p destdir)
+      (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
+    (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
 	   (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 jkr/maildir-move-tmp-to-new (destdir msg-id)
+(defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
   (add-name-to-file
    (concat destdir "/tmp/" msg-id)
    (concat destdir "/new/" msg-id ":2,")))
 
-(defun jkr/maildir-move-tmp-to-cur (destdir msg-id &optional mark-seen)
+(defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
   (add-name-to-file
    (concat destdir "/tmp/" msg-id)
    (concat destdir "/cur/" msg-id ":2," (when mark-seen "S"))))
 
-(defun jkr/maildir-write-buffer-to-maildir (destdir &optional mark-seen)
+(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."
   (let ((orig-buffer (buffer-name)))
     (with-temp-buffer
-      (insert-buffer orig-buffer)
+      (insert-buffer-substring orig-buffer)
       (catch 'link-error
-	(let ((msg-id (jkr/maildir-save-buffer-to-tmp destdir)))
+	(let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
 	  (when msg-id
 	    (cond (mark-seen
 		   (condition-case err
-		       (jkr/maildir-move-tmp-to-cur destdir msg-id t)
+		       (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
 		     (file-already-exists
 		      (throw 'link-error nil))))
 		  (t
 		   (condition-case err
-		       (jkr/maildir-move-tmp-to-new destdir msg-id)
+		       (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)))
\ No newline at end of file
+      t)))
+
+(notmuch-fcc-initialization)
+(provide 'notmuch-maildir-fcc)
+