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
27 (defvar bbdb-pop-up-elided-display nil))
28 ;; (or (fboundp 'bbdb-wl-extract-field-value-internal)
29 ;; (defun bbdb-wl-extract-field-value-internal (field))))
32 (defvar bbdb-wl-get-update-record-hook nil)
34 (defun bbdb-wl-setup ()
35 (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
36 (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
37 (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
38 (add-hook 'wl-exit-hook 'bbdb-wl-exit)
39 (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
40 (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
41 (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
42 (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
43 'bbdb-wl-show-bbdb-buffer)
44 (add-hook 'wl-summary-mode-hook
47 (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
48 (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
49 (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
50 (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
51 (add-hook 'wl-mail-setup-hook
54 ;;; (local-set-key "\M-\t" 'bbdb-complete-name)
55 (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)
58 (defun bbdb-wl-exit ()
60 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
61 (kill-buffer bbdb-buf)))
64 (defun bbdb-wl-get-update-record ()
65 (set-buffer (wl-message-get-original-buffer))
66 (bbdb-wl-update-record)
67 (run-hooks 'bbdb-wl-get-update-record-hook))
69 (defun bbdb-wl-hide-bbdb-buffer ()
70 (let (bbdb-buf bbdb-win)
71 (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
72 (if (setq bbdb-win (get-buffer-window bbdb-buf))
73 (delete-window bbdb-win)))))
75 (defun bbdb-wl-show-bbdb-buffer ()
77 (if (get-buffer-window bbdb-buffer-name)
79 (let ((mes-win (get-buffer-window
81 (if (buffer-live-p wl-current-summary-buffer)
82 (set-buffer wl-current-summary-buffer))
84 (cur-win (selected-window))
86 (and mes-win (select-window mes-win))
88 (- (window-height mes-win)
90 (- (window-height mes-win)
91 (max window-min-height
92 (1+ bbdb-pop-up-target-lines))))))
93 (split-window mes-win (if (> size 0) size window-min-height)))
94 ;; goto the bottom of the two...
95 (select-window (next-window))
96 ;; make it display *BBDB*...
97 (let ((pop-up-windows nil))
98 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
100 (defun bbdb-wl-get-petname (from)
101 "For `wl-summary-get-petname-func'."
102 (let* ((address (wl-address-header-extract-address from))
103 (record (bbdb-search-simple nil address)))
105 (or (bbdb-record-name record)
106 (car (bbdb-record-name record))))))
108 (defun bbdb-wl-from-func (string)
109 "A candidate From field STRING. For `wl-summary-from-func'."
110 (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
112 first-name last-name from-str)
115 (setq first-name (aref hit 0))
116 (setq last-name (aref hit 1))
117 (cond ((and (null first-name)
119 (setq from-str string))
120 ((and first-name last-name)
121 (setq from-str (concat first-name " " last-name)))
122 ((or first-name last-name)
123 (setq from-str (or first-name last-name))))
127 (defun bbdb-wl-update-record (&optional offer-to-create)
128 "Returns the record corresponding to the current WL message,
129 creating or modifying it as necessary. A record will be created if
130 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
131 the user confirms the creation."
134 (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
139 (if (buffer-live-p wl-current-summary-buffer)
140 (set-buffer wl-current-summary-buffer))
144 wl-current-summary-buffer
145 wl-message-buffer-cur-number)))))
146 (or (bbdb-message-cache-lookup key nil)
148 (let* ((from (or (std11-field-body "From") ""))
150 (nth 1 (std11-extract-address-components
154 (string-match (bbdb-user-mail-names) addr))
155 (setq from (or (std11-field-body "To") from)))
156 (with-temp-buffer ; to keep raw buffer unibyte.
157 (elmo-set-buffer-multibyte
158 default-enable-multibyte-characters)
159 (setq from (eword-decode-string
160 (decode-mime-charset-string
164 (bbdb-encache-message
166 (bbdb-annotate-message-sender
168 (or (bbdb-invoke-hook-for-value
169 bbdb/mail-auto-create-p)
171 offer-to-create))))))))))
173 (defun bbdb-wl-annotate-sender (string)
174 "Add a line to the end of the Notes field of the BBDB record
175 corresponding to the sender of this message."
176 (interactive (list (if bbdb-readonly-p
177 (error "The Insidious Big Brother Database is read-only")
178 (read-string "Comments: "))))
179 (set-buffer (wl-message-get-original-buffer))
180 (bbdb-annotate-notes (bbdb-wl-update-record t) string))
182 (defun bbdb-wl-edit-notes (&optional arg)
183 "Edit the notes field or (with a prefix arg) a user-defined field
184 of the BBDB record corresponding to the sender of this message."
186 (wl-summary-redisplay)
187 (set-buffer (wl-message-get-original-buffer))
188 (let ((record (or (bbdb-wl-update-record t) (error ""))))
189 (bbdb-display-records (list record))
191 (bbdb-record-edit-property record nil t)
192 (bbdb-record-edit-notes record t))))
194 (defun bbdb-wl-show-sender ()
195 "Display the contents of the BBDB for the sender of this message.
196 This buffer will be in `bbdb-mode', with associated keybindings."
198 (wl-summary-set-message-buffer-or-redisplay)
199 (set-buffer (wl-message-get-original-buffer))
200 (let ((record (bbdb-wl-update-record t))
204 (bbdb-wl-pop-up-bbdb-buffer)
205 (bbdb-display-records (list record)))
207 (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
209 (select-window bbdb-win))))
212 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
213 "Make the *BBDB* buffer be displayed along with the WL window(s),
214 displaying the record corresponding to the sender of the current message."
215 (if (get-buffer-window bbdb-buffer-name)
217 (let ((mes-win (get-buffer-window
219 (if (buffer-live-p wl-current-summary-buffer)
220 (set-buffer wl-current-summary-buffer))
222 (cur-win (selected-window))
223 (b (current-buffer)))
225 (select-window mes-win))
227 (- (window-height mes-win)
229 (- (window-height mes-win)
230 (max window-min-height
231 (1+ bbdb-pop-up-target-lines))))))
232 (split-window mes-win (if (> size 0) size window-min-height)))
233 ;; goto the bottom of the two...
234 (select-window (next-window))
235 ;; make it display *BBDB*...
236 (let ((pop-up-windows nil))
237 (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
238 ;; select the original window we were in...
239 (select-window cur-win)
240 ;; and make sure the current buffer is correct as well.
242 (let ((bbdb-gag-messages t)
243 (bbdb-use-pop-up nil)
244 (bbdb-electric-p nil))
245 (let ((record (bbdb-wl-update-record offer-to-create))
246 (bbdb-elided-display (bbdb-pop-up-elided-display))
247 (b (current-buffer)))
248 (bbdb-display-records (if record (list record) nil))
252 (defun bbdb-wl-send-mail-internal (&optional to subj records)
254 (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
255 (condition-case nil (delete-other-windows) (error))))
257 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
259 (if (and (string< bbdb-version "1.58")
260 ;; (not (fboundp 'bbdb-extract-field-value) ; defined as autoload
261 (not (fboundp 'bbdb-header-start)))
264 (require 'bbdb-hooks)))
266 (static-cond ((fboundp 'tm:bbdb-extract-field-value)
267 (defun bbdb-wl-extract-field-value-internal (field)
268 (funcall (symbol-function 'tm:bbdb-extract-field-value)
271 (defun bbdb-wl-extract-field-value-internal (field)
272 (funcall (symbol-function 'bbdb-extract-field-value)
275 (defun bbdb-extract-field-value (field)
276 (let ((value (bbdb-wl-extract-field-value-internal field)))
277 (with-temp-buffer ; to keep raw buffer unibyte.
278 (elmo-set-buffer-multibyte
279 default-enable-multibyte-characters)
281 (eword-decode-string value)))))
286 ;;; bbdb-wl.el ends here