path: root/lisp/bbdb-sc.el
diff options
Diffstat (limited to 'lisp/bbdb-sc.el')
1 files changed, 209 insertions, 0 deletions
diff --git a/lisp/bbdb-sc.el b/lisp/bbdb-sc.el
new file mode 100644
index 0000000..6fe04ae
--- /dev/null
+++ b/lisp/bbdb-sc.el
@@ -0,0 +1,209 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; This file is an addition to the Insidious Big Brother Database
+;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
+;;; <>.
+;;; The Insidious Big Brother Database 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 1, or (at your
+;;; option) any later version.
+;;; BBDB 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 GNU Emacs; see the file COPYING. If not, write to
+;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; This file was written by Martin Sjolin <>
+;;; based the original code by Tom Tromey <>.
+;;; Thanks to Richard Stanton <> for ideas
+;;; for improvements and to Michael D. Carney <>
+;;; for testing and feedback.
+;;; This file adds the ability to define attributions for Supercite in
+;;; a BBDB, enables you to retrieve your standard attribution from
+;;; BBDB. If the from header in the mail to which you are replying
+;;; only contains the e-mail address, the personal name is lookup in
+;;; BBDB. You need Supercite to make this code work. The attribution
+;;; os is stored under the key `attribution' (unless you've changed
+;;; bbdb/sc-attribution-field).
+;;; To use enable this code you will have to the "sc-consult" to your
+;;; sc-preferred-attribution-list. This file sets variable if it is not
+;;; set and isues an warning message if "sc-consult" is not included.
+;;; (setq sc-preferred-attribution-list
+;;; '("sc-lastchoice" "x-attribution" "sc-consult"
+;;; "initials" "firstname" "lastname"))
+;;; We also set the sc-attrib-selection-list below if is not bound, if
+;;; you have your own special sc-attrib-selection-list, please add
+;;; an expression as below:
+;;; (setq sc-attrib-selection-list
+;;; '(("sc-from-address" ((".*" . (bbdb/sc-consult-attr
+;;; (sc-mail-field "sc-from-address")))))))
+;;; And finally we set the sc-mail-glom-frame to enable the
+;;; fetching of the name of person when there is only an e-mail
+;;; address in the original mail:
+;;; (setq sc-mail-glom-frame
+;;; '((begin (setq sc-mail-headers-start (point)))
+;;; ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
+;;; ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
+;;; ("^$" (progn (bbdb/sc-default)
+;;; (list 'abort '(step . 0))))
+;;; ("^[ \t]+" (sc-mail-append-field))
+;;; (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
+;;; (end (setq sc-mail-headers-end (point)))))
+;;; packages
+(require 'bbdb)
+(require 'supercite)
+;;; User variable(s)
+(defcustom bbdb/sc-replace-attr-p t
+ "t if you like to create a new BBDB entry when
+entering a non-default attribution, 'ask if the user
+should be asked before creation and NIL if we never create a new entry."
+ :group 'bbdb-utilities-supercite
+ :type '(choice (const "Create a new BBDB entry" t)
+ (const "Confirm new record creation" ask)
+ (const "Don't create a new entry" nil)))
+(defcustom bbdb/sc-attribution-field 'attribution
+ "The BBDB field used for Supercite attribution information."
+ :group 'bbdb-utilities-supercite
+ :type '(symbol :tag "Field name"))
+;;; Code starts
+(defcustom bbdb/sc-last-attribution ""
+ "Default attribution return by the SuperCite citation engine,
+used to compare against citation selected by the user."
+ :group 'bbdb-utilities-supercite
+ :type '(string :tag "Default citation" ""))
+(defun bbdb/sc-consult-attr (from)
+ "Extract citing information from BBDB using sc-consult where
+FROM is user e-mail address to look for in BBDB."
+ ;; if logged in user sent this, use recipients.
+ (let ((from (if (or (null from)
+ (string-match (bbdb-user-mail-names) from))
+ (car (cdr (mail-extract-address-components
+ (or (sc-mail-field "to") from))))
+ from)))
+ (if from
+ (let ((record (bbdb-search-simple nil from)))
+ (and record
+ (bbdb-record-getprop record bbdb/sc-attribution-field))))))
+(defun bbdb/sc-set-attr ()
+ "Add attribute to BBDB."
+ (let ((from (sc-mail-field "from"))
+ (address (sc-mail-field "sc-from-address"))
+ (attr (sc-mail-field "sc-attribution")))
+ (if (and from attr bbdb/sc-replace-attr-p
+ (not (string-equal attr bbdb/sc-last-attribution))
+ (not (string-match (bbdb-user-mail-names) address)))
+ (let* ((bbdb-notice-hook nil)
+ ;; avoid noticing any headers in the reply message
+ (record (bbdb-annotate-message-sender
+ from t
+ (bbdb-invoke-hook-for-value
+ bbdb/mail-auto-create-p) t)))
+ (if record
+ (let ((old (bbdb-record-getprop record 'attribution)))
+ ;; ignore if we have an value and same value
+ (if (and (not (and old (string-equal old attr)))
+ (or (not (eq bbdb/sc-replace-attr-p 'ask))
+ (y-or-n-p (concat "Change attribution " attr))))
+ (progn (bbdb-record-putprop record
+ bbdb/sc-attribution-field attr)
+ (bbdb-change-record record nil)))))))))
+;;; this is marked as autoload since someone managed to trip up Gnus
+;;; with it. I'm not clear this needs fixing, as you should be calling
+;;; bbdb-insinuate-sc if you're using supercite/BBDB. However.
+(defun bbdb/sc-default ()
+ "If the current \"from\" field in `sc-mail-info' alist
+contains only an e-mail address, lookup e-mail address in
+BBDB, and prepend a new \"from\" field to `sc-mail-info'."
+ (let* ((from (sc-mail-field "from"))
+ (pair (and from (mail-extract-address-components from))))
+ (if (and pair (not (car pair)))
+ (let* ((record (bbdb-search-simple nil (car (cdr pair))))
+ (name (and record (bbdb-record-name record))))
+ (if name
+ (setq sc-mail-info
+ (cons (cons "from"
+ (format "%s (%s)" (car (cdr pair)) name))
+ sc-mail-info)))))))
+;;; setup the default setting of the variables
+(defun bbdb/sc-setup-variables ()
+ "Set up the various Supercite variables for the BBDB.
+`sc-preferred-attribution-list', `sc-attrib-selection-list', and
+`sc-mail-glom-frame' are set, but only if they have not previously
+been defined. It is strongly suggested that you not call this
+function directly, but that you use this function (specifically the
+settings contained herein) as an example. In other words, set these
+variables yourself, either in your Emacs configuration file or using
+ ;; check for sc-consult in sc-preferred-attribution-list
+ (if (boundp 'sc-preferred-attribution-list)
+ (or (member '"sc-consult" sc-preferred-attribution-list)
+ (bbdb-warn (concat "\"sc-consult\" not included in "
+ "sc-preferred-attribution-list. Attributions cannot"
+ "be gathered from the BBDB without \"sc-consult\""
+ "in sc-preferred-attribution-list")))
+ (defvar sc-preferred-attribution-list
+ '("sc-lastchoice" "x-attribution" "sc-consult"
+ "initials" "firstname" "lastname")))
+ ;; check sc-attrib-selection-list
+ (defvar sc-attrib-selection-list
+ '(("sc-from-address"
+ ((".*" . (bbdb/sc-consult-attr
+ (sc-mail-field "sc-from-address")))))))
+ ;; set sc-mail-glom-frame
+ (defvar sc-mail-glom-frame
+ '((begin (setq sc-mail-headers-start (point)))
+ ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
+ ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
+ ("^$" (progn (bbdb/sc-default)
+ (list 'abort '(step . 0))))
+ ("^[ \t]+" (sc-mail-append-field))
+ (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
+ (end (setq sc-mail-headers-end (point))))))
+;; insert our hooks - call me from your Emacs initialization file
+(defvar attribution) ;; dammit, supercite!
+(defun bbdb-insinuate-sc ()
+ "Call this function to hook BBDB into Supercite."
+ (add-hook 'sc-post-hook 'bbdb/sc-set-attr)
+ (add-hook 'sc-attribs-postselect-hook
+ (function (lambda()
+ (setq bbdb/sc-last-attribution
+ (if sc-downcase-p
+ (downcase attribution) attribution))))))
+(provide 'bbdb-sc)
+;;; end of bbdb-sc.el