[elpa] externals/ebdb 823a7d4 29/33: Use value of ebdb-mua-folder-list in VM splitting

[Eric Abrahamsen]

branch: externals/ebdb
commit 823a7d428f829f6f965540d530fb86e579705555
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    Use value of ebdb-mua-folder-list in VM splitting
    
    * ebdb-vm.el (ebdb/vm-auto-folder): Change function body to use the
      list.
      (ebdb/vm-auto-folder-field): This defcustom no longer exists (it has
      been preserved in the migration process, however).
---
 ebdb-vm.el | 374 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 374 insertions(+)

diff --git a/ebdb-vm.el b/ebdb-vm.el
new file mode 100644
index 0000000..6eab10b
--- /dev/null
+++ b/ebdb-vm.el
@@ -0,0 +1,374 @@
+;;; ebdb-vm.el --- EBDB interface to VM              -*- lexical-binding: t; 
-*-
+
+;; Copyright (C) 2016-2017  Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program 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 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; EBDB's interface to VM.
+
+;;; Code:
+
+(require 'ebdb-mua)
+
+(when t
+  (require 'vm-autoloads)
+  (require 'vm))
+
+(declare-function vm-check-for-killed-summary "ext:vm-misc")
+(declare-function vm-error-if-folder-empty "ext:vm-misc")
+(declare-function vm-get-header-contents "ext:vm-summary")
+(declare-function vm-su-to-names "ext:vm-summary")
+(declare-function vm-su-from "ext:vm-summary")
+(declare-function vm-su-to "ext:vm-summary")
+(declare-function vm-su-full-name "ext:vm-summary")
+(declare-function vm-su-interesting-full-name "ext:vm-summary")
+(declare-function vm-decode-mime-encoded-words-in-string "ext:vm-mime")
+(declare-function vm-follow-summary-cursor "ext:vm-motion")
+(declare-function vm-add-message-labels "ext:vm-undo")
+
+(defvar vm-summary-function-B)
+(defvar vm-summary-uninteresting-senders)
+(defvar vm-summary-uninteresting-senders-arrow)
+(defvar vm-message-pointer)
+(defvar vm-auto-folder-alist)
+(defvar vm-virtual-folder-alist)
+(defvar vm-folder-directory)
+(defvar vm-primary-inbox)
+(defvar vm-mode-map)
+
+(defgroup ebdb-mua-vm nil
+  "VM-specific EBDB customizations"
+  :group 'ebdb-mua)
+(put 'ebdb-mua-vm 'custom-loads '(ebdb-vm))
+
+(defun ebdb/vm-header (header)
+  (save-current-buffer
+    (with-no-warnings
+      ;; This is a defsubst, and will cause compiler warnings if the
+      ;; user doesn't actually have vm installed.
+     (vm-select-folder-buffer))
+    (vm-check-for-killed-summary)
+    (vm-error-if-folder-empty)
+    (let ((enable-local-variables t))
+      (vm-get-header-contents (car vm-message-pointer)
+                             (concat header ":")))))
+
+
+;; By Alastair Burt <address@hidden>
+;; vm 5.40 and newer support a new summary format, %U<letter>, to call
+;; a user-provided function.  Use "%-17.17UB" instead of "%-17.17F" to
+;; have your VM summary buffers display EBDB's idea of the sender's full
+;; name instead of the name (or lack thereof) in the message itself.
+
+;; RW: this is a VM-specific version of `ebdb-mua-summary-unify'
+;; which respects `vm-summary-uninteresting-senders'.
+
+(defun vm-summary-function-B (m)
+  "For VM message M return the EBDB name of the sender.
+Respect `vm-summary-uninteresting-senders'."
+  (if vm-summary-uninteresting-senders
+        (if (let ((case-fold-search t))
+              (string-match vm-summary-uninteresting-senders (vm-su-from m)))
+            (concat vm-summary-uninteresting-senders-arrow
+                    (or (ebdb/vm-alternate-full-name (vm-su-to m))
+                        (vm-decode-mime-encoded-words-in-string
+                         (vm-su-to-names m))))
+          (or (ebdb/vm-alternate-full-name (vm-su-from m))
+              (vm-su-full-name m)))
+    (or (ebdb/vm-alternate-full-name (vm-su-from m))
+        (vm-decode-mime-encoded-words-in-string (vm-su-full-name m)))))
+
+(defun ebdb/vm-alternate-full-name (address)
+  (if address
+      (let* ((data (ebdb-extract-address-components address))
+             (record (car (ebdb-message-search (car data) (cadr data)))))
+        (if record
+            (or (ebdb-record-xfield record 'mail-name)
+                (ebdb-record-name record))))))
+
+
+
+;;;###autoload
+(defcustom ebdb/vm-auto-folder-headers '("From:" "To:" "CC:")
+  "The headers used by `ebdb/vm-auto-folder'.
+The order in this list is the order how matching will be performed."
+  :group 'ebdb-mua-vm
+  :type '(repeat (string :tag "header name")))
+
+;;;###autoload
+(defcustom ebdb/vm-virtual-folder-field 'vm-virtual
+  "The xfield which `ebdb/vm-virtual-folder' searches for."
+  :group 'ebdb-mua-vm
+  :type 'symbol)
+
+;;;###autoload
+(defcustom ebdb/vm-virtual-real-folders nil
+  "Real folders used for defining virtual folders.
+If nil use `vm-primary-inbox'."
+  :group 'ebdb-mua-vm
+  :type '(choice (const :tag "Use vm-primary-inbox" nil)
+                 (repeat (string :tag "Real folder"))))
+
+;;;###autoload
+(defun ebdb/vm-auto-folder ()
+  "Add entries to `vm-auto-folder-alist' for the records in EBDB.
+For each element in `ebdb-mua-folder-list', add an element
+\(MAIL-REGEXP . FOLDER-NAME) to `vm-auto-folder-alist'.
+The element gets added to the sublists of `vm-auto-folder-alist'
+specified in `ebdb/vm-auto-folder-headers'.
+MAIL-REGEXP matches the mail addresses of the EBDB record.
+
+To use this, add a `ebdb-field-mail-folder' instance to records.
+The value of the field becomes FOLDER-NAME.
+
+Add this function to `ebdb-before-save-hook' and your .vm."
+  (interactive)
+  (let (folder-list folder-name mail-regexp)
+    ;; Add (MAIL-REGEXP . FOLDER-NAME) pair to this sublist of 
`vm-auto-folder-alist'
+    (dolist (header ebdb/vm-auto-folder-headers)
+      ;; create the folder-list in `vm-auto-folder-alist' if it does not exist
+      (unless (setq folder-list (assoc header vm-auto-folder-alist))
+        (push (list header) vm-auto-folder-alist)
+        (setq folder-list (assoc header vm-auto-folder-alist)))
+      (dolist (elt ebdb-mail-folder-list)
+        (setq folder-name (car elt)
+              ;; Mails are already quoted regexps.
+              mail-regexp (mapconcat #'identity (cdr elt) "\\|"))
+        (unless (or (string= "" mail-regexp)
+                    (assoc mail-regexp folder-list))
+          ;; Convert relative into absolute file names using
+          ;; `vm-folder-directory'.
+          (unless (file-name-absolute-p folder-name)
+            (setq folder-name (abbreviate-file-name
+                               (expand-file-name folder-name
+                                                 vm-folder-directory))))
+          ;; nconc modifies the list in place
+          (nconc folder-list (list (cons mail-regexp folder-name))))))))
+
+;;;###autoload
+(defun ebdb/vm-virtual-folder ()
+  "Create `vm-virtual-folder-alist' according to the records in EBDB.
+For each record that has a `vm-virtual' xfield, add or modify the
+corresponding VIRTUAL-FOLDER-NAME element of `vm-virtual-folder-alist'.
+
+  (VIRTUAL-FOLDER-NAME ((FOLDER-NAME ...)
+                        (author-or-recipient MAIL-REGEXP)))
+
+VIRTUAL-FOLDER-NAME is the first element of the `vm-virtual' xfield.
+FOLDER-NAME ... are either the remaining elements of the `vm-virtual' xfield,
+or `ebdb/vm-virtual-real-folders' or `vm-primary-inbox'.
+MAIL-REGEXP matches the mail addresses of the EBDB record.
+The `vm-virtual' xfield is defined via `ebdb/vm-virtual-folder-field'.
+
+Add this function to `ebdb-before-save-hook' and your .vm."
+  (interactive)
+  (let (real-folders mail-regexp folder val tmp)
+    (dolist (record (ebdb-records))
+      (when (setq val (ebdb-record-xfield-split
+                       record ebdb/vm-virtual-folder-field))
+        (setq mail-regexp (regexp-opt (ebdb-record-mail record)))
+        (unless (string= "" mail-regexp)
+          (setq folder (car val)
+                real-folders (mapcar
+                              (lambda (f)
+                                (if (file-name-absolute-p f) f
+                                  (abbreviate-file-name
+                                   (expand-file-name f vm-folder-directory))))
+                              (or (cdr val) ebdb/vm-virtual-real-folders
+                                  (list vm-primary-inbox)))
+                ;; Either extend the definition of an already defined
+                ;; virtual folder or define a new virtual folder
+                tmp (or (assoc folder vm-virtual-folder-alist)
+                        (car (push (list folder) vm-virtual-folder-alist)))
+                tmp (or (assoc real-folders (cdr tmp))
+                        (car (setcdr tmp (cons (list real-folders)
+                                               (cdr tmp)))))
+                tmp (or (assoc 'author-or-recipient (cdr tmp))
+                        (car (setcdr tmp (cons (list 'author-or-recipient)
+                                               (cdr tmp))))))
+          (cond ((not (cdr tmp))
+                 (setcdr tmp (list mail-regexp)))
+                ((not (string-match (regexp-quote mail-regexp)
+                                    (cadr tmp)))
+                 (setcdr tmp (list (concat (cadr tmp) "\\|" 
mail-regexp))))))))))
+
+
+;; RW: Adding custom labels to VM messages allows one to create,
+;; for example, virtual folders.  The following code creates
+;; the required labels in a rather simplistic way, checking merely
+;; whether the sender's EBDB record uses a certain mail alias.
+;; (Note that `ebdb/vm-virtual-folder' can achieve the same goal,
+;; yet this requires a second xfield that must be kept up-to-date, too.)
+;; To make auto labels yet more useful, the code could allow more
+;; sophisticated schemes, too.  Are there real-world applications
+;; for this?
+
+;;; Howard Melman, contributed Jun 16 2000
+(defcustom ebdb/vm-auto-add-label-list nil
+  "List used by `ebdb/vm-auto-add-label' to automatically label VM messages.
+Its elements may be strings used both as the xfield value to check for
+and as the label to apply to the message.
+If an element is a cons pair (VALUE . LABEL), VALUE is the xfield value
+to search for and LABEL is the label to apply."
+  :group 'ebdb-mua-vm
+  :type 'list)
+
+(defcustom ebdb/vm-auto-add-label-field ebdb-mail-alias-field
+  "Xfields used by `ebdb/vm-auto-add-label' to automatically label messages.
+This is either a single EBDB xfield or a list of xfields that
+`ebdb/vm-auto-add-label' uses to check for labels to apply to a message.
+Defaults to `ebdb-mail-alias-field' which defaults to `mail-alias'."
+  :group 'ebdb-mua-vm
+  :type '(choice symbol list))
+
+(defun ebdb/vm-auto-add-label (record)
+  "Automatically add labels to VM messages.
+Add this to `ebdb-notice-record-hook' to check the messages noticed by EBDB.
+If the value of `ebdb/vm-auto-add-label-field' in the sender's EBDB record
+matches a value in `ebdb/vm-auto-add-label-list' then a VM label will be added
+to the message.  Such VM labels can be used, e.g., to mark messages via
+`vm-mark-matching-messages' or to define virtual folders via
+`vm-create-virtual-folder'
+
+Typically `ebdb/vm-auto-add-label-field' and `ebdb/vm-auto-add-label-list'
+refer to mail aliases FOO used with multiple records.  This adds a label FOO
+to all incoming messages matching FOO.  Then VM can create a virtual folder
+for these messages.  The concept of combining multiple recipients of an
+outgoing message in one mail alias thus gets extended to incoming messages
+from different senders."
+  ;; This could go into `vm-arrived-message-hook' to check messages only once.
+  (if (eq major-mode 'vm-mode)
+      (let* ((xvalues
+              ;; Inspect the relevant fields of RECORD
+              (append
+               (mapcar (lambda (field)
+                         (ebdb-record-xfield-split record field))
+                       (cond ((listp ebdb/vm-auto-add-label-field)
+                              ebdb/vm-auto-add-label-field)
+                             ((symbolp ebdb/vm-auto-add-label-field)
+                              (list ebdb/vm-auto-add-label-field))
+                             (t (error "Bad value for 
ebdb/vm-auto-add-label-field"))))))
+             ;; Collect the relevant labels from `ebdb/vm-auto-add-label-list'
+             (labels
+              (delq nil
+                    (mapcar (lambda (l)
+                              (cond ((stringp l)
+                                     (if (member l xvalues)
+                                         l))
+                                    ((and (consp l)
+                                          (stringp (car l))
+                                          (stringp (cdr l)))
+                                     (if (member (car l) xvalues)
+                                         (cdr l)))
+                                    (t
+                                     (error "Malformed 
ebdb/vm-auto-add-label-list"))))
+                            ebdb/vm-auto-add-label-list))))
+        (if labels
+            (vm-add-message-labels
+             (mapconcat 'identity labels " ") 1)))))
+
+
+
+;;; If vm has set up its various modes using `define-derived-mode' we
+;;; should be able to collapse all these various methods into one that
+;;; checks `derived-mode-p'.  Check how to do that with &context.
+
+
+(cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-mode))
+  "Produce a EBDB buffer name associated with VM mode."
+  (format "*%s-VM*" ebdb-buffer-name))
+
+(cl-defmethod ebdb-make-buffer-name (&context (major-mode 
vm-presentation-mode))
+  "Produce a EBDB buffer name associated with VM mode."
+  (format "*%s-VM*" ebdb-buffer-name))
+
+(cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-summary-mode))
+  "Produce a EBDB buffer name associated with VM mode."
+  (format "*%s-VM*" ebdb-buffer-name))
+
+(cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-virtual-mode))
+  "Produce a EBDB buffer name associated with VM mode."
+  (format "*%s-VM*" ebdb-buffer-name))
+
+(cl-defmethod ebdb-mua-message-header ((header string)
+                                  &context (major-mode vm-mode))
+  (ebdb/vm-header header))
+
+(cl-defmethod ebdb-mua-message-header ((header string)
+                                  &context (major-mode vm-virtual-mode))
+  (ebdb/vm-header header))
+
+(cl-defmethod ebdb-mua-message-header ((header string)
+                                  &context (major-mode vm-summary-mode))
+  (ebdb/vm-header header))
+
+(cl-defmethod ebdb-mua-message-header ((header string)
+                                  &context (major-mode vm-presentation-mode))
+  (ebdb/vm-header header))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-mode))
+  (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-virtual-mode))
+  (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-summary-mode))
+  (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode 
vm-presentation-mode))
+  (vm-follow-summary-cursor))
+
+;;;###autoload
+(defun ebdb-insinuate-vm ()
+  "Hook EBDB into VM."
+  (define-key vm-mode-map ";" ebdb-mua-keymap)
+  (define-key vm-mode-map "/" 'ebdb)
+  ;; `mail-mode-map' is the parent of `vm-mail-mode-map'.
+  ;; So the following is also done by `ebdb-insinuate-mail'.
+  (if (and ebdb-complete-mail (boundp 'vm-mail-mode-map))
+      (define-key vm-mail-mode-map "\M-\t" 'ebdb-complete-mail))
+
+  ;; Set up user field for use in `vm-summary-format'
+  ;; (1) Big solution: use whole name
+  (if ebdb-mua-summary-unify-format-letter
+      (fset (intern (concat "vm-summary-function-"
+                            ebdb-mua-summary-unify-format-letter))
+            (lambda (m) (ebdb-mua-summary-unify
+                         ;; VM does not give us the original From header.
+                         ;; So we have to work backwards.
+                         (let ((name (vm-decode-mime-encoded-words-in-string
+                                      (vm-su-interesting-full-name m)))
+                               (mail (vm-su-from m)))
+                           (if (string= name mail) mail
+                             (format "\"%s\" <%s>" name mail)))))))
+
+  ;; (2) Small solution: a mark for messages whos sender is in EBDB.
+  (if ebdb-mua-summary-mark-format-letter
+      (fset (intern (concat "vm-summary-function-"
+                            ebdb-mua-summary-mark-format-letter))
+            ;; VM does not give us the original From header.
+            ;; So we assume that the mail address is sufficient to identify
+            ;; the EBDB record of the sender.
+            (lambda (m) (ebdb-mua-summary-mark (vm-su-from m))))))
+
+(add-hook 'vm-mode-hook #'ebdb-insinuate-vm)
+
+(add-hook 'vm-select-message-hook #'ebdb-mua-auto-update)
+
+(provide 'ebdb-vm)
+;;; ebdb-vm.el ends here