[elpa] externals/ebdb 886c134 27/33: Add new ebdb-field-mail-folder fieldclass

[Eric Abrahamsen]

branch: externals/ebdb
commit 886c134c5e5c2d16a7ed439cd16efff3aec848e9
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    Add new ebdb-field-mail-folder fieldclass
    
    * ebdb-mua.el (ebdb-mail-folder-list): New variable holding
      correspondences between folder names and mail regexps.
      (ebdb-field-mail-folder): New class holding a mail folder name to
      split to. Also all the basic field methods.
---
 ebdb-mua.el | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 72 insertions(+), 1 deletion(-)

diff --git a/ebdb-mua.el b/ebdb-mua.el
index 8096692..6b37cbd 100644
--- a/ebdb-mua.el
+++ b/ebdb-mua.el
@@ -483,10 +483,81 @@ Currently no other MUAs support this EBDB feature."
   :group 'ebdb-mua
   :type 'string)
 
+(defvar ebdb-mail-folder-list nil
+  "Variable holding lists of mail folder names and mail regexps.
+This is a list of lists: the car of each list element is a string
+folder name, followed by an arbitrary number of strings
+representing regular expressions matching mail addresses.
+
+The value of this variable is usually constructed from instances
+of the `ebdb-field-mail-folder' field.  It's also possible to
+manually add regexps to this list, if for instance the user
+wishes to match mail addresses more broadly.  In this case the
+variable should be set before EBDB is loaded.")
+
+(defclass ebdb-field-mail-folder (ebdb-field-user)
+  ((folder
+    :type string
+    :initarg :folder
+    :custom string
+    :documentation "The folder name to split mail to."))
+  :human-readable "mail folder"
+  :documentation "A field holding the string names of MUA
+  folders.  The MUA packages may perform automatic splitting and
+  filing of messages from records based on the value of this
+  field.")
+
+(cl-defmethod ebdb-string ((f ebdb-field-mail-folder))
+  (slot-value f 'folder))
+
+(cl-defmethod ebdb-read ((c (subclass ebdb-field-mail-folder))
+                        &optional slots obj)
+  (unless (plist-get slots :folder)
+    (setq slots (plist-put slots :folder
+                          (ebdb-read-string
+                           "Folder name: "
+                           (when obj (slot-value obj 'folder))
+                           ebdb-mail-folder-list))))
+  (cl-call-next-method c slots obj))
+
+(cl-defmethod ebdb-parse ((c (subclass ebdb-field-mail-folder))
+                         (str string)
+                         &optional slots)
+  (unless (plist-get slots :folder)
+    (setq slots (plist-put slots :folder str)))
+  (cl-call-next-method c str slots))
+
+(cl-defmethod ebdb-init-field ((f ebdb-field-mail-folder)
+                              &optional record)
+  (when record
+    (let* ((folder (slot-value f 'folder))
+          (mails (mapcar #'regexp-quote (ebdb-record-mail-canon record)))
+          (entry (assoc-string folder
+                               ebdb-mail-folder-list)))
+      (when mails
+       (if entry
+           (setcdr (assoc folder ebdb-mail-folder-list)
+                   (delete-dups (append (cdr entry) mails)))
+         (push (cons folder mails)
+               ebdb-mail-folder-list)))))
+  (cl-call-next-method))
+
+(cl-defmethod ebdb-delete-field ((f ebdb-field-mail-folder)
+                                &optional record unload)
+  (when record
+    (let* ((folder (slot-value f 'folder))
+          (mails (mapcar #'regexp-quote (ebdb-record-mail-canon record)))
+          (entry (assoc-string folder
+                               ebdb-mail-folder-list)))
+      (when (and mails entry)
+       (setcdr (assoc folder ebdb-mail-folder-list)
+               (seq-difference (cdr entry) mails)))))
+  (cl-call-next-method))
+
 (defsubst ebdb-message-header-re (header regexp)
   "Return non-nil if REGEXP matches value of HEADER."
   (let ((val (ebdb-mua-message-header header))
-        (case-fold-search t)) ; RW: Is this what we want?
+        (case-fold-search t))          ; RW: Is this what we want?
     (and val (string-match regexp val))))
 
 (defsubst ebdb-mua-check-header (header-type address-parts &optional invert)