I know how to extract the contents of a message header and put it into
a particular notes field. I now wish to extract a pseudo-header (like
the "Archive: ..." line in source postings) and put that in a notes
field.
My best guess at the moment is to create a munged copy of
bbdb-auto-notes-hook that looks at the message body if the header
specified is "Body".
Is there an easier way ? Has anyone done this before ?
BTW, here is my current BBDB setup file for your edification. Notable
features are the removal of redundant addresses, the deletion of bbdb
windows on quitting the news or mail reader and the highlighting
(using font-lock-mode, of course) of article subject lines in GNUS
from people who are in my database. Jamie, feel free to pick anything
you like out of here for the BBDB distribution.
[The defadvice function is defined in the "advice" package, available
with FSF19 or from /ftp.cs.buffalo.edu:/pub/Emacs/ - a most excellent
package IMHO. It should included with the next version of Lucid Emacs
- hint, hint.]
;;; $Id: bbdb-defaults.el,v 1.6 1993/06/25 00:03:30 rwhitby Exp $
;;; $File: ~/elib/defaults/bbdb-defaults.el $
;;; $Copyright: ) 1993 Rod Whitby, <[EMAIL PROTECTED]> $
;;; Should set this to t sometime in the future
(setq bbdb-message-caching-enabled nil)
;;; Don't pop up the BBDB buffer
(setq bbdb-use-pop-up nil)
;;; Try and be safe about multiple editing
(setq bbdb-auto-revert-p t)
(setq bbdb-notice-auto-save-file t)
;;; Always save the database
(setq bbdb-offer-save 'just-do-it)
;;; Ignore some messages
(setq bbdb-ignore-some-messages-alist
'(
("From" . "\
root\\|\
postmaster\\|\
procnetfetch\\|\
procftpmail\\|\
mailer-daemon\\|\
rwhitby")
))
;;; Auto-create from mail in primary inbox
(setq bbdb/mail-auto-create-p 'elib-bbdb-ignore-some-messages-hook)
(defun elib-bbdb-ignore-some-messages-hook ()
(and vm-primary-inbox-p (bbdb-ignore-some-messages-hook)))
;;; Don't auto-create from news yet
(setq bbdb/news-auto-create-p nil)
(setq bbdb-auto-notes-alist
(list
'("To"
("ange-ftp-lovers" mailing-lists "Ange FTP")
("bbdb-announce" mailing-lists "BBDB")
("blake7" mailing-lists "Blake's 7")
("bug-lucid-emacs" mailing-lists "Lucid Emacs")
("c++-mode-victims" mailing-lists "C++ Mode")
("ctwm" mailing-lists "CTWM")
("dirt-users" mailing-lists "Dirt")
("edb-list" mailing-lists "EDB")
("faces" mailing-lists "Faces")
("free-widgets-announce" mailing-lists "FWF")
("help-lucid-emacs" mailing-lists "Lucid Emacs")
("hyperbole" mailing-lists "Hyperbole")
("info-bbdb" mailing-lists "BBDB")
("info-cvs" mailing-lists "CVS")
("info-pgp" mailing-lists "PGP")
("para" mailing-lists "Para Mode")
("procmail" mailing-lists "Procmail")
("supercite" mailing-lists "Supercite")
("ups-users" mailing-lists "UPS")
)
'("Cc"
("ange-ftp-lovers" mailing-lists "Ange FTP")
("bbdb-announce" mailing-lists "BBDB")
("blake7" mailing-lists "Blake's 7")
("bug-lucid-emacs" mailing-lists "Lucid Emacs")
("c++-mode-victims" mailing-lists "C++ Mode")
("ctwm" mailing-lists "CTWM")
("dirt-users" mailing-lists "Dirt")
("edb-list" mailing-lists "EDB")
("faces" mailing-lists "Faces")
("free-widgets-announce" mailing-lists "FWF")
("help-lucid-emacs" mailing-lists "Lucid Emacs")
("hyperbole" mailing-lists "Hyperbole")
("info-bbdb" mailing-lists "BBDB")
("info-cvs" mailing-lists "CVS")
("info-pgp" mailing-lists "PGP")
("para" mailing-lists "Para Mode")
("procmail" mailing-lists "Procmail")
("supercite" mailing-lists "Supercite")
("ups-users" mailing-lists "UPS")
)
'("Organization" (".*" company 0))
;; Only store the first newsgroup in a crossposting
'("Newsgroups" ("[^,]+" newsgroups 0))
(list "x-face"
(list (concat "[ \t\n]*\\([^ \t\n]*\\)"
"\\([ \t\n]+\\([^ \t\n]+\\)\\)?"
"\\([ \t\n]+\\([^ \t\n]+\\)\\)?"
"\\([ \t\n]+\\([^ \t\n]+\\)\\)?"
)
'face
"\\1\\3\\5\\7"))
))
(setq bbdb-auto-notes-ignore
'(
("Organization" . "\
^Gatewayed from\\|^Source only\\|GNUs Not Usenet\\|GNU's Not UNIX\\|The Internet")
))
(add-hook 'bbdb-notice-hook 'bbdb-auto-notes-hook)
;;; Change all the field separators to commas
(defun elib-bbdb-after-read-db-hook ()
(mapcar
(function
(lambda (fieldname)
(put (intern (car fieldname)) 'field-separator ", ")))
(bbdb-propnames))
nil)
(add-hook 'bbdb-after-read-db-hook 'elib-bbdb-after-read-db-hook)
;;; Ask before adding new addresses at the end of the list
(setq bbdb-always-add-addresses t)
(setq bbdb-new-nets-always-primary t)
(defun bbdb-net-is-redundant (list net)
(let ((redundant nil))
(while (and (not redundant)
(not (null list)))
;; Calculate a host-regexp for each address in LIST
(let* ((host-index (string-match "@" (car list)))
(name (and host-index
(substring (car list) 0 host-index)))
(host (and host-index
(substring (car list) (1+ host-index))))
;; host-regexp is "^<name>@.*\.<host>$"
(host-regexp (and name host
(concat "\\`" (regexp-quote name)
"@.*\\." (regexp-quote host)
"\\'"))))
;; If NET matches host-regexp, then it is redundant
(if (and host-regexp net
(string-match host-regexp net))
(setq redundant t)))
(setq list (cdr list)))
redundant))
(defun bbdb-remove-redundant-nets (record)
(let* ((all-nets (bbdb-record-net record))
(rest-nets all-nets)
new-nets)
(while (not (null rest-nets))
(let ((net (car rest-nets)))
(if (not (bbdb-net-is-redundant all-nets net))
(setq new-nets (nconc new-nets (list net)))))
(setq rest-nets (cdr rest-nets)))
(bbdb-record-set-net record new-nets)))
(add-hook 'bbdb-change-hook 'bbdb-remove-redundant-nets)
;;;; Hook functions
(defun elib-bbdb-kill-buffer ()
(interactive)
(let ((bbdb-buffer (and bbdb-buffer-name
(get-buffer bbdb-buffer-name))))
(and bbdb-buffer
(progn
(set-buffer bbdb-buffer)
(bbdb-bury-buffer)
(delete-windows-on bbdb-buffer)))))
;;;; Hooks into GNUS
(setq bbdb/gnus-header-prefer-real-names nil)
(setq bbdb/gnus-mark-known-posters t)
(setq bbdb/gnus-header-show-bbdb-names t)
(defun bbdb/gnus-optional-from (header)
"Return a string like `AUTHOR' from HEADER."
(let* ((length (length "umerin@photon"))
(from (nntp-header-from header))
(data (and (or bbdb/gnus-mark-known-posters
bbdb/gnus-header-show-bbdb-names)
(condition-case ()
(mail-extract-address-components from)
(error nil))))
(name (car data))
(net (car (cdr data)))
(record (and data
(bbdb-search-simple name
(if (and net bbdb-canonicalize-net-hook)
(bbdb-canonicalize-address net)
net))))
string L)
(setq name (or (and bbdb/gnus-header-prefer-real-names
(or (and bbdb/gnus-header-show-bbdb-names record
(bbdb-record-name record))
name))
net))
;; GNUS can't cope with extra square-brackets appearing in the summary.
(if (and name (string-match "[][]" name))
(progn (setq name (copy-sequence name))
(while (string-match "[][]" name)
(aset name (match-beginning 0) ? ))))
(setq string (format "%c%s"
(if (and record bbdb/gnus-mark-known-posters) ?* ? )
(or name from))
L (length string))
(cond ((> L length) (substring string 0 length))
((< L length) (concat string (make-string (- length L) ? )))
(t string))))
(defun elib-bbdb-insinuate-gnus ()
"Call this function to hook BBDB into GNUS."
;; Hack on to gnus-Group-exit, since the Exit hook is called too early.
(defadvice gnus-Group-exit (after elib-bbdb-kill-buffer last activate)
"Kill the BBDB buffer."
(elib-bbdb-kill-buffer))
;; Hack on to gnus-Group-quit, since the Exit hook is called too early.
(defadvice gnus-Group-quit (after elib-bbdb-kill-buffer last activate)
"Kill the BBDB buffer."
(elib-bbdb-kill-buffer))
(setq gnus-optional-headers 'bbdb/gnus-optional-from)
)
(add-hook 'gnus-Startup-hook 'bbdb-insinuate-gnus 'at-end)
(add-hook 'gnus-Startup-hook 'elib-bbdb-insinuate-gnus 'at-end)
;;;; Hooks into VM
(defun elib-bbdb-insinuate-vm ()
"Call this function to hook BBDB into VM."
;; Hack on to vm-save-folder, since VM 5.32 doesn't
;; have a vm-save-folder-hook or anything...
(defadvice vm-save-folder (after bbdb-offer-save last activate)
"Offer to save the BBDB buffer."
(bbdb-offer-save))
;; Hack on to vm-quit, since VM 5.32 doesn't
;; have a vm-quit-hook or anything...
(defadvice vm-quit (after elib-bbdb-kill-buffer last activate)
"Kill the BBDB buffer."
(elib-bbdb-kill-buffer))
)
(add-hook 'vm-mode-hooks 'bbdb-insinuate-vm 'at-end)
(add-hook 'vm-mode-hooks 'elib-bbdb-insinuate-vm 'at-end)
;;;; Hooks into mail
(add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail 'at-end)
(add-hook 'mail-setup-hook 'bbdb-define-all-aliases 'at-end)
(cond
(running-lemacs
;; Hooks into font-lock mode
(require 'font-lock-setup)
(setq gnus-Subject-font-lock-keywords
(append
(list
'("^. +[0-9]+:.\\(\\[\\*[^\]]+\\]\\)" 1 font-lock-comment-face t))
gnus-Subject-font-lock-keywords
))
)
)
(provide 'bbdb-defaults)
--
--------------------------------------------- _--_|\ |
Rod Whitby ([EMAIL PROTECTED]) / \ |
Canon Information Systems Research Australia \_.--._/ |
1 Thomas Holt Drive, North Ryde, N.S.W., 2113. v |
