1 ;;; bbdb-wl.el -- BBDB interface to Wanderlust
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, news, database
10 ;; Insert the following lines in your ~/.wl
28 (defvar bbdb-pop-up-elided-display nil))
32 (defvar bbdb-wl-get-update-record-hook nil)
33 (defvar bbdb-wl-folder-regexp nil)
34 (defvar bbdb-wl-ignore-folder-regexp nil)
36 (defvar bbdb-wl-canonicalize-full-name-function
37 #'bbdb-wl-canonicalize-spaces-and-dots
38 "Way to canonicalize full name.")
40 (defun bbdb-wl-canonicalize-spaces-and-dots (string)
41 (while (and string (string-match " +\\|[\f\t\n\r\v]+\\|\\." string))
42 (setq string (replace-match " " nil t string)))
43 (and string (string-match "^ " string)
44 (setq string (replace-match "" nil t string)))
48 (defun bbdb-wl-setup ()
49 (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
50 (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
51 (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
52 (add-hook 'wl-exit-hook 'bbdb-wl-exit)
53 (add-hook 'wl-save-hook 'bbdb-offer-save)
54 (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
55 (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
56 (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
57 (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
58 'bbdb-wl-show-bbdb-buffer)
59 (add-hook 'wl-summary-mode-hook
62 (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
63 (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
64 (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
65 (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
66 (add-hook 'wl-mail-setup-hook
69 ;;; (local-set-key "\M-\t" 'bbdb-complete-name)
70 (define-key (current-local-map) "\M-\t" 'bbdb-complete-name))))
74 (if (not (boundp 'bbdb-get-addresses-from-headers))
75 (defvar bbdb-get-addresses-from-headers
76 '("From" "Resent-From" "Reply-To")))
78 (if (not (boundp 'bbdb-get-addresses-to-headers))
79 (defvar bbdb-get-addresses-to-headers
80 '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
82 (if (not (boundp 'bbdb-get-addresses-headers))
83 (defvar bbdb-get-addresses-headers
84 (append bbdb-get-addresses-from-headers
85 bbdb-get-addresses-to-headers))))
87 (defun bbdb-wl-exit ()
89 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
90 (kill-buffer bbdb-buf)))
93 (defun bbdb-wl-get-update-record ()
94 (let ((folder-name (with-current-buffer
95 wl-message-buffer-cur-summary-buffer
96 (wl-summary-buffer-folder-name))))
97 (if (and (or (null bbdb-wl-folder-regexp)
98 (string-match bbdb-wl-folder-regexp folder-name))
99 (not (and bbdb-wl-ignore-folder-regexp
100 (string-match bbdb-wl-ignore-folder-regexp
102 (with-current-buffer (wl-message-get-original-buffer)
103 (bbdb-wl-update-record)
104 (run-hooks 'bbdb-wl-get-update-record-hook)))))
106 (defun bbdb-wl-hide-bbdb-buffer ()
107 (let (bbdb-buf bbdb-win)
108 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
109 (if (setq bbdb-win (get-buffer-window bbdb-buf))
110 (delete-window bbdb-win)))))
112 (defun bbdb-wl-show-bbdb-buffer ()
113 (save-selected-window
114 (if (get-buffer-window bbdb-buffer-name)
116 (let ((mes-win (get-buffer-window
118 (if (buffer-live-p wl-current-summary-buffer)
119 (set-buffer wl-current-summary-buffer))
121 (cur-win (selected-window))
122 (b (current-buffer)))
123 (and mes-win (select-window mes-win))
125 (- (window-height mes-win)
127 (- (window-height mes-win)
128 (max window-min-height
129 (1+ bbdb-pop-up-target-lines))))))
130 (split-window mes-win (if (> size 0) size window-min-height)))
131 ;; goto the bottom of the two...
132 (select-window (next-window))
133 ;; make it display *BBDB*...
134 (let ((pop-up-windows nil))
135 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
137 (defun bbdb-wl-get-petname (from)
138 "For `wl-summary-get-petname-function'."
139 (let* ((address (wl-address-header-extract-address from))
140 (record (bbdb-search-simple nil address)))
142 (or (bbdb-record-name record)
143 (car (bbdb-record-name record))))))
145 (defun bbdb-wl-from-func (string)
146 "A candidate From field STRING. For `wl-summary-from-function'."
147 (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
149 first-name last-name from-str)
152 (setq first-name (aref hit 0))
153 (setq last-name (aref hit 1))
154 (cond ((and (null first-name)
156 (setq from-str string))
157 ((and first-name last-name)
158 (setq from-str (concat first-name " " last-name)))
159 ((or first-name last-name)
160 (setq from-str (or first-name last-name))))
164 (defun bbdb-wl-get-addresses-1 (&optional only-first-address)
165 "Return real name and email address of sender respectively recipients.
166 If an address matches `bbdb-user-mail-names' it will be ignored.
167 The headers to search can be configured by `bbdb-get-addresses-headers'.
168 For BBDB 2.33 or earlier."
171 (std11-narrow-to-header)
172 (let ((headers bbdb-get-addresses-headers)
173 (uninteresting-senders bbdb-user-mail-names)
174 addrlist header structures structure fn ad)
176 (setq header (std11-fetch-field (car headers)))
178 (setq structures (std11-parse-addresses-string
179 (std11-unfold-string header)))
180 (while (and (setq structure (car structures))
181 (eq (car structure) 'mailbox))
182 (setq fn (std11-full-name-string structure)
184 (with-temp-buffer ; to keep raw buffer unibyte.
185 (set-buffer-multibyte
186 default-enable-multibyte-characters)
188 (decode-mime-charset-string
189 fn wl-mime-charset))))
190 fn (funcall bbdb-wl-canonicalize-full-name-function fn)
191 ad (std11-address-string structure))
192 ;; ignore uninteresting addresses, this is kinda gross!
193 (when (or (not (stringp uninteresting-senders))
196 (and fn (string-match uninteresting-senders fn))
197 (and ad (string-match uninteresting-senders ad)))))
198 (add-to-list 'addrlist (list fn ad)))
199 (if (and only-first-address addrlist)
200 (setq structures nil headers nil)
201 (setq structures (cdr structures)))))
202 (setq headers (cdr headers)))
203 (nreverse addrlist)))))
205 (defun bbdb-wl-get-addresses-2 (&optional only-first-address)
206 "Return real name and email address of sender respectively recipients.
207 If an address matches `bbdb-user-mail-names' it will be ignored.
208 The headers to search can be configured by `bbdb-get-addresses-headers'.
209 For BBDB 2.34 or later."
212 (std11-narrow-to-header)
213 (let ((headers bbdb-get-addresses-headers)
214 (uninteresting-senders bbdb-user-mail-names)
215 addrlist header structures structure fn ad
216 header-type header-fields header-content)
218 (setq header-type (caar headers)
219 header-fields (cdar headers))
221 (setq header-content (std11-fetch-field (car header-fields)))
223 (setq structures (std11-parse-addresses-string
224 (std11-unfold-string header-content)))
225 (while (and (setq structure (car structures))
226 (eq (car structure) 'mailbox))
227 (setq fn (std11-full-name-string structure)
229 (with-temp-buffer ; to keep raw buffer unibyte.
230 (set-buffer-multibyte
231 default-enable-multibyte-characters)
233 (decode-mime-charset-string
234 fn wl-mime-charset))))
235 fn (funcall bbdb-wl-canonicalize-full-name-function fn)
236 ad (std11-address-string structure))
237 ;; ignore uninteresting addresses, this is kinda gross!
238 (when (or (not (stringp uninteresting-senders))
242 (string-match uninteresting-senders fn))
244 (string-match uninteresting-senders ad)))))
245 (add-to-list 'addrlist (list header-type
248 (if (and only-first-address addrlist)
249 (setq structures nil headers nil)
250 (setq structures (cdr structures)))))
251 (setq header-fields (cdr header-fields)))
252 (setq headers (cdr headers)))
253 (nreverse addrlist)))))
255 (defun bbdb-wl-get-addresses (&optional only-first-address)
256 "Return real name and email address of sender respectively recipients.
257 If an address matches `bbdb-user-mail-names' it will be ignored.
258 The headers to search can be configured by `bbdb-get-addresses-headers'."
259 (if (string< bbdb-version "2.34")
260 (bbdb-wl-get-addresses-1)
261 (bbdb-wl-get-addresses-2)))
263 (defun bbdb-wl-update-record (&optional offer-to-create)
264 "Returns the record corresponding to the current WL message,
265 creating or modifying it as necessary. A record will be created if
266 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
267 the user confirms the creation."
268 (let* ((bbdb-get-only-first-address-p t)
269 (records (bbdb-wl-update-records offer-to-create)))
270 (if (and records (listp records))
274 (defun bbdb-wl-update-records (&optional offer-to-create)
275 "Returns the records corresponding to the current WL message,
276 creating or modifying it as necessary. A record will be created if
277 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
278 the user confirms the creation."
281 (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
286 (if (buffer-live-p wl-current-summary-buffer)
287 (set-buffer wl-current-summary-buffer))
291 wl-current-summary-buffer
292 wl-message-buffer-cur-number))))
294 (or (progn (setq record (bbdb-message-cache-lookup key))
295 (if (listp record) (nth 1 record) record))
296 (static-if (not (fboundp 'bbdb-update-records))
297 (let* ((from (or (std11-field-body "From") ""))
299 (nth 1 (std11-extract-address-components
303 (string-match (bbdb-user-mail-names) addr))
304 (setq from (or (std11-field-body "To") from)))
305 (with-temp-buffer ; to keep raw buffer unibyte.
306 (set-buffer-multibyte
307 default-enable-multibyte-characters)
308 (setq from (eword-decode-string
309 (decode-mime-charset-string
313 (bbdb-encache-message
315 (bbdb-annotate-message-sender
317 (or (bbdb-invoke-hook-for-value
318 bbdb/mail-auto-create-p)
321 (bbdb-encache-message
323 (bbdb-update-records (bbdb-wl-get-addresses
324 bbdb-get-only-first-address-p)
325 (or (bbdb-invoke-hook-for-value
326 bbdb/mail-auto-create-p)
328 offer-to-create))))))))
330 (defun bbdb-wl-annotate-sender (string)
331 "Add a line to the end of the Notes field of the BBDB record
332 corresponding to the sender of this message."
333 (interactive (list (if bbdb-readonly-p
334 (error "The Insidious Big Brother Database is read-only")
335 (read-string "Comments: "))))
336 (set-buffer (wl-message-get-original-buffer))
337 (bbdb-annotate-notes (bbdb-wl-update-record t) string))
339 (defun bbdb-wl-edit-notes (&optional arg)
340 "Edit the notes field or (with a prefix arg) a user-defined field
341 of the BBDB record corresponding to the sender of this message."
343 (wl-summary-set-message-buffer-or-redisplay)
344 (set-buffer (wl-message-get-original-buffer))
345 (let ((record (or (bbdb-wl-update-record t) (error ""))))
346 (bbdb-display-records (list record))
348 (bbdb-record-edit-property record nil t)
349 (bbdb-record-edit-notes record t))))
351 (defun bbdb-wl-show-records (&optional headers)
352 "Display the contents of the BBDB for the sender of this message.
353 This buffer will be in `bbdb-mode', with associated keybindings."
355 (wl-summary-set-message-buffer-or-redisplay)
356 (set-buffer (wl-message-get-original-buffer))
357 (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers))
358 (bbdb-update-records-mode 'annotating)
359 (bbdb-message-cache nil)
360 (bbdb-user-mail-names nil)
362 (setq records (bbdb-wl-update-records t))
365 (bbdb-wl-pop-up-bbdb-buffer)
366 (bbdb-display-records (if (listp records) records
368 (bbdb-undisplay-records))
369 (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
371 (select-window bbdb-win))
374 (defun bbdb-wl-address-headers-spec (address-class)
375 "Return address headers structure for ADDRESS-CLASS."
376 (if (string< bbdb-version "2.34")
378 ((eq address-class 'recipients)
379 bbdb-get-addresses-to-headers)
380 ((eq address-class 'authors)
381 bbdb-get-addresses-from-headers)
383 (append bbdb-get-addresses-to-headers
384 bbdb-get-addresses-from-headers)))
385 (list (assoc address-class bbdb-get-addresses-headers))))
387 (defun bbdb-wl-show-all-recipients ()
388 "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
390 (bbdb-wl-show-records (bbdb-wl-address-headers-spec 'recipients)))
392 (defun bbdb-wl-show-sender (&optional show-recipients)
393 "Display the contents of the BBDB for the senders of this message.
394 With a prefix argument show the recipients instead,
395 with two prefix arguments show all records.
396 This buffer will be in `bbdb-mode', with associated keybindings."
398 (cond ((= 4 show-recipients)
399 (bbdb-wl-show-all-recipients))
400 ((= 16 show-recipients)
401 (bbdb-wl-show-records))
403 (if (null (bbdb-wl-show-records
404 (bbdb-wl-address-headers-spec 'authors)))
405 (bbdb-wl-show-all-recipients)))))
407 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
408 "Make the *BBDB* buffer be displayed along with the WL window(s),
409 displaying the record corresponding to the sender of the current message."
410 (if (get-buffer-window bbdb-buffer-name)
412 (let ((mes-win (get-buffer-window
414 (if (buffer-live-p wl-current-summary-buffer)
415 (set-buffer wl-current-summary-buffer))
417 (cur-win (selected-window))
418 (b (current-buffer)))
420 (select-window mes-win))
422 (- (window-height mes-win)
424 (- (window-height mes-win)
425 (max window-min-height
426 (1+ bbdb-pop-up-target-lines))))))
427 (split-window mes-win (if (> size 0) size window-min-height)))
428 ;; goto the bottom of the two...
429 (select-window (next-window))
430 ;; make it display *BBDB*...
431 (let ((pop-up-windows nil))
432 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
433 ;; select the original window we were in...
434 (select-window cur-win)
435 ;; and make sure the current buffer is correct as well.
437 (let ((bbdb-gag-messages t)
438 (bbdb-use-pop-up nil)
439 (bbdb-electric-p nil))
440 (let* ((records (static-if (fboundp 'bbdb-update-records)
441 (bbdb-wl-update-records offer-to-create)
442 (bbdb-wl-update-record offer-to-create)))
443 ;; BBDB versions v2.33 and later.
445 (cond ((boundp 'bbdb-pop-up-display-layout)
446 (symbol-value 'bbdb-pop-up-display-layout))
447 ((boundp 'bbdb-pop-up-elided-display)
448 (symbol-value 'bbdb-pop-up-elided-display))))
449 ;; BBDB versions prior to v2.33,
450 (bbdb-elided-display bbdb-display-layout)
451 (b (current-buffer)))
452 (bbdb-display-records (if (listp records) records
457 (defun bbdb-wl-send-mail-internal (&optional to subj records)
459 (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
460 (condition-case nil (delete-other-windows) (error))))
462 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
465 (if (fboundp 'bbdb-wl-extract-field-value-internal)
466 ;;(if (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
468 (if (and (string< bbdb-version "1.58")
469 ;;(not (fboundp 'bbdb-extract-field-value) ;; defined as autoload
470 (not (fboundp 'bbdb-header-start)))
472 (require 'bbdb-hooks))
473 (fset 'bbdb-wl-extract-field-value-internal
475 ((fboundp 'tm:bbdb-extract-field-value)
476 (symbol-function 'tm:bbdb-extract-field-value))
477 (t (symbol-function 'bbdb-extract-field-value))))
478 (defun bbdb-extract-field-value (field)
479 (let ((value (bbdb-wl-extract-field-value-internal field)))
480 (with-temp-buffer ; to keep raw buffer unibyte.
481 (set-buffer-multibyte
482 default-enable-multibyte-characters)
484 (eword-decode-string value)))))
490 ;;; bbdb-wl.el ends here