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)
37 (defun bbdb-wl-setup ()
38 (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
39 (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
40 (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
41 (add-hook 'wl-exit-hook 'bbdb-wl-exit)
42 (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
43 (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
44 (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
45 (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
46 'bbdb-wl-show-bbdb-buffer)
47 (add-hook 'wl-summary-mode-hook
50 (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
51 (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
52 (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
53 (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
54 (add-hook 'wl-mail-setup-hook
57 ;;; (local-set-key "\M-\t" 'bbdb-complete-name)
58 (define-key (current-local-map) "\M-\t" 'bbdb-complete-name))))
59 ;; BBDB 2.00.06 or earlier:
60 ;; auto-autoloads.el includes (provide 'bbdb-autoloads)
61 ;; Don't exist bbdb-autoloads.el
62 (when (and (not (featurep 'bbdb-autoloads))
63 (module-installed-p 'bbdb-autoloads))
64 ;; BBDB 2.20: bbdb-autoloads.el NOT includes (provide 'bbdb-autoloads)
65 (load "bbdb-autoloads")))
67 (defun bbdb-wl-exit ()
69 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
70 (kill-buffer bbdb-buf)))
73 (defun bbdb-wl-get-update-record ()
74 (let ((folder-name (with-current-buffer
75 wl-message-buffer-cur-summary-buffer
76 (wl-summary-buffer-folder-name))))
77 (if (and (or (null bbdb-wl-folder-regexp)
78 (string-match bbdb-wl-folder-regexp folder-name))
79 (not (and bbdb-wl-ignore-folder-regexp
80 (string-match bbdb-wl-ignore-folder-regexp
82 (with-current-buffer (wl-message-get-original-buffer)
83 (bbdb-wl-update-record)
84 (run-hooks 'bbdb-wl-get-update-record-hook)))))
86 (defun bbdb-wl-hide-bbdb-buffer ()
87 (let (bbdb-buf bbdb-win)
88 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
89 (if (setq bbdb-win (get-buffer-window bbdb-buf))
90 (delete-window bbdb-win)))))
92 (defun bbdb-wl-show-bbdb-buffer ()
94 (if (get-buffer-window bbdb-buffer-name)
96 (let ((mes-win (get-buffer-window
98 (if (buffer-live-p wl-current-summary-buffer)
99 (set-buffer wl-current-summary-buffer))
101 (cur-win (selected-window))
102 (b (current-buffer)))
103 (and mes-win (select-window mes-win))
105 (- (window-height mes-win)
107 (- (window-height mes-win)
108 (max window-min-height
109 (1+ bbdb-pop-up-target-lines))))))
110 (split-window mes-win (if (> size 0) size window-min-height)))
111 ;; goto the bottom of the two...
112 (select-window (next-window))
113 ;; make it display *BBDB*...
114 (let ((pop-up-windows nil))
115 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
117 (defun bbdb-wl-get-petname (from)
118 "For `wl-summary-get-petname-function'."
119 (let* ((address (wl-address-header-extract-address from))
120 (record (bbdb-search-simple nil address)))
122 (or (bbdb-record-name record)
123 (car (bbdb-record-name record))))))
125 (defun bbdb-wl-from-func (string)
126 "A candidate From field STRING. For `wl-summary-from-function'."
127 (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
129 first-name last-name from-str)
132 (setq first-name (aref hit 0))
133 (setq last-name (aref hit 1))
134 (cond ((and (null first-name)
136 (setq from-str string))
137 ((and first-name last-name)
138 (setq from-str (concat first-name " " last-name)))
139 ((or first-name last-name)
140 (setq from-str (or first-name last-name))))
144 (if (not (boundp 'bbdb-get-addresses-from-headers))
145 (defvar bbdb-get-addresses-from-headers
146 '("From" "Resent-From" "Reply-To")))
148 (if (not (boundp 'bbdb-get-addresses-to-headers))
149 (defvar bbdb-get-addresses-to-headers
150 '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
152 (if (not (boundp 'bbdb-get-addresses-headers))
153 (defvar bbdb-get-addresses-headers
154 (append bbdb-get-addresses-from-headers bbdb-get-addresses-to-headers)))
156 (defun bbdb-wl-get-addresses (&optional only-first-address)
157 "Return real name and email address of sender respectively recipients.
158 If an address matches `bbdb-user-mail-names' it will be ignored.
159 The headers to search can be configured by `bbdb-get-addresses-headers'."
162 (std11-narrow-to-header)
163 (let ((headers bbdb-get-addresses-headers)
164 (uninteresting-senders bbdb-user-mail-names)
165 addrlist header structures structure fn ad)
167 (setq header (std11-fetch-field (car headers)))
169 (setq structures (std11-parse-addresses-string
170 (std11-unfold-string header)))
171 (while (and (setq structure (car structures))
172 (eq (car structure) 'mailbox))
173 (setq fn (std11-full-name-string structure)
175 (with-temp-buffer ; to keep raw buffer unibyte.
176 (elmo-set-buffer-multibyte
177 default-enable-multibyte-characters)
179 (decode-mime-charset-string
180 fn wl-mime-charset))))
181 ad (std11-address-string structure))
183 ;; ignore uninteresting addresses, this is kinda gross!
184 (when (or (not (stringp uninteresting-senders))
186 (and fn (string-match uninteresting-senders fn))
187 (and ad (string-match uninteresting-senders ad)))))
188 (add-to-list 'addrlist (list fn ad)))
190 (if (and only-first-address addrlist)
191 (setq structures nil headers nil)
192 (setq structures (cdr structures)))))
193 (setq headers (cdr headers)))
194 (nreverse addrlist)))))
196 (defun bbdb-wl-update-record (&optional offer-to-create)
197 "Returns the record corresponding to the current WL message,
198 creating or modifying it as necessary. A record will be created if
199 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
200 the user confirms the creation."
201 (let* ((bbdb-get-only-first-address-p t)
202 (records (bbdb-wl-update-records offer-to-create)))
203 (if (and records (listp records))
207 (defun bbdb-wl-update-records (&optional offer-to-create)
208 "Returns the records corresponding to the current WL message,
209 creating or modifying it as necessary. A record will be created if
210 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
211 the user confirms the creation."
214 (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
219 (if (buffer-live-p wl-current-summary-buffer)
220 (set-buffer wl-current-summary-buffer))
224 wl-current-summary-buffer
225 wl-message-buffer-cur-number))))
227 (or (progn (setq record (bbdb-message-cache-lookup key))
228 (if (listp record) (nth 1 record) record))
229 (static-if (not (fboundp 'bbdb-update-records))
230 (let* ((from (or (std11-field-body "From") ""))
232 (nth 1 (std11-extract-address-components
236 (string-match (bbdb-user-mail-names) addr))
237 (setq from (or (std11-field-body "To") from)))
238 (with-temp-buffer ; to keep raw buffer unibyte.
239 (elmo-set-buffer-multibyte
240 default-enable-multibyte-characters)
241 (setq from (eword-decode-string
242 (decode-mime-charset-string
246 (bbdb-encache-message
248 (bbdb-annotate-message-sender
250 (or (bbdb-invoke-hook-for-value
251 bbdb/mail-auto-create-p)
254 (bbdb-encache-message
256 (bbdb-update-records (bbdb-wl-get-addresses
257 bbdb-get-only-first-address-p)
258 (or (bbdb-invoke-hook-for-value
259 bbdb/mail-auto-create-p)
261 offer-to-create))))))))
263 (defun bbdb-wl-annotate-sender (string)
264 "Add a line to the end of the Notes field of the BBDB record
265 corresponding to the sender of this message."
266 (interactive (list (if bbdb-readonly-p
267 (error "The Insidious Big Brother Database is read-only")
268 (read-string "Comments: "))))
269 (set-buffer (wl-message-get-original-buffer))
270 (bbdb-annotate-notes (bbdb-wl-update-record t) string))
272 (defun bbdb-wl-edit-notes (&optional arg)
273 "Edit the notes field or (with a prefix arg) a user-defined field
274 of the BBDB record corresponding to the sender of this message."
276 (wl-summary-set-message-buffer-or-redisplay)
277 (set-buffer (wl-message-get-original-buffer))
278 (let ((record (or (bbdb-wl-update-record t) (error ""))))
279 (bbdb-display-records (list record))
281 (bbdb-record-edit-property record nil t)
282 (bbdb-record-edit-notes record t))))
284 (defun bbdb-wl-show-records (&optional headers)
285 "Display the contents of the BBDB for the sender of this message.
286 This buffer will be in `bbdb-mode', with associated keybindings."
288 (wl-summary-set-message-buffer-or-redisplay)
289 (set-buffer (wl-message-get-original-buffer))
290 (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers))
291 (bbdb-update-records-mode 'annotating)
292 (bbdb-message-cache nil)
293 (bbdb-user-mail-names nil)
295 (setq records (bbdb-wl-update-records t))
298 (bbdb-wl-pop-up-bbdb-buffer)
299 (bbdb-display-records (if (listp records) records
301 (bbdb-undisplay-records))
302 (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
304 (select-window bbdb-win))
307 (defun bbdb-wl-show-all-recipients ()
308 "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
310 (bbdb-wl-show-records bbdb-get-addresses-to-headers))
312 (defun bbdb-wl-show-sender (&optional show-recipients)
313 "Display the contents of the BBDB for the senders of this message.
314 With a prefix argument show the recipients instead,
315 with two prefix arguments show all records.
316 This buffer will be in `bbdb-mode', with associated keybindings."
318 (cond ((= 4 show-recipients)
319 (bbdb-wl-show-all-recipients))
320 ((= 16 show-recipients)
321 (bbdb-wl-show-records))
323 (if (null (bbdb-wl-show-records bbdb-get-addresses-from-headers))
324 (bbdb-wl-show-all-recipients)))))
326 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
327 "Make the *BBDB* buffer be displayed along with the WL window(s),
328 displaying the record corresponding to the sender of the current message."
329 (if (get-buffer-window bbdb-buffer-name)
331 (let ((mes-win (get-buffer-window
333 (if (buffer-live-p wl-current-summary-buffer)
334 (set-buffer wl-current-summary-buffer))
336 (cur-win (selected-window))
337 (b (current-buffer)))
339 (select-window mes-win))
341 (- (window-height mes-win)
343 (- (window-height mes-win)
344 (max window-min-height
345 (1+ bbdb-pop-up-target-lines))))))
346 (split-window mes-win (if (> size 0) size window-min-height)))
347 ;; goto the bottom of the two...
348 (select-window (next-window))
349 ;; make it display *BBDB*...
350 (let ((pop-up-windows nil))
351 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
352 ;; select the original window we were in...
353 (select-window cur-win)
354 ;; and make sure the current buffer is correct as well.
356 (let ((bbdb-gag-messages t)
357 (bbdb-use-pop-up nil)
358 (bbdb-electric-p nil))
359 (let* ((records (static-if (fboundp 'bbdb-update-records)
360 (bbdb-wl-update-records offer-to-create)
361 (bbdb-wl-update-record offer-to-create)))
362 ;; BBDB versions v2.33 and later.
364 (cond ((boundp 'bbdb-pop-up-display-layout)
365 (symbol-value 'bbdb-pop-up-display-layout))
366 ((boundp 'bbdb-pop-up-elided-display)
367 (symbol-value 'bbdb-pop-up-elided-display))))
368 ;; BBDB versions prior to v2.33,
369 (bbdb-elided-display bbdb-display-layout)
370 (b (current-buffer)))
371 (bbdb-display-records (if (listp records) records
376 (defun bbdb-wl-send-mail-internal (&optional to subj records)
378 (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
379 (condition-case nil (delete-other-windows) (error))))
381 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
384 (if (fboundp 'bbdb-wl-extract-field-value-internal)
385 ;;(if (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
387 (if (and (string< bbdb-version "1.58")
388 ;;(not (fboundp 'bbdb-extract-field-value) ;; defined as autoload
389 (not (fboundp 'bbdb-header-start)))
391 (require 'bbdb-hooks))
392 (fset 'bbdb-wl-extract-field-value-internal
394 ((fboundp 'tm:bbdb-extract-field-value)
395 (symbol-function 'tm:bbdb-extract-field-value))
396 (t (symbol-function 'bbdb-extract-field-value))))
397 (defun bbdb-extract-field-value (field)
398 (let ((value (bbdb-wl-extract-field-value-internal field)))
399 (with-temp-buffer ; to keep raw buffer unibyte.
400 (elmo-set-buffer-multibyte
401 default-enable-multibyte-characters)
403 (eword-decode-string value)))))
409 ;;; bbdb-wl.el ends here