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))
29 ;; (or (fboundp 'bbdb-wl-extract-field-value-internal)
30 ;; (defun bbdb-wl-extract-field-value-internal (field))))
33 (defvar bbdb-wl-get-update-record-hook nil)
34 (defvar bbdb-wl-folder-regexp nil)
36 (defun bbdb-wl-setup ()
37 (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
38 (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
39 (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
40 (add-hook 'wl-exit-hook 'bbdb-wl-exit)
41 (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
42 (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
43 (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
44 (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
45 'bbdb-wl-show-bbdb-buffer)
46 (add-hook 'wl-summary-mode-hook
49 (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
50 (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
51 (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
52 (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
53 (add-hook 'wl-mail-setup-hook
56 ;;; (local-set-key "\M-\t" 'bbdb-complete-name)
57 (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)
60 (defun bbdb-wl-exit ()
62 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
63 (kill-buffer bbdb-buf)))
66 (defun bbdb-wl-get-update-record ()
67 (if (or (null bbdb-wl-folder-regexp)
71 wl-message-buffer-cur-summary-buffer
72 (wl-summary-buffer-folder-name))))
73 (with-current-buffer (wl-message-get-original-buffer)
74 (bbdb-wl-update-record)
75 (run-hooks 'bbdb-wl-get-update-record-hook))))
77 (defun bbdb-wl-hide-bbdb-buffer ()
78 (let (bbdb-buf bbdb-win)
79 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
80 (if (setq bbdb-win (get-buffer-window bbdb-buf))
81 (delete-window bbdb-win)))))
83 (defun bbdb-wl-show-bbdb-buffer ()
85 (if (get-buffer-window bbdb-buffer-name)
87 (let ((mes-win (get-buffer-window
89 (if (buffer-live-p wl-current-summary-buffer)
90 (set-buffer wl-current-summary-buffer))
92 (cur-win (selected-window))
94 (and mes-win (select-window mes-win))
96 (- (window-height mes-win)
98 (- (window-height mes-win)
99 (max window-min-height
100 (1+ bbdb-pop-up-target-lines))))))
101 (split-window mes-win (if (> size 0) size window-min-height)))
102 ;; goto the bottom of the two...
103 (select-window (next-window))
104 ;; make it display *BBDB*...
105 (let ((pop-up-windows nil))
106 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
108 (defun bbdb-wl-get-petname (from)
109 "For `wl-summary-get-petname-func'."
110 (let* ((address (wl-address-header-extract-address from))
111 (record (bbdb-search-simple nil address)))
113 (or (bbdb-record-name record)
114 (car (bbdb-record-name record))))))
116 (defun bbdb-wl-from-func (string)
117 "A candidate From field STRING. For `wl-summary-from-func'."
118 (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
120 first-name last-name from-str)
123 (setq first-name (aref hit 0))
124 (setq last-name (aref hit 1))
125 (cond ((and (null first-name)
127 (setq from-str string))
128 ((and first-name last-name)
129 (setq from-str (concat first-name " " last-name)))
130 ((or first-name last-name)
131 (setq from-str (or first-name last-name))))
135 (defun bbdb-wl-get-addresses (&optional only-first-address)
136 "Return real name and email address of sender respectively recipients.
137 If an address matches `bbdb-user-mail-names' it will be ignored.
138 The headers to search can be configured by `bbdb-get-addresses-headers'."
141 (std11-narrow-to-header)
142 (let ((headers bbdb-get-addresses-headers)
143 (uninteresting-senders bbdb-user-mail-names)
144 addrlist header structures structure fn ad)
146 (setq header (std11-fetch-field (car headers)))
148 (setq structures (std11-parse-addresses-string
149 (std11-unfold-string header)))
150 (while (and (setq structure (car structures))
151 (eq (car structure) 'mailbox))
152 (setq fn (std11-full-name-string structure)
154 (with-temp-buffer ; to keep raw buffer unibyte.
155 (elmo-set-buffer-multibyte
156 default-enable-multibyte-characters)
158 (decode-mime-charset-string
159 fn wl-mime-charset))))
160 ad (std11-address-string structure))
162 ;; ignore uninteresting addresses, this is kinda gross!
163 (when (or (not (stringp uninteresting-senders))
165 (and fn (string-match uninteresting-senders fn))
166 (and ad (string-match uninteresting-senders ad)))))
167 (add-to-list 'addrlist (list fn ad)))
169 (if (and only-first-address addrlist)
170 (setq structures nil headers nil)
171 (setq structures (cdr structures)))))
172 (setq headers (cdr headers)))
173 (nreverse addrlist)))))
175 (defun bbdb-wl-update-record (&optional offer-to-create)
176 "Returns the record corresponding to the current WL message,
177 creating or modifying it as necessary. A record will be created if
178 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
179 the user confirms the creation."
180 (let* ((bbdb-get-only-first-address-p t)
181 (records (bbdb-wl-update-records offer-to-create)))
182 (if (and records (listp records))
186 (defun bbdb-wl-update-records (&optional offer-to-create)
187 "Returns the records corresponding to the current WL message,
188 creating or modifying it as necessary. A record will be created if
189 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
190 the user confirms the creation."
193 (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
198 (if (buffer-live-p wl-current-summary-buffer)
199 (set-buffer wl-current-summary-buffer))
203 wl-current-summary-buffer
204 wl-message-buffer-cur-number))))
206 (or (progn (setq record (bbdb-message-cache-lookup key))
207 (if (listp record) (nth 1 record) record))
208 (static-if (not (fboundp 'bbdb-update-records))
209 (let* ((from (or (std11-field-body "From") ""))
211 (nth 1 (std11-extract-address-components
215 (string-match (bbdb-user-mail-names) addr))
216 (setq from (or (std11-field-body "To") from)))
217 (with-temp-buffer ; to keep raw buffer unibyte.
218 (elmo-set-buffer-multibyte
219 default-enable-multibyte-characters)
220 (setq from (eword-decode-string
221 (decode-mime-charset-string
225 (bbdb-encache-message
227 (bbdb-annotate-message-sender
229 (or (bbdb-invoke-hook-for-value
230 bbdb/mail-auto-create-p)
233 (bbdb-encache-message
235 (bbdb-update-records (bbdb-wl-get-addresses
236 bbdb-get-only-first-address-p)
237 (or (bbdb-invoke-hook-for-value
238 bbdb/mail-auto-create-p)
240 offer-to-create))))))))
242 (defun bbdb-wl-annotate-sender (string)
243 "Add a line to the end of the Notes field of the BBDB record
244 corresponding to the sender of this message."
245 (interactive (list (if bbdb-readonly-p
246 (error "The Insidious Big Brother Database is read-only")
247 (read-string "Comments: "))))
248 (set-buffer (wl-message-get-original-buffer))
249 (bbdb-annotate-notes (bbdb-wl-update-record t) string))
251 (defun bbdb-wl-edit-notes (&optional arg)
252 "Edit the notes field or (with a prefix arg) a user-defined field
253 of the BBDB record corresponding to the sender of this message."
255 (wl-summary-set-message-buffer-or-redisplay)
256 (set-buffer (wl-message-get-original-buffer))
257 (let ((record (or (bbdb-wl-update-record t) (error ""))))
258 (bbdb-display-records (list record))
260 (bbdb-record-edit-property record nil t)
261 (bbdb-record-edit-notes record t))))
263 (if (not (boundp 'bbdb-get-addresses-from-headers))
264 (defvar bbdb-get-addresses-from-headers
265 '("From" "Resent-From" "Reply-To")))
267 (if (not (boundp 'bbdb-get-addresses-to-headers))
268 (defvar bbdb-get-addresses-to-headers
269 '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
271 (if (not (boundp 'bbdb-get-addresses-headers))
272 (defvar bbdb-get-addresses-headers
273 (append bbdb-get-addresses-from-headers bbdb-get-addresses-to-headers)))
275 (defun bbdb-wl-show-records (&optional headers)
276 "Display the contents of the BBDB for the sender of this message.
277 This buffer will be in `bbdb-mode', with associated keybindings."
279 (wl-summary-set-message-buffer-or-redisplay)
280 (set-buffer (wl-message-get-original-buffer))
281 (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers))
282 (bbdb-update-records-mode 'annotating)
283 (bbdb-message-cache nil)
284 (bbdb-user-mail-names nil)
286 (setq records (bbdb-wl-update-records t))
289 (bbdb-wl-pop-up-bbdb-buffer)
290 (bbdb-display-records (if (listp records) records
292 (bbdb-undisplay-records))
293 (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
295 (select-window bbdb-win))
298 (defun bbdb-wl-show-all-recipients ()
299 "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
301 (bbdb-wl-show-records bbdb-get-addresses-to-headers))
303 (defun bbdb-wl-show-sender (&optional show-recipients)
304 "Display the contents of the BBDB for the senders of this message.
305 With a prefix argument show the recipients instead,
306 with two prefix arguments show all records.
307 This buffer will be in `bbdb-mode', with associated keybindings."
309 (cond ((= 4 show-recipients)
310 (bbdb-wl-show-all-recipients))
311 ((= 16 show-recipients)
312 (bbdb-wl-show-records))
314 (if (null (bbdb-wl-show-records bbdb-get-addresses-from-headers))
315 (bbdb-wl-show-all-recipients)))))
317 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
318 "Make the *BBDB* buffer be displayed along with the WL window(s),
319 displaying the record corresponding to the sender of the current message."
320 (if (get-buffer-window bbdb-buffer-name)
322 (let ((mes-win (get-buffer-window
324 (if (buffer-live-p wl-current-summary-buffer)
325 (set-buffer wl-current-summary-buffer))
327 (cur-win (selected-window))
328 (b (current-buffer)))
330 (select-window mes-win))
332 (- (window-height mes-win)
334 (- (window-height mes-win)
335 (max window-min-height
336 (1+ bbdb-pop-up-target-lines))))))
337 (split-window mes-win (if (> size 0) size window-min-height)))
338 ;; goto the bottom of the two...
339 (select-window (next-window))
340 ;; make it display *BBDB*...
341 (let ((pop-up-windows nil))
342 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
343 ;; select the original window we were in...
344 (select-window cur-win)
345 ;; and make sure the current buffer is correct as well.
347 (let ((bbdb-gag-messages t)
348 (bbdb-use-pop-up nil)
349 (bbdb-electric-p nil))
350 (let ((records (static-if (fboundp 'bbdb-update-records)
351 (bbdb-wl-update-records offer-to-create)
352 (bbdb-wl-update-record offer-to-create)))
353 (bbdb-elided-display (bbdb-pop-up-elided-display))
354 (b (current-buffer)))
355 (bbdb-display-records (if (listp records) records
360 (defun bbdb-wl-send-mail-internal (&optional to subj records)
362 (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
363 (condition-case nil (delete-other-windows) (error))))
365 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
367 (and (not (fboundp 'bbdb-wl-extract-field-value-internal))
368 ;;; (not (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
370 (if (and (string< bbdb-version "1.58")
371 ;; (not (fboundp 'bbdb-extract-field-value) ; defined as autoload
372 (not (fboundp 'bbdb-header-start)))
374 (require 'bbdb-hooks))
375 (fset 'bbdb-wl-extract-field-value-internal
377 ((fboundp 'tm:bbdb-extract-field-value)
378 (symbol-function 'tm:bbdb-extract-field-value))
379 (t (symbol-function 'bbdb-extract-field-value))))
380 (defun bbdb-extract-field-value (field)
381 (let ((value (bbdb-wl-extract-field-value-internal field)))
382 (with-temp-buffer ; to keep raw buffer unibyte.
383 (elmo-set-buffer-multibyte
384 default-enable-multibyte-characters)
386 (eword-decode-string value)))))
392 ;;; bbdb-wl.el ends here