emacs: make modifications to message Fcc vars buffer-local

[notmuch] / emacs / notmuch-maildir-fcc.el

diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el
index 979428e44e616dddbcbe46d6cdc7eea97e351116..c2f2f4cb127db3d9f2c786b8c8236cffe558193e 100644 (file)
--- a/emacs/notmuch-maildir-fcc.el
+++ b/emacs/notmuch-maildir-fcc.el
@@ -12,104 +12,202 @@
 ;; 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.
 ;; 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.

 
 

+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).

 
 

-(defvar jkr/maildir-count 0)
+You will be prompted to create the directory if it does not exist
+yet when sending a mail."

 
 

-(defun jkr/maildir-host-fixer (hostname)
+ :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)
+
+(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))
+
+(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
+      (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 "/\\|:"
   (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))
 
                            hostname
                            t
                            t))
 

-(defun jkr/maildir-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))
+(defun notmuch-maildir-fcc-make-uniq-maildir-id ()
+   (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"
      (format "%d.%d_%d_%d.%s"

-            timeid
+            ftime

             (emacs-pid)
             microseconds
             (emacs-pid)
             microseconds

-            jkr/maildir-count
+            notmuch-maildir-fcc-count

             hostname)))
 
             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/"))))
 
   (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 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."
   "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))
     (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
           (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))))
 
           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,")))
 
   (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"))))
 
   (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
   "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
       (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
          (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
                     (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))))
                     (file-already-exists
                      (throw 'link-error nil))))))
          (delete-file (concat destdir "/tmp/" msg-id))))

-      t)))
\ No newline at end of file
+      t)))
+
+(provide 'notmuch-maildir-fcc)
+