1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
|
;;; >>>>> Ronan Waide writes:
;;; >> * birthdays/anniversaries
;;; RW> This /is/ venturing into calendar land. Still, go to yer bbdb buffer
;;; RW> and create a field with C-o. Again, I prefer not to add baggage to the
;;; RW> file format unless it's absolutely necessary. Also, you should be able
;;; RW> to attach bbdb to calendar.el using the bbdb record-dinking hooks so
;;; RW> that it auto-fills your calendar with goop for you. And maybe get
;;; RW> working on calendar-pilot.el...
;;; Well, this isn't really release-ready -- but since someone asks, it
;;; could be a good starting point for someone. Feel free to
;;; redistribute, or chop up and use the useful bits.
;;; Bng
;;; BBDB-BNG
;;; Various functions I have added to enhance the big brother database.
;;; Boris Goldowsky, <boris@cs.rochester.edu>
;;;
;;; This file allows you to do the following things:
;;; * Sort by firstname or company rather than last name.
;;; * Mark people's birthdays in emacs's calendar and diary displays.
;;; * Maintains a file of mail aliases, for use by other mailers,
;;; automatically updated when the information changes in your database.
;;; * Make sure that everyone has their username defined as an alias
;;; for their complete net addresses.
;;;
;;; INSTALLATION:
;;; Put this file in emacs's load-path, and make sure it gets loaded whenever
;;; you load BBDB.
;;; * To use alternate sorting, evaluate (bbdb-sort-by ...) whenever you load
;;; bbdb. YOU MUST EITHER ALWAYS DO THIS, OR NEVER DO IT. When you switch
;;; over, evaluate (bbdb-resort-database).
;;; * To make a file of mail-aliases, set bbdb-mail-alias-file to a filename,
;;; and source that file from your .mailrc.
;;; * Username-aliases are enabled by default. Set
;;; `bbdb-auto-username-alias' to nil if you don't want them.
;;; You can also use the function `bbdb-add-user-name-as-alias' to
;;; add such aliases manually.
;;; * The bbdb/calendar stuff is under development, and may not work.
;;;
;;; EXAMPLE:
;;; The following code could go in your .emacs:
;;; (add-hook 'bbdb-load-hook
;;; (function (lambda ()
;;; (setq bbdb-mail-alias-file
;;; (expand-file-name "~/.mail_aliases")
;;; (require 'bbdb-bng)
;;; (bbdb-sort-by 'firstname))))
;;; USE:
;;; If installed as above, these functions operate automatically.
;;; DEPENDENCIES:
;;; BBDB, of course.
;;; calendar.el and diary-lib.el are built into recent emacs versions.
;;; dates.el is available from me.
(provide 'bbdb-bng)
;;;
;;; New birthday stuff.
;;;
(require 'calendar)
(require 'dates)
(if (not (featurep 'diary)) ; the library of many names.
(or (load "diary-lib" t)
(load "diary")))
(defvar bbdb/calendar-marker
(if (not window-system)
"^"
(require 'faces)
'bold-italic)
"*How to mark birthdays in calendar.
Can be either a single-character string or a face.")
(add-hook 'list-diary-entries-hook 'bbdb/calendar-list-entries)
(add-hook 'mark-diary-entries-hook 'bbdb/calendar-mark-entries)
(defun bbdb/calendar-mark-entries ()
(save-excursion
(set-buffer calendar-buffer)
(let ((month displayed-month)
(year displayed-year))
(bbdb/calendar-mark-month month year)
(increment-calendar-month month year -1)
(bbdb/calendar-mark-month month year)
(increment-calendar-month month year 2)
(bbdb/calendar-mark-month month year))))
(defun bbdb/calendar-mark-month (month year)
(message "Marking birthdays..."
(let ((days (aref (bbdb/calendar-birthdays) month)))
(while days
(mark-visible-calendar-date (list month (car (car days)) year)
bbdb/calendar-marker)
(setq days (cdr days))))
(message nil)))
(defun bbdb/calendar-list-entries ()
(message "Listing birthdays..."
(let* ((bdays (bbdb/calendar-birthdays))
(start-date (calendar-absolute-from-gregorian original-date))
(end-date (+ number start-date)))
(calendar-for-loop abs-date from start-date to end-date do
(let* ((date (calendar-gregorian-from-absolute abs-date))
(entries (cdr (assoc (extract-calendar-day date)
(aref bdays
(extract-calendar-month date))))))
(while entries
(add-to-diary-list date (car entries))
(setq entries (cdr entries))))))
(message nil)))
(defvar bbdb/calendar-birthdays nil
"Used by function of the same name, which see.")
(defun bbdb/calendar-birthdays ()
"Returns a vector containing the birthdays in your BBDB.
This is a vector with one element per month:
[birthdays ; identifier in spot 0
((4 \"Isaac Newton's birthday\")) ; Newton's birthday is Jan 4.
((11 \"Thomas Edison's birthday\") ; Edison's is Feb 11.
(15 \"Galileo's birthday\" \"Susan B. Anthony's birthday\")) ; Both Feb 15.
...march through dec...
]"
(or bbdb/calendar-birthdays
(setq bbdb/calendar-birthdays
(let ((cal (make-vector 13 nil))
(recs (bbdb-records))
birthday-string)
(aset cal 0 'birthdays)
(while recs
(if (setq birthday-string
(bbdb-record-getprop (car recs) 'birthday))
(let ((events (bbdb-split birthday-string ","))
(name (bbdb-record-name (car recs))))
(while events
(let ((bday (date-parse (car events))))
(if (null bday)
(message "Unparsable birthday: %s" (car events))
(let* ((date-end (parse-string-end))
(eventname (if (eq t date-end)
"birthday"
(substring (car events)
date-end)))
(event (concat name "'s "
(if (equal "" eventname)
"birthday"
eventname)))
(month (extract-calendar-month bday))
(day (extract-calendar-day bday))
(monthlist (aref cal month))
(daylist (assoc day monthlist)))
(if daylist
(setcdr daylist (cons event (cdr daylist)))
(aset cal month (cons (list day event)
monthlist))))))
(setq events (cdr events)))))
(setq recs (cdr recs)))
cal))))
;;;
;;; Mail alias code
;;;
(defvar bbdb-mail-alias-file nil
"*File to save mail-aliases into.
Aliases are also kept in the database proper; this is just for the convenience
of other programs that are interested in mail aliases. For example, you can
use your bbdb mail aliases with ucb mail by including the line
source ~/.mail_aliases
in your .mailrc file.
Set this to nil to avoid storing mail aliases in a file.")
(defvar bbdb-auto-username-alias t
"*If t, always have a person's username as a mail-alias for them.")
(if bbdb-mail-alias-file
(add-hook 'bbdb-after-change-hook (function bbdb-check-mail-alias)))
(defun bbdb-add-user-name-as-alias ()
(interactive)
(let ((bbdb-auto-username-alias t)
(this(bbdb-current-record)))
(bbdb-check-mail-alias this)
(bbdb-redisplay-one-record this)))
(defun bbdb-record-username (record)
"Return just the username part of RECORD's first net address,
if it looks like a well-formed internet address; nil otherwise."
(let ((addr (car (bbdb-record-net record))))
(if (and addr (string-match "^[a-zA-z0-9]+@" addr))
(substring addr 0 (1- (match-end 0))))))
(defun bbdb-record-mail-aliases (record)
(let ((all (bbdb-record-getprop record bbdb-define-all-aliases-field)))
(if all (bbdb-split all ","))))
(defun bbdb-check-mail-alias (record)
"Makes sure the person's username is defined as a mail abbrev
for them, and makes sure all their mail abbreves are ready for use."
(let ((username (bbdb-record-username record))
(current (bbdb-record-getprop record bbdb-define-all-aliases-field)))
(if (and current (string-match "\\(,\\)? *\n" current))
(setq current (replace-match ", " nil nil current)))
(if (and bbdb-auto-username-alias
username
(not (and (boundp 'mail-abbrevs)
(intern-soft username mail-abbrevs)))
(not (member username (bbdb-record-mail-aliases record))))
(setq current
(if current (concat current ", " username)
username)))
(if current
(bbdb-record-putprop record bbdb-define-all-aliases-field current))
;; And make sure aliases are all defined (if any are)
(if (boundp 'mail-abbrevs)
(mapcar (function
(lambda (alias)
(if (not (intern-soft alias mail-abbrevs))
(my-define-mail-abbrev
alias (bbdb-dwim-net-address record)))))
(bbdb-record-mail-aliases record)))))
(defun my-define-mail-abbrev (abbrev address)
"Defines abbrev, and marks bbdb-mail-alias-file as modified."
(define-mail-abbrev abbrev address)
(save-excursion
(set-buffer (find-file-noselect bbdb-mail-alias-file))
(setq buffer-read-only t)
(set-buffer-modified-p t)
(make-variable-buffer-local 'local-write-file-hooks)
(if (not (memq 'bbdb-mail-alias-file-write-hook
local-write-file-hooks))
(setq local-write-file-hooks '(bbdb-mail-alias-file-write-hook)))))
(defun bbdb-insert-mail-aliases ()
(let ((begin (point)))
(if (not (boundp 'mail-abbrevs))
(bbdb-define-all-aliases))
(insert-abbrev-table-description 'mail-abbrevs nil)
(goto-char begin)
(let ((abbrevs (nth 1 (nth 2 (read (current-buffer))))))
(setq abbrevs (sort abbrevs (function
(lambda (x y)
(string-lessp (car x) (car y))))))
(delete-region begin (point))
(mapcar (function
(lambda (abbrev)
(let ((alias (car abbrev))
(addr (mapconcat (function simplify-address)
(bbdb-split (nth 1 abbrev) ",") " ")))
(if (not (string-equal alias addr))
(insert (format "alias %s\t%s\n" alias addr))))))
abbrevs))))
(defun simplify-address (addr)
(let ((addr (car (cdr (mail-extract-address-components addr)))))
(if (string-match (concat "@" (system-name) "$") addr)
(substring addr 0 (match-beginning 0))
addr)))
(defun bbdb-mail-alias-file-write-hook ()
"Regenerate mail-aliases if necc.
Call from local-write-file-hooks."
(let ((buffer-read-only nil))
(message "Writing aliases...")
(delete-region (point-min) (point-max))
(bbdb-insert-mail-aliases)
(message "Writing aliases...done")
nil))
;;;
;;; sorting frobnification.
;;;
(defun bbdb-sort-by (field)
"Tell BBDB which field is the primary sort key.
Currently FIELD must be one of 'firstname 'lastname or 'company.
The first time you use this, use bbdb-resort-database immediately
afterwards. Then put \(bbdb-sort-by 'firstname), or whichever field is
your choice, on your bbdb-after-load-db-hook."
(cond ((eq field 'lastname)
(defun bbdb-record-sortkey (record)
(or (bbdb-cache-sortkey (bbdb-record-cache record))
(bbdb-cache-set-sortkey
(bbdb-record-cache record)
(downcase
(concat (bbdb-record-lastname record)
(bbdb-record-firstname record)
(bbdb-record-company record)))))))
((eq field 'firstname)
(defun bbdb-record-sortkey (record)
(or (bbdb-cache-sortkey (bbdb-record-cache record))
(bbdb-cache-set-sortkey
(bbdb-record-cache record)
(downcase
(concat (bbdb-record-firstname record)
(bbdb-record-lastname record)
(bbdb-record-company record)))))))
((eq field 'company)
(defun bbdb-record-sortkey (record)
(or (bbdb-cache-sortkey (bbdb-record-cache record))
(bbdb-cache-set-sortkey
(bbdb-record-cache record)
(downcase
(concat (bbdb-record-company record)
(bbdb-record-lastname record)
(bbdb-record-firstname record)))))))
(t (error "Can only sort by firstname lastname or company!"))))
;;; Local Variables:
;;; eval:(put 'calendar-for-loop 'lisp-indent-hook 6)
;;; End:
|
