The following message is a courtesy copy of an article
that has been posted to gnu.emacs.sources as well.
This is a new version of the BBDB expiry hack `expire-bbdb.el'.
Changes:
- Renamed to `bbdb-expire.el' to be more in keeping with the way BBDB and
Emacs packages are normally named, and the way the package's own
variables are named. (The original name was a mistake, really.)
The `expire-bbdb-load-hook' has changed name accordingly.
- Comment better, and improve docstrings.
- Split out the unportable part (the brittle advisement-based scheme for
allowing notice hooks to update the BBDB `quietly' without updating
changed-record lists or last-modified timestamps) into
`bbdb-hidden-update.el', included herein.
In bbdb-hidden-update.el:
- Fix hidden updating so that it suppresses firing of the bbdb-change-hook
when called from a function on the `bbdb-notice-hook', rather than
concentrating exclusively on timestamps. (This behaviour should already
be present, according to the docstring of the `bbdb-notice-hook', but this
is not the case. Probably a bug; when the bug is fixed this code can be
removed.)
First, here is the new bbdb-expire.el:
;;; bbdb-expire.el --- expiry and expire-proof entries for the BBDB
;;; Copyright (C) 2000 Nix <[EMAIL PROTECTED]>.
;; Author: Nix <[EMAIL PROTECTED]>
;; Created: 2000-09-17
;; Last modified: 2000-10-28
;; Keywords: mail news
;; Version: $Revision: 1.3 $
;; This file is not part of XEmacs, or GNU Emacs.
;; This library 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 2.1, or (at your option)
;; any later version.
;; It 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 this library; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.
;;; Commentary:
;; This file implements expiry of BBDB databases, to stop them getting too
;; fantastically bloated. Only specific entries are retained across expiry.
;;
;; Each entry is passed through each function in the
;; `bbdb-expire-expiry-functions' in turn; if any return t it is a candicate
;; for expiry; but if any of the functions in the
;; `bbdb-expire-preservation-functions' return t, it is not expired after all.
;; (This scheme allows functions to say `I don't care' as well as `expire
;; me now' and `do not expire me'.)
;;
;; One function is on `bbdb-expire-expiry-functions' by default;
;; `bbdb-expire-record-old-p'.
;; Two functions are on `bbdb-expire-preservation-functions' by default;
;; `bbdb-expire-field-permanent-p' and `bbdb-expire-field-notes-p'.
;;
;; Together, these ensure that old records without a `notes' or a
;; `permanent' field are expired; the field-checking functions are
;; generated by a macro, `bbdb-expire-field-foo-p'.
;; This will probably only work with version 2.00 of the BBDB, and may well
;; only work with version 2.00.06.
;; It requires the `bbdb-hidden-update.el' library, available from wherever
;; you got `bbdb-expire.el' from.
;; To use:
;; First of all, after you load this package but before you do anything else
;; with the BBDB, do a `bbdb-expire-add-last-access-time'. This attaches the
;; last access time field to all the BBDB entries, and assumes they were
;; last accessed *right now*. You never need to do this again, except if
;; you stop using this package and want to restart later on.
;; WARNING: If you forget to do this, only entries that you have accessed,
;; and then left for more than `bbdb-expire-this-old' days, will be expired;
;; entries that have been left since before you used this package will be
;; left alone, which is suboptimal.
;; (You do not need to do this if you remove `bbdb-expire-record-old-p'
;; from the `bbdb-expire-expiry-functions', but that leaves this package
;; mostly devoid of function...)
;; To expire the BBDB at any time, run `bbdb-expire-bbdb'.
;; Everything else happens automagically.
;; To do:
;; Currently, `bbdb-expire-bbdb' is not automatically called.
;; The ideal would be to call it once per session, as BBDB initializes, but
;; the only obvious place to do that is the `bbdb-after-read-db-hook',
;; but as you cannot call `bbdb-records' from that hook, this is impossible.
;; If you have any idea where I can hang it, please say!
;; This is dependent on the bbdb-hidden-update library, which is very brittle
;; and BBDB version dependent. It would be nice to remove this dependency
;; (but that requires changes to BBDB itself).
;; Add customize support.
;; This probably does not work with GNU Emacs; I don't currently have a copy
;; so it is hard to test it there, and there are probably unintentional
;; dependencies on XEmacs.
;; If you want to use this on GNU Emacs, and it doesn't work, please tell me
;; what is missing or broken for GNU Emacs support so I can fix it, as I
;; would like it to work there as well.
;;; Requirements:
(require 'bbdb)
(require 'bbdb-com)
(require 'bbdb-hooks)
(require 'time-date)
(require 'bbdb-hidden-update)
(bbdb-hidden-update-initialize)
;;; User-configurable variables:
(defvar bbdb-expire-this-old 90
"Expire entries in the BBDB that have not been referenced for this many days.
Used by the `bbdb-expire-record-old-p' function.")
(defvar bbdb-expire-expiry-functions '(bbdb-expire-record-old-p)
"Functions to call to determine if a record is expirable or not.
Each function is called with one parameter, the record to test for expirable
status; it should return t if the record is eligible for expiry.")
(defvar bbdb-expire-preservation-functions '(bbdb-expire-field-permanent-p
bbdb-expire-field-notes-p)
"Functions to call to determine if a record should be preserved from expiry.
Each function is called with one parameter, the record to test for preservable
status; it should return t if the record should never be expired.")
;;; Code:
;; Keeping things updated.
(defun bbdb-expire-update-last-access-time (record)
"Update the (non-displayed) `last-access' field in the BBDB.
(The `last-access' field is used by the `bbdb-expire-record-old-p' predicate.)"
(bbdb-record-putprop record 'last-access
(format-time-string bbdb-time-internal-format
(current-time))))
; Arrange to call this function whenever a record is noticed, in such a way
; that modifications to BBDB records from within it do not mark those records
; as changed or fire the bbdb-change-hook or bbdb-after-change-hook.
(add-hook 'bbdb-hidden-update-functions 'bbdb-expire-update-last-access-time)
;; Handling refiling of multiple records containing a `last-access' or
;; `permanent' field; we pick the string which is lexicographically
;; highest. (Here, we see an advantage of the ISO date format;
;; lexicographic ordering is the same as temporal ordering.)
; When we refile them, we want to sort them lexicographically,
; so we need a function that does that.
(defun bbdb-refile-notes-string-most (string1 string2)
"Returns the string that is not lessp."
(if (not (string-lessp string1 string2))
string1
string2))
; Arrange to use this function when refiling two records that
; contain these fields.
(setq bbdb-refile-notes-generate-alist
(append '((last-access . bbdb-refile-notes-string-most)
(permanent . bbdb-refile-notes-string-most))
bbdb-refile-notes-generate-alist))
;; Do not display either field.
(setq bbdb-elided-display (nconc bbdb-elided-display '(last-access permanent)))
;; Initial installation.
(defun bbdb-expire-add-last-access-time ()
(interactive)
"Add last access times to BBDB records that do not yet have them.
The last access time is set to the current time, because this is safest."
; Do not fire change hooks, update timestamps, or update `last-access'
; times.
(with-bbdb-change-hooks-suppressed
(let ((bbdb-hidden-update-functions bbdb-hidden-update-functions))
(remove-hook 'bbdb-hidden-update-functions
'bbdb-expire-update-last-access-time)
; For all records, add a `last-access' field set to the current time
; if that record does not already have one.
(mapc #'(lambda (record)
(or (bbdb-record-getprop record 'last-access)
(bbdb-record-putprop record 'last-access
(format-time-string bbdb-time-internal-format
(current-time)))))
(bbdb-records)))))
;; Expiration predicates.
; This is the conventional way of doing expiry.
(defun bbdb-expire-record-old-p (record)
"Return t if RECORD is older than `bbdb-expire-this-old' days."
(let ((last-access (bbdb-record-getprop record 'last-access)))
(and last-access
(string< last-access
(format-time-string bbdb-time-internal-format
(subtract-time (current-time)
(days-to-time
bbdb-expire-this-old)))))))
; Generate all these dull `if-this-field-is-present' predicates with
; a macro.
; (These predicates are used as `bbdb-expire-preservation-functions'.)
(defmacro bbdb-expire-field-foo-p (field)
"Generate functions that return t if some RECORD contains a given FIELD.
FIELD should be a quoted symbol, just as passed to `bbdb-record-getprop'."
`(defun ,@(list (intern (concat "bbdb-expire-field-"
(symbol-name (car (cdr field)))
"-p"))) (record)
,@(list (concat "Return t if RECORD contains the `"
(symbol-name (car (cdr field))) "' field."))
(bbdb-record-getprop record ,field)))
(bbdb-expire-field-foo-p 'permanent)
(bbdb-expire-field-foo-p 'notes)
;; Expiry.
; FIXME: Is it necessary to use `bbdb-records'? Using it stops this from going
; on the `bbdb-after-read-db-hook'... :(
(defun bbdb-expire-bbdb ()
(interactive)
"Expire old records from the BBDB.
Entries are expired if at least one of the `bbdb-expire-expiry-functions'
returns t, and none of the `bbdb-expire-preservation-functions' return t."
; Do not fire change hooks, update timestamps, or update last-access
; times.
(with-bbdb-change-hooks-suppressed
(let ((bbdb-hidden-update-functions bbdb-hidden-update-functions))
(remove-hook 'bbdb-hidden-update-functions
'bbdb-expire-update-last-access-time)
; For all records, if the record should be expired, and fails
; all attempts at its preservation, delete it.
(mapc #'(lambda (record)
(and (run-hook-with-args-until-success
'bbdb-expire-expiry-functions record)
(not (run-hook-with-args-until-success
'bbdb-expire-preservation-functions record))
(bbdb-delete-record-internal record)))
(bbdb-records)))))
(run-hooks 'bbdb-expire-load-hook)
(provide 'bbdb-expire)
-- -- -- -- cut here -- -- -- --
Next, here is the bbdb-hidden-update.el library, required by bbdb-expire.el:
;;; bbdb-hidden-update.el --- Update BBDB records very quietly and automatically
;;; Copyright (C) 2000 Nix <[EMAIL PROTECTED]>.
;; Author: Nix <[EMAIL PROTECTED]>
;; Created: 2000-10-26
;; Last modified: 2000-10-28
;; Keywords: mail news
;; Version: $Revision: 1.1 $
;; This file is not part of XEmacs, or GNU Emacs.
;; This library 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 2.1, or (at your option)
;; any later version.
;; It 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 this library; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.
;;; Commentary:
;; The `bbdb-notice-hook' allows things to happen whenver a BBDB record
;; is noticed; but if you try to record that fact in the BBDB record itself,
;; you have the problem that the BBDB record is marked as changed in the
;; `bbdb-changed-records' list, and that the modification itself triggers
;; the `bbdb-change-hook', which by default calls `bbdb-timestamp-hook',
;; leading to the BBDB's last-modified timestamp being updated *every
;; single time* the record is noticed, and to `bbdb-changed' listing
;; every record you've seen since the database was last saved; not an
;; especially useful function.
;; (Yes, the docstring for `bbdb-change-hook' states that it is not called
;; for modifications made within the `bbdb-notice-hook'. This is incorrect;
;; maybe it is a bug.)
;; This file fixes this, providing the ability to have some field that is
;; automatically updated whenever a record is noticed, without making a fuss
;; about it, recording it as changed, or calling `bbdb-change-hook' or
;; `bbdb-after-change-hook'. (The .bbdb file is still marked as modified, so
;; that it will still be saved.)
;; This facility should be integrated --- in a neater and less fragile form ---
;; into BBDB itself; but until it is, this file exists to provide the same
;; facilities.
;; This will probably only work with version 2.00 of the BBDB, and may well
;; only work with version 2.00.06.
;; To use:
;; Call the function `bbdb-hidden-update-initialize' to begin hidden
;; updating. Add the names of functions to call to do the updating to the
;; `bbdb-hidden-update-functions' alist. They get passed the record to
;; use.
;; If you want to do some arbitrary thing without running the BBDB
;; change hooks (for instance, to avoid timestamp changes), you can
;; use the `with-bbdb-change-hooks-suppressed' macro.
;; If you just want to work around the buglet with `bbdb-notice-hook',
;; you just need to load the file; there is no need to run
;; `bbdb-hidden-update-initialize' unless you want to use
;; `bbdb-hidden-update-functions' in some way.
;; To do:
;; Parts of this code are very brittle, and highly dependent on BBDB version
;; (because of all the advisements). This will remain true if and until code
;; doing what this does is folded into the BBDB. (Note that this code should
;; *not* be folded in; it jumps through lots of hoops to avoid changing the
;; BBDB's code, and all these hoops can be thrown away.)
;; This might not work with GNU Emacs; I don't currently have a copy so it is
;; hard to test it there, and there may be unintentional dependencies on
;; XEmacs.
;; If you want to use this on GNU Emacs, and it doesn't work, please tell me
;; what is missing or broken for GNU Emacs support so I can fix it, as I
;; would like it to work there as well.
;;; Requirements:
(require 'advice)
(require 'bbdb)
;;; User-configurable variables:
(defvar bbdb-hidden-update-functions '()
"Functions that should be called whenever a BBDB record is noticed.
These differ from functions on the `bbdb-notice-hook' in that if they
change the record they are modifying, the record is not marked as changed,
and the hooks `bbdb-change-hook' and `bbdb-after-change-hook' are not run.")
;;; Code:
;; Do a hidden update.
(defun bbdb-hidden-update-run-functions (record)
"Do some BBDB record updates, very quietly.
This calls the functions named in the `bbdb-hidden-update-functions',
allowing them to change the `record' without marking it as changed,
or calling the `bbdb-change-hook' or `bbdb-after-change-hook'."
; The horrible frobbing with the `bbdb-changed-records' variable is because it
; is local to the .bbdb buffer, and is changed there by the function
; `bbdb-changed-records'. Locally rebinding the `bbdb-changed-records'
; variable does not work at all; it is not clear why this is.
; TODO: fix this.
(let ((real-bbdb-changed-records (bbdb-with-db-buffer bbdb-changed-records)))
(bbdb-invoke-hook 'bbdb-hidden-update-functions record)
(bbdb-with-db-buffer
(setq bbdb-changed-records real-bbdb-changed-records))))
;; Fix the `bbdb-.*-change-hook' buglet.
;; We have an advisement on `bbdb-invoke-hook' which suppresses execution of
;; hooks `eq' to `bbdb-change-hook' and `bbdb-after-change-hook' if a certain
;; variable is set; there is a macro `with-bbdb-change-hooks-suppressed' which
;; sets this variable; and there is an advisement on
;; `bbdb-annotate-message-sender' (which runs the `bbdb-notice-hook') that
;; forces `bbdb-annotate-message-sender' to be run
;; `with-bbdb-change-hooks-suppressed'.
;; This really does too much; if `bbdb-annotate-message-sender' does things
;; that might call the change hooks without going through the notice hooks,
;; they won't run. But as far as I can tell it does not do such things.
;; This could be done somewhat more simply if we could modify the BBDB source,
;; but we cannot assume that everyone will do that...
(defmacro with-bbdb-change-hooks-suppressed (&rest body)
"Execute the forms in BODY without running the BBDB change hooks.
If the BBDB changes in a way that would normally run these hooks,
they will not run.
The value returned is the value of the last form in BODY."
`(let ((bbdb-hidden-update-suppress-change-hooks t))
,@body))
;; This uses dynamic scoping, so we shut up the byte-compiler where it matters.
(let ((byte-compile-default-warnings
(delq 'unused-vars (copy-list byte-compile-default-warnings))))
;; This advice does the actual work.
(defadvice bbdb-invoke-hook (around bbdb-hidden-update-not-change-hooks
activate)
"Do not call the `bbdb-change-hook' or `bbdb-after-change-hook' if inside
`bbdb-annotate-message-sender'."
(or (and (boundp 'bbdb-hidden-update-suppress-change-hooks)
(or (eq hook bbdb-change-hook)
(eq hook bbdb-after-change-hook)))
ad-do-it)))
;; This advice merely suppresses the change hooks.
(defadvice bbdb-annotate-message-sender (around
bbdb-hidden-update-annotate-message-sender
activate)
"Notify `bbdb-invoke-hook' not to run the `bbdb-change-hook' or
`bbdb-after-change-hook'."
(with-bbdb-change-hooks-suppressed ad-do-it))
;; Initialization.
(defun bbdb-hidden-update-initialize ()
"Prepare to do hidden updates of fields in the BBDB."
(add-hook 'bbdb-notice-hook 'bbdb-hidden-update-run-functions))
(provide 'bbdb-hidden-update)
--
`Normally, we don't do people's homework around here, but Venice
is a very beautiful city, so I'll make a small exception.'
--- Robert Redelmeier compromises his principles
_______________________________________________
bbdb-info mailing list
[EMAIL PROTECTED]
http://lists.sourceforge.net/mailman/listinfo/bbdb-info
