cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-sc.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is an addition to the Insidious Big Brother Database
   4 ;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
   5 ;;; <jwz@netscape.com>.
   6 ;;;
   7 ;;; The Insidious Big Brother Database is free software; you can redistribute
   8 ;;; it and/or modify it under the terms of the GNU General Public License as
   9 ;;; published by the Free Software Foundation; either version 1, or (at your
  10 ;;; option) any later version.
  11 ;;;
  12 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  13 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15 ;;; details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21
  22 ;;; This file was written by Martin Sjolin <marsj@ida.liu.se>
  23 ;;; based the original code by Tom Tromey <tromey@busco.lanl.gov>.
  24 ;;;
  25 ;;; Thanks to Richard Stanton <stanton@haas.berkeley.edu> for ideas
  26 ;;; for improvements and to Michael D. Carney  <carney@ltx-tr.com>
  27 ;;; for testing and feedback.
  28
  29 ;;; $Id: bbdb-sc.el,v 1.8 2007-02-23 20:24:08 fenk Exp $
  30
  31 ;;; This file adds the ability to define attributions for Supercite in
  32 ;;; a BBDB, enables you to retrieve your standard attribution from
  33 ;;; BBDB. If the from header in the mail to which you are replying
  34 ;;; only contains the e-mail address, the personal name is lookup in
  35 ;;; BBDB. You need Supercite to make this code work. The attribution
  36 ;;; os is stored under the key `attribution' (unless you've changed
  37 ;;; bbdb/sc-attribution-field).
  38
  39 ;;; To use enable this code you will have to the "sc-consult" to your
  40 ;;; sc-preferred-attribution-list. This file sets variable if it is not
  41 ;;; set and isues an warning message if "sc-consult" is not included.
  42 ;;;
  43 ;;;   (setq sc-preferred-attribution-list
  44 ;;;     '("sc-lastchoice" "x-attribution" "sc-consult"
  45 ;;;       "initials" "firstname" "lastname"))
  46 ;;;
  47 ;;;
  48 ;;; We also set the sc-attrib-selection-list below if is not bound, if
  49 ;;; you have your own special sc-attrib-selection-list, please add
  50 ;;; an expression as below:
  51 ;;;
  52 ;;;   (setq sc-attrib-selection-list
  53 ;;;        '(("sc-from-address" ((".*" . (bbdb/sc-consult-attr
  54 ;;;                    (sc-mail-field "sc-from-address")))))))
  55 ;;;
  56 ;;; And finally we set the sc-mail-glom-frame to enable the
  57 ;;; fetching of the name of person when there is only an e-mail
  58 ;;; address in the original mail:
  59 ;;;
  60 ;;;  (setq sc-mail-glom-frame
  61 ;;;    '((begin                        (setq sc-mail-headers-start (point)))
  62 ;;;      ("^x-attribution:[ \t]+.*$"   (sc-mail-fetch-field t) nil t)
  63 ;;;      ("^\\S +:.*$"                 (sc-mail-fetch-field) nil t)
  64 ;;;      ("^$"                         (progn (bbdb/sc-default)
  65 ;;;                      (list 'abort '(step . 0))))
  66 ;;;      ("^[ \t]+"                    (sc-mail-append-field))
  67 ;;;      (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
  68 ;;;      (end                          (setq sc-mail-headers-end (point)))))
  69 ;;;
  70 ;;;
  71
  72 ;;;
  73 ;;;
  74
  75 ;;; packages
  76 (require 'bbdb)
  77 (require 'supercite)
  78
  79 ;;; User variable(s)
  80 (defcustom bbdb/sc-replace-attr-p t
  81  "t if you like to create a new BBDB entry when
  82 entering a non-default attribution, 'ask if the user
  83 should be asked before creation and NIL if we never create a new entry."
  84  :group 'bbdb-utilities-supercite
  85  :type '(choice (const "Create a new BBDB entry" t)
  86         (const "Confirm new record creation" ask)
  87         (const "Don't create a new entry" nil)))
  88
  89 (defcustom bbdb/sc-attribution-field 'attribution
  90   "The BBDB field used for Supercite attribution information."
  91   :group 'bbdb-utilities-supercite
  92   :type '(symbol :tag "Field name"))
  93
  94 ;;; Code starts
  95 (defcustom bbdb/sc-last-attribution ""
  96  "Default attribution return by the SuperCite citation engine,
  97 used to compare against citation selected by the user."
  98  :group 'bbdb-utilities-supercite
  99  :type '(string :tag "Default citation" ""))
 100
 101 (defun bbdb/sc-consult-attr (from)
 102   "Extract citing information from BBDB using sc-consult where
 103 FROM is user e-mail address to look for in BBDB."
 104   ;; if logged in user sent this, use recipients.
 105   (let ((from (if (or (null from)
 106                       (string-match (bbdb-user-mail-names) from))
 107                   (car (cdr (mail-extract-address-components
 108                              (or (sc-mail-field "to") from))))
 109                 from)))
 110     (if from
 111         (let ((record (bbdb-search-simple nil from)))
 112           (and record
 113                (bbdb-record-getprop record bbdb/sc-attribution-field))))))
 114
 115 (defun bbdb/sc-set-attr ()
 116   "Add attribute to BBDB."
 117   (let ((from (sc-mail-field "from"))
 118     (address (sc-mail-field "sc-from-address"))
 119     (attr (sc-mail-field "sc-attribution")))
 120     (if (and from attr bbdb/sc-replace-attr-p
 121         (not (string-equal attr bbdb/sc-last-attribution))
 122         (not (string-match (bbdb-user-mail-names) address)))
 123     (let* ((bbdb-notice-hook nil)
 124            ;; avoid noticing any headers in the reply message
 125            (record (bbdb-annotate-message-sender
 126                from t
 127                (bbdb-invoke-hook-for-value
 128             bbdb/mail-auto-create-p) t)))
 129       (if record
 130           (let ((old (bbdb-record-getprop record 'attribution)))
 131         ;; ignore if we have an value and same value
 132         (if (and (not (and old (string-equal old attr)))
 133              (or (not (eq bbdb/sc-replace-attr-p 'ask))
 134                  (y-or-n-p (concat "Change attribution " attr))))
 135             (progn (bbdb-record-putprop record
 136                         bbdb/sc-attribution-field attr)
 137                (bbdb-change-record record nil)))))))))
 138
 139 ;;; this is marked as autoload since someone managed to trip up Gnus
 140 ;;; with it. I'm not clear this needs fixing, as you should be calling
 141 ;;; bbdb-insinuate-sc if you're using supercite/BBDB. However.
 142 ;;;###autoload
 143 (defun bbdb/sc-default ()
 144   "If the current \"from\" field in `sc-mail-info' alist
 145 contains only an e-mail address, lookup e-mail address in
 146 BBDB, and prepend a new \"from\" field to `sc-mail-info'."
 147   (let* ((from   (sc-mail-field "from"))
 148      (pair   (and from (mail-extract-address-components from))))
 149     (if (and pair (not (car pair)))
 150     (let* ((record (bbdb-search-simple nil (car (cdr pair))))
 151            (name   (and record (bbdb-record-name record))))
 152       (if name
 153           (setq sc-mail-info
 154             (cons (cons "from"
 155                 (format "%s (%s)" (car (cdr pair)) name))
 156               sc-mail-info)))))))
 157
 158 ;;; setup the default setting of the variables
 159 (defun bbdb/sc-setup-variables ()
 160   "Set up the various Supercite variables for the BBDB.
 161 `sc-preferred-attribution-list', `sc-attrib-selection-list', and
 162 `sc-mail-glom-frame' are set, but only if they have not previously
 163 been defined.  It is strongly suggested that you not call this
 164 function directly, but that you use this function (specifically the
 165 settings contained herein) as an example.  In other words, set these
 166 variables yourself, either in your Emacs configuration file or using
 167 Custom."
 168
 169   ;; check for sc-consult in sc-preferred-attribution-list
 170   (if (boundp 'sc-preferred-attribution-list)
 171       (or (member '"sc-consult" sc-preferred-attribution-list)
 172       (bbdb-warn (concat "\"sc-consult\" not included in "
 173                  "sc-preferred-attribution-list.  Attributions cannot"
 174                  "be gathered from the BBDB without \"sc-consult\""
 175                  "in sc-preferred-attribution-list")))
 176     (defvar sc-preferred-attribution-list
 177       '("sc-lastchoice" "x-attribution" "sc-consult"
 178         "initials" "firstname" "lastname")))
 179
 180   ;; check sc-attrib-selection-list
 181   (defvar sc-attrib-selection-list
 182     '(("sc-from-address"
 183        ((".*" . (bbdb/sc-consult-attr
 184          (sc-mail-field "sc-from-address")))))))
 185
 186   ;; set sc-mail-glom-frame
 187   (defvar sc-mail-glom-frame
 188     '((begin                        (setq sc-mail-headers-start (point)))
 189       ("^x-attribution:[ \t]+.*$"   (sc-mail-fetch-field t) nil t)
 190       ("^\\S +:.*$"                 (sc-mail-fetch-field) nil t)
 191       ("^$"                         (progn (bbdb/sc-default)
 192                        (list 'abort '(step . 0))))
 193       ("^[ \t]+"                    (sc-mail-append-field))
 194       (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
 195       (end                          (setq sc-mail-headers-end (point))))))
 196
 197 ;; insert our hooks - call me from your Emacs initialization file
 198 (defvar attribution) ;; dammit, supercite!
 199 ;;;###autoload
 200 (defun bbdb-insinuate-sc ()
 201   "Call this function to hook BBDB into Supercite."
 202
 203   (add-hook 'sc-post-hook 'bbdb/sc-set-attr)
 204   (add-hook 'sc-attribs-postselect-hook
 205          (function (lambda()
 206                  (setq bbdb/sc-last-attribution
 207                    (if sc-downcase-p
 208                        (downcase attribution) attribution))))))
 209
 210 (provide 'bbdb-sc)
 211 ;;; end of bbdb-sc.el