Here at Honeywell, the email addresses of those who labor under
Microsoft Mail are not the normal "Firstname Lastname" format one
would expect, but rather "Lastname, Firstname." After adding a whole
lot of AKA fields, I got bored with that and made the following hack
to bbdb-annotate-message-sender. As you can see I just redefined this
function using eval-after-load, because I couldn't figure out how to
reconcile my stuff with the distributed code.
There are two primary reasons for my inability to reconcile the stuff,
which I had thought would be possible using advice:
1. the piece of code that ought to be advised is bbdb-search-simple,
which is defined using defsubst, instead of defun;
2. despite many attempts, I just can't manage to grok the emacs lisp
advice facility.
Hope some of you find this useful.
R
(eval-after-load "bbdb-rmail"
(defun bbdb-annotate-message-sender (from &optional loudly create-p
prompt-to-create-p)
"Fills the record corresponding to the sender with as much info as possible.
A record may be created by this; a record or nil is returned.
If bbdb-readonly-p is true, then a record will never be created.
If CREATE-P is true, then a record may be created, otherwise it won't.
If PROMPT-TO-CREATE-P is true, then the user will be asked for confirmation
before the record is created, otherwise it is created without confirmation
\(assuming that CREATE-P is true\). "
(let* ((data (mail-extract-address-components from))
(name (car data))
(net (car (cdr data))))
(if (equal name net) (setq name nil))
(bbdb-debug
(if (equal name "") (error "mail-extr returned \"\" as name"))
(if (equal net "") (error "mail-extr returned \"\" as net")))
(if (and net bbdb-canonicalize-net-hook)
(setq net (bbdb-canonicalize-address net)))
(let ((change-p nil)
;;this is the stuff I changed, because the MS mail
;;systems that send stuff to me often have peoples'
;;names last-name-first.[goldman:1994.12.3.0:14.14.CST]
(record (or (bbdb-search-simple name net)
(let ((name-break (string-match "," name)))
(when name-break
(let ((new-name (concat
;;stuff after last name
(substring name
(1+ (match-end 0)))
" "
(substring name 0
name-break))))
(bbdb-search-simple new-name net))))))
(created-p nil)
(fname name)
(lname nil)
old-name
bogon-mode)
(and record (setq old-name (bbdb-record-name record)))
;; This is to prevent having losers like "John <blat@foop>" match
;; against existing records like "Someone Else <john>".
;;
;; The solution implemented here is to never create or show records
;; corresponding to a person who has a real-name which is the same
;; as the network-address of someone in the db already. This is not
;; a good solution.
(let (down-name old-net)
(if (and record name
(not (equal (setq down-name (downcase name))
(and old-name (downcase old-name)))))
(progn
(setq old-net (bbdb-record-net record))
(while old-net
(if (equal down-name (downcase (car old-net)))
(progn
(setq bogon-mode t
old-net nil)
(message
"Ignoring bogon %s's name \"%s\" to avoid name-clash with
\"%s\""
net name old-name)
(sit-for 2))
(setq old-net (cdr old-net)))))))
(if (or record
bbdb-readonly-p
(not create-p)
(not (or name net))
bogon-mode)
;; no further action required
nil
;; otherwise, the db is writable, and we may create a record.
(setq record (if (or (null prompt-to-create-p)
(bbdb-y-or-n-p (format "%s is not in the db; rectify? "
name)))
(make-vector bbdb-record-length nil))
created-p (not (null record)))
(if record
(bbdb-record-set-cache record (make-vector bbdb-cache-length nil)))
(if created-p (bbdb-invoke-hook 'bbdb-create-hook record)))
(if (or bogon-mode (null record))
nil
(bbdb-debug (if (bbdb-record-deleted-p record)
(error "nasty nasty deleted record nasty.")))
(if (and name
(not (equal (and name (downcase name))
(and old-name (downcase old-name))))
(or (null bbdb-use-alternate-names)
(not (bbdb-check-alternate-name name record)))
(let ((fullname (bbdb-divide-name name))
tmp)
(setq fname (car fullname)
lname (nth 1 fullname))
(not (and (equal (downcase fname)
(and (setq tmp (bbdb-record-firstname record))
(downcase tmp)))
(equal (downcase lname)
(and (setq tmp (bbdb-record-lastname record))
(downcase tmp)))))))
;; have a message-name, not the same as old name.
(cond (bbdb-readonly-p nil)
;;(created-p nil)
((and bbdb-quiet-about-name-mismatches old-name)
(message "name mismatch: \"%s\" changed to \"%s\""
(bbdb-record-name record) name)
(sit-for 1))
((or created-p
(if (null old-name)
(bbdb-y-or-n-p (format "Assign name \"%s\" to address
\"%s\"? "
name (car (bbdb-record-net
record))))
(bbdb-y-or-n-p (format "Change name \"%s\" to \"%s\"? "
old-name name))))
(setq change-p 'sort)
(and old-name bbdb-use-alternate-names
(if (bbdb-y-or-n-p (format "Keep name \"%s\" as an AKA? "
old-name))
(bbdb-record-set-aka record
(cons old-name (bbdb-record-aka
record)))
(bbdb-remhash (downcase old-name))))
(bbdb-record-set-namecache record nil)
(bbdb-record-set-firstname record fname)
(bbdb-record-set-lastname record lname)
(bbdb-debug (or fname lname
(error "bbdb: should have a name by now")))
(bbdb-puthash (downcase (bbdb-record-name record))
record)
)
((and old-name
bbdb-use-alternate-names
(bbdb-y-or-n-p
(format "Make \"%s\" an alternate for \"%s\"? "
name old-name)))
(setq change-p 'sort)
(bbdb-record-set-aka
record
(cons name (bbdb-record-aka record)))
(bbdb-puthash (downcase name) record)
)))
;; It's kind of a kludge that the "redundancy" concept is built in.
;; Maybe I should just add a new hook here... The problem is that the
;; canonicalize-net-hook is run before database lookup, and thus can't
;; refer to the database to determine whether a net is redundant.
(if bbdb-canonicalize-redundant-nets-p
(setq net (or (bbdb-net-redundant-p net (bbdb-record-net record))
net)))
(if (and net (not bbdb-readonly-p))
(if (null (bbdb-record-net record))
;; names are always a sure match, so don't bother prompting here.
(progn (bbdb-record-set-net record (list net))
(bbdb-puthash (downcase net) record) ; important!
(or change-p (setq change-p t)))
;; new address; ask before adding.
(if (let ((rest-net (bbdb-record-net record))
(new (downcase net))
(match nil))
(while (and rest-net (null match))
(setq match (string= new (downcase (car rest-net)))
rest-net (cdr rest-net)))
match)
nil
(if (cond
((eq bbdb-always-add-addresses t)
t)
(bbdb-always-add-addresses ; non-t and non-nil = never
nil)
(t
(and
(not (equal net "???"))
(let ((the-first-bit
(format "add address \"%s\" to \"" net))
;; this groveling is to prevent the "(y or n)" from
;; falling off the right edge of the screen.
(the-next-bit (mapconcat 'identity
(bbdb-record-net record)
", "))
(w (window-width (minibuffer-window))))
(if (> (+ (length the-first-bit)
(length the-next-bit) 15) w)
(setq the-next-bit
(concat
(substring the-next-bit
0 (max 0 (- w (length the-first-bit)
20)))
"...")))
(bbdb-y-or-n-p (concat the-first-bit the-next-bit
"\"? "))))))
(let ((front-p (cond ((null bbdb-new-nets-always-primary)
(bbdb-y-or-n-p
(format
"Make \"%s\" the primary address? "
net)))
((eq bbdb-new-nets-always-primary t)
t)
(t nil))))
(bbdb-record-set-net record
(if front-p
(cons net (bbdb-record-net record))
(nconc (bbdb-record-net record) (list
net))))
(bbdb-puthash (downcase net) record) ; important!
(or change-p (setq change-p t)))))))
(bbdb-debug
(if (and change-p bbdb-readonly-p)
(error
"doubleplus ungood: how did we change anything in readonly mode?")))
(if (and loudly change-p)
(if (eq change-p 'sort)
(message "noticed \"%s\"" (bbdb-record-name record))
(if (bbdb-record-name record)
(message "noticed %s's address \"%s\"" (bbdb-record-name record)
net)
(message "noticed naked address \"%s\"" net))))
(if change-p
(bbdb-change-record record (eq change-p 'sort)))
(bbdb-invoke-hook 'bbdb-notice-hook record)
record)))))
