[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/gnorb 5876834 088/449: BBDB posting styles, first draft
From: |
Stefan Monnier |
Subject: |
[elpa] externals/gnorb 5876834 088/449: BBDB posting styles, first draft |
Date: |
Fri, 27 Nov 2020 23:15:14 -0500 (EST) |
branch: externals/gnorb
commit 5876834937adc3ffbe39a7e1bb21a4c93d6b7105
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>
BBDB posting styles, first draft
lisp/gnorb-bbdb.el: New functions `gnorb-bbdb-mail' and
`gnorb-bbdb-configure-posting-styles', and user option
`gnorb-bbdb-posting-styles'.
Works "just like" gnus-posting-styles, except you write rules matching
fields of the BBDB contact you're composing a message to.
---
lisp/gnorb-bbdb.el | 206 +++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 206 insertions(+)
diff --git a/lisp/gnorb-bbdb.el b/lisp/gnorb-bbdb.el
index 11c3ccf..370a4ad 100644
--- a/lisp/gnorb-bbdb.el
+++ b/lisp/gnorb-bbdb.el
@@ -40,6 +40,212 @@
(unless (assoc gnorb-bbdb-org-tag-field bbdb-separator-alist)
(push `(,gnorb-bbdb-org-tag-field ":" ":") bbdb-separator-alist))
+(defcustom gnorb-bbdb-posting-styles nil
+ "An alist of styles to use when composing messages to the BBDB
+ record(s) under point. This is entirely analogous to
+ `gnus-posting-styles', it simply works by examining record
+ fields rather than group names.
+
+When composing a message to multiple contacts (using the \"*\"
+prefix), the records will be scanned in order, with the record
+initially under point (if any) set aside for last. That means
+that, in the case of conflicting styles, the record under point
+will override the others.
+
+In order not to be too intrusive, this option has no effect on
+the usual `bbdb-mail' command. Instead, the wrapper command
+`gnorb-bbdb-mail' is provided, which consults this option and
+then hands off to `bbdb-compose-mail'. If you'd always like to
+use `gnorb-bbdb-mail', you can simply bind it to \"m\" in the
+`bbdb-mode-map'.
+
+The value of the option should be a list of sexps, each one
+matching a single field. The first element should match a field
+name: one of the built-in fields like lastname, or an xfield.
+Field names should be given as symbols.
+
+The second element is a regexp used to match against the value of
+the field (non-string field values will be cast to strings, if
+possible). It can also be a cons of two strings, the first of
+which matches the field label, the second the field value.
+
+Alternately, the first element can be the name of a custom
+function that is called with the record as its only argument, and
+returns either t or nil. In this case, the second element of the
+list is disregarded.
+
+All following elements should be field setters for the message to
+be composed, just as in `gnus-posting-styles'.
+
+An example value might look like:"
+ :group 'gnorb-bbdb)
+
+(defun gnorb-bbdb-mail (records &optional subject n verbose)
+ "Acts just like `bbdb-mail', except runs RECORDS through
+ `gnorb-bbdb-posting-styles', allowing customization of message
+ styles for certain records. From the `bbdb-mail' docstring:
+
+Compose a mail message to RECORDS (optional: using SUBJECT).
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+By default, the first mail addresses of RECORDS are used.
+If prefix N is a number, use Nth mail address of RECORDS (starting from 1).
+If prefix N is C-u (t noninteractively) use all mail addresses of RECORDS.
+If VERBOSE is non-nil (as in interactive calls) be verbose."
+ ;; see the function `gnus-configure-posting-styles' for tips on how
+ ;; to actually do this.
+ (interactive (list (bbdb-do-records) nil
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t))
+ (setq records (bbdb-record-list records))
+ (if (not records)
+ (user-error "No records displayed")
+ (let ((head (bbdb-current-record))
+ (to (bbdb-mail-address records n nil verbose))
+ (message-mode-hook (copy-sequence message-mode-hook)))
+ (setq records (remove head records))
+ (when gnorb-bbdb-posting-styles
+ (add-hook 'message-mode-hook
+ `(lambda ()
+ (gnorb-bbdb-configure-posting-styles ,records)
+ (gnorb-bbdb-configure-posting-styles (list ,head)))))
+ (bbdb-compose-mail to subject))))
+
+(defun gnorb-bbdb-configure-posting-styles (recs)
+ ;; My most magnificent work of copy pasta!
+ (dolist (r recs)
+ (let (field val label recval element filep
+ element v results name address)
+ (dolist (style gnorb-bbdb-posting-styles)
+ (setq field (pop style)
+ val (pop style))
+ (when (consp val)
+ (setq label (pop val)
+ val (pop val)))
+ (unless (fboundp field)
+ (setq rec-val (bbdb-record-field r field)))
+ (when (cond
+ ((eq field 'address)
+ (dolist (a rec-val)
+ (unless (and label
+ (not (string-match label (car f))))
+ (string-match val (bbdb-format-address-default f)))))
+ ((eq field 'phone)
+ (dolist (p rec-val)
+ (unless (and label
+ (not (string-match label (car f))))
+ (string-match val (bbdb-phone-string p)))))
+ ((consp rec-val)
+ (dolist (f rec-val)
+ (string-match var f)))
+ ((fboundp field)
+ (funcall field rec))
+ ((stringp rec-val)
+ (string-match val rec-val)))
+ (dolist (attribute style)
+ (setq element (pop attribute)
+ filep nil)
+ (setq value
+ (cond
+ ((eq (car attribute) :file)
+ (setq filep t)
+ (cadr attribute))
+ ((eq (car attribute) :value)
+ (cadr attribute))
+ (t
+ (car attribute))))
+ ;; We get the value.
+ (setq v
+ (cond
+ ((stringp value)
+ (if (and (gnus-string-match-p "\\\\[&[:digit:]]" value)
+ (match-beginning 1))
+ (gnus-match-substitute-replacement value nil nil group)
+ value))
+ ((or (symbolp value)
+ (functionp value))
+ (cond ((functionp value)
+ (funcall value))
+ ((boundp value)
+ (symbol-value value))))
+ ((listp value)
+ (eval value))))
+ ;; Post-processing for the signature posting-style:
+ (and (eq element 'signature) filep
+ message-signature-directory
+ ;; don't actually use the signature directory
+ ;; if message-signature-file contains a path.
+ (not (file-name-directory v))
+ (setq v (nnheader-concat message-signature-directory v)))
+ ;; Get the contents of file elems.
+ (when (and filep v)
+ (setq v (with-temp-buffer
+ (insert-file-contents v)
+ (buffer-substring
+ (point-min)
+ (progn
+ (goto-char (point-max))
+ (if (zerop (skip-chars-backward "\n"))
+ (point)
+ (1+ (point))))))))
+ (setq results (delq (assoc element results) results))
+ (push (cons element v) results))))
+ (setq name (assq 'name results)
+ address (assq 'address results))
+ (setq results (delq name (delq address results)))
+ (gnus-make-local-hook 'message-setup-hook)
+ (setq results (sort results (lambda (x y)
+ (string-lessp (car x) (car y)))))
+ (dolist (result results)
+ (add-hook 'message-setup-hook
+ (cond
+ ((eq 'eval (car result))
+ 'ignore)
+ ((eq 'body (car result))
+ `(lambda ()
+ (save-excursion
+ (message-goto-body)
+ (insert ,(cdr result)))))
+ ((eq 'signature (car result))
+ (set (make-local-variable 'message-signature) nil)
+ (set (make-local-variable 'message-signature-file) nil)
+ (if (not (cdr result))
+ 'ignore
+ `(lambda ()
+ (save-excursion
+ (let ((message-signature ,(cdr result)))
+ (when message-signature
+ (message-insert-signature)))))))
+ (t
+ (let ((header
+ (if (symbolp (car result))
+ (capitalize (symbol-name (car result)))
+ (car result))))
+ `(lambda ()
+ (save-excursion
+ (message-remove-header ,header)
+ (let ((value ,(cdr result)))
+ (when value
+ (message-goto-eoh)
+ (insert ,header ": " value)
+ (unless (bolp)
+ (insert "\n")))))))))
+ t 'local))
+ (when (or name address)
+ (add-hook 'message-setup-hook
+ `(lambda ()
+ (set (make-local-variable 'user-mail-address)
+ ,(or (cdr address) user-mail-address))
+ (let ((user-full-name ,(or (cdr name) (user-full-name)))
+ (user-mail-address
+ ,(or (cdr address) user-mail-address)))
+ (save-excursion
+ (message-remove-header "From")
+ (message-goto-eoh)
+ (insert "From: " (message-make-from) "\n"))))
+ t 'local)))))
+
(defun gnorb-bbdb-tag-agenda (records)
"Open an Org agenda tags view from the BBDB buffer, using the
value of the record's org-tags field. This shows only TODOs by
- [elpa] externals/gnorb b5d3731 046/449: What on earth was that still doing there?, (continued)
- [elpa] externals/gnorb b5d3731 046/449: What on earth was that still doing there?, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 0db3991 051/449: Move mail search backend stuff to gnorb-gnus, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 9fff78a 057/449: Changing email TODO handling to operate by org ID, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 30afb67 068/449: Various docstring and comment edits., Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 7052248 069/449: New generalized function gnorb-trigger-todo-action, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 70b5534 070/449: Make TODOs from outgoing messages, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb bda9cfe 079/449: More complete docs: How to use Gnorb for email tracking, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb c0e03b2 081/449: Actually add the sent message ID to the TODO, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 96afd01 084/449: Skip Note items when scanning state changes, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 0c247d4 085/449: Remember to put :group and :type on defcustoms, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 5876834 088/449: BBDB posting styles, first draft,
Stefan Monnier <=
- [elpa] externals/gnorb 69c3312 089/449: Refactoring of gnorb-org link scanning, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 6a66e21 093/449: Got the arguments to org-get-heading backwards, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb a64f652 094/449: Have gnorb-org-popup-bbdb scan the whole subtree, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 68f1473 096/449: More robust check for an open nngnorb server, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 9fbd947 105/449: Collect attachments on incoming trigger action, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb adba76d 117/449: Rewrite of link-scanning routine, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 522f653 121/449: Declare some function, possibly unneccesary, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 1a40d11 130/449: Checking wishlist items off, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 372986c 132/449: Fix call of key-description, Stefan Monnier, 2020/11/27
- [elpa] externals/gnorb 9ecb0e2 136/449: Use BBDB posting styles in mail composition, Stefan Monnier, 2020/11/27