[emacs] manually add bbdb into lisp/bbdb/
[~bandali/configs] / lisp / bbdb / bbdb-mua.el
CommitLineData
1a5de666
AB
1;;; bbdb-mua.el --- various MUA functionality for BBDB -*- lexical-binding: t -*-
2
3;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
4
5;; This file is part of the Insidious Big Brother Database (aka BBDB),
6
7;; BBDB is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; BBDB is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21;; This file provides various additional functionality for BBDB
22;; See the BBDB info manual for documentation.
23
24;; This file lets you do stuff like
25;;
26;; o automatically add some string to some field(s) based on the
27;; contents of header fields of the current message
28;; o only automatically create records when certain header fields
29;; are matched
30;; o do not automatically create records when certain header fields
31;; are matched
32;;
33;; Read the docstrings; read the texinfo file.
34
35;;; Code:
36
37(require 'bbdb)
38(require 'bbdb-com)
39
40(eval-and-compile
41 (autoload 'gnus-fetch-original-field "gnus-utils")
42 (autoload 'gnus-summary-select-article "gnus-sum")
43 (defvar gnus-article-buffer)
44
45 (autoload 'bbdb/vm-header "bbdb-vm")
46 (autoload 'vm-follow-summary-cursor "vm-motion")
47 (autoload 'vm-select-folder-buffer "vm-macro")
48 (autoload 'vm-check-for-killed-summary "vm-misc")
49 (autoload 'vm-error-if-folder-empty "vm-misc")
50
51 (autoload 'bbdb/rmail-header "bbdb-rmail")
52 (defvar rmail-buffer)
53
54 (autoload 'bbdb/mh-header "bbdb-mhe")
55 (autoload 'mh-show "mh-show")
56 (defvar mh-show-buffer)
57
58 (defvar mu4e~view-buffer-name)
59
60 (autoload 'bbdb/wl-header "bbdb-wl")
61
62 (autoload 'message-field-value "message")
63 (autoload 'mail-decode-encoded-word-string "mail-parse"))
64
65(defconst bbdb-mua-mode-alist
66 '((vm vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode)
67 (gnus gnus-summary-mode gnus-article-mode gnus-tree-mode)
68 (rmail rmail-mode rmail-summary-mode)
69 (mh mhe-mode mhe-summary-mode mh-folder-mode)
70 (mu4e mu4e-view-mode) ; Tackle `mu4e-headers-mode' later
71 (wl wl-summary-mode wl-draft-mode)
72 (message message-mode mu4e-compose-mode notmuch-message-mode)
73 (mail mail-mode))
74 "Alist of MUA modes supported by BBDB.
75Each element is of the form (MUA MODE MODE ...), where MODEs are used by MUA.")
76
77(defun bbdb-mua ()
78 "For the current message return the MUA.
79Return values include
80 gnus Newsreader Gnus
81 rmail Reading Mail in Emacs
82 vm Viewmail
83 mh Emacs interface to the MH mail system (aka MH-E)
84 mu4e Mu4e
85 wl Wanderlust
86 message Mail and News composition mode that goes with Gnus
87 mail Emacs Mail Mode."
88 (let ((mm-alist bbdb-mua-mode-alist)
89 elt mua)
90 (while (setq elt (pop mm-alist))
91 (if (memq major-mode (cdr elt))
92 (setq mua (car elt)
93 mm-alist nil)))
94 (or mua (error "BBDB: MUA `%s' not supported" major-mode))))
95
96;;;###autoload
97(defun bbdb-message-header (header)
98 "For the current message return the value of HEADER.
99MIME encoded headers are decoded. Return nil if HEADER does not exist."
100 ;; RW: If HEADER was allowed to be a regexp and the content of multiple
101 ;; matching headers was concatenated as in `message-field-value',
102 ;; this would simplify the usage of `bbdb-accept-message-alist' and
103 ;; `bbdb-ignore-message-alist'.
104 ;; RW: If this function had a remember table, it could look up the value
105 ;; of a header if we request the value of the same header multiple times.
106 ;; (We would reset the remember table each time we move on to a new message.)
107 (let* ((mua (bbdb-mua))
108 (val (cond (;; It seems that `gnus-fetch-field' fetches decoded content of
109 ;; `gnus-visible-headers', ignoring `gnus-ignored-headers'.
110 ;; Here we use instead `gnus-fetch-original-field' that fetches
111 ;; the encoded content of `gnus-original-article-buffer'.
112 ;; Decoding makes this possibly a bit slower, but something like
113 ;; `bbdb-select-message' does not get fooled by an apparent
114 ;; absence of some headers.
115 ;; See http://permalink.gmane.org/gmane.emacs.gnus.general/78741
116 (eq mua 'gnus) (gnus-fetch-original-field header))
117 ((eq mua 'vm) (bbdb/vm-header header))
118 ((eq mua 'rmail) (bbdb/rmail-header header))
119 ((eq mua 'mh) (bbdb/mh-header header))
120 ((eq mua 'mu4e) (message-field-value header))
121 ((eq mua 'wl) (bbdb/wl-header header))
122 ((memq mua '(message mail)) (message-field-value header))
123 (t (error "BBDB/%s: header function undefined" mua)))))
124 (if val (mail-decode-encoded-word-string val))))
125
126(defsubst bbdb-message-header-re (header regexp)
127 "Return non-nil if REGEXP matches value of HEADER."
128 (let ((val (bbdb-message-header header))
129 (case-fold-search t)) ; RW: Is this what we want?
130 (and val (string-match regexp val))))
131
132;;; Update database
133
134;;;###autoload
135(defun bbdb-accept-message (&optional invert)
136 "For use with variable `bbdb-mua-update-interactive-p' and friends.
137Return the value of variable `bbdb-update-records-p' for messages matching
138`bbdb-accept-message-alist'. If INVERT is non-nil, accept messages
139not matching `bbdb-ignore-message-alist'."
140 (let ((rest (if invert bbdb-ignore-message-alist
141 bbdb-accept-message-alist))
142 done elt)
143 (if (eq rest t)
144 (setq done t)
145 (while (and (setq elt (pop rest)) (not done))
146 (dolist (header (if (stringp (car elt)) (list (car elt)) (car elt)))
147 (if (bbdb-message-header-re header (cdr elt))
148 (setq done t)))))
149 (if invert (setq done (not done)))
150 (if done bbdb-update-records-p)))
151
152;;;###autoload
153(defun bbdb-ignore-message (&optional invert)
154 "For use with variable `bbdb-mua-update-interactive-p' and friends.
155Return the value of variable `bbdb-update-records-p' for messages not matching
156`bbdb-ignore-message-alist'. If INVERT is non-nil, accept messages
157matching `bbdb-accept-message-alist'."
158 (bbdb-accept-message (not invert)))
159
160;;;###autoload
161(defun bbdb-select-message ()
162 "For use with variable `bbdb-mua-update-interactive-p' and friends.
163Return the value of variable `bbdb-update-records-p' for messages both matching
164`bbdb-accept-message-alist' and not matching `bbdb-ignore-message-alist'."
165 (and (bbdb-accept-message)
166 (bbdb-ignore-message)))
167
168(defun bbdb-get-address-components (&optional header-class ignore-address)
169 "Extract mail addresses from a message.
170Return list with elements (NAME EMAIL HEADER HEADER-CLASS MUA).
171HEADER-CLASS is defined in `bbdb-message-headers'. If HEADER-CLASS is nil,
172use all classes in `bbdb-message-headers'.
173If regexp IGNORE-ADDRESS matches NAME or EMAIL of an address, this address
174is ignored. If IGNORE-ADDRESS is nil, use value of `bbdb-user-mail-address-re'."
175 ;; We do not use `bbdb-message-all-addresses' here because only when we
176 ;; have compared the addresses with the records in BBDB do we know which
177 ;; address(es) are relevant for us.
178 (let ((message-headers (if header-class
179 (list (assoc header-class bbdb-message-headers))
180 bbdb-message-headers))
181 (mua (bbdb-mua))
182 (ignore-address (or ignore-address bbdb-user-mail-address-re))
183 address-list name mail mail-list content)
184 (dolist (headers message-headers)
185 (dolist (header (cdr headers))
186 (when (setq content (bbdb-message-header header))
187 ;; Always extract all addresses because we do not know yet which
188 ;; address might match IGNORE-ADDRESS.
189 (dolist (address (bbdb-extract-address-components content t))
190 ;; We canonicalize name and mail as early as possible.
191 (setq name (car address)
192 mail (cadr address))
193 ;; ignore uninteresting addresses
194 (unless (or (and (stringp ignore-address)
195 (or (and name (string-match ignore-address name))
196 (and mail (string-match ignore-address mail))))
197 (and mail (member-ignore-case mail mail-list)))
198 ;; Add each address only once. (Use MAIL-LIST for book keeping.)
199 ;; Thus if we care about whether an address gets associated with
200 ;; one or another header, the order of elements in
201 ;; `bbdb-message-headers' is relevant. The "most important"
202 ;; headers should be first in `bbdb-message-headers'.
203 (if mail (push mail mail-list))
204 (push (list name mail header (car headers) mua) address-list))))))
205 (or (nreverse address-list)
206 (and header-class bbdb-message-try-all-headers
207 ;; Try again the remaining header classes
208 (let ((bbdb-message-headers
209 (remove (assoc header-class bbdb-message-headers)
210 bbdb-message-headers)))
211 (bbdb-get-address-components nil ignore-address))))))
212
213;;;###autoload
214(defun bbdb-update-records (address-list &optional update-p sort)
215 "Return the list of BBDB records matching ADDRESS-LIST.
216ADDRESS-LIST is a list of mail addresses. (It can be extracted from
217a mail message using `bbdb-get-address-components'.)
218UPDATE-P may take the following values:
219 search Search for existing records matching ADDRESS.
220 update Search for existing records matching ADDRESS;
221 update name and mail field if necessary.
222 query Search for existing records matching ADDRESS;
223 query for creation of a new record if the record does not exist.
224 create or t Search for existing records matching ADDRESS;
225 create a new record if it does not yet exist.
226 nil Do nothing.
227 a function This functions will be called with no arguments.
228 It should return one of the above values.
229
230If SORT is non-nil, sort records according to `bbdb-record-lessp'.
231Ottherwise, the records are ordered according to ADDRESS-LIST.
232
233Usually this function is called by the wrapper `bbdb-mua-update-records'."
234 ;; UPDATE-P allows filtering of complete messages.
235 ;; Filtering of individual addresses within an accepted message
236 ;; is done by `bbdb-get-address-components' using `bbdb-user-mail-address-re'.
237 ;; We resolve UPDATE-P repeatedly. This is needed, for example,
238 ;; with the chain `bbdb-mua-auto-update-p' -> `bbdb-select-message'
239 ;; -> `bbdb-update-records-p'.
240 (while (and (functionp update-p)
241 ;; Bad! `search' is a function in `cl-seq.el'.
242 (not (eq update-p 'search)))
243 (setq update-p (funcall update-p)))
244 (cond ((eq t update-p)
245 (setq update-p 'create))
246 ((not (memq update-p '(search update query create nil)))
247 (error "Illegal value of arg update-p: %s" update-p)))
248
249 (let (;; `bbdb-update-records-p' and `bbdb-offer-to-create' are used here
250 ;; as internal variables for communication with `bbdb-query-create'.
251 ;; This does not affect the value of the global user variable
252 ;; `bbdb-update-records-p'.
253 (bbdb-offer-to-create 'start)
254 (bbdb-update-records-p update-p)
255 address records)
256
257 (when update-p
258 (while (setq address (pop address-list))
259 (let* ((bbdb-update-records-address address)
260 hits
261 (task
262 (catch 'done
263 (setq hits
264 ;; We put the call of `bbdb-notice-mail-hook'
265 ;; into `bbdb-annotate-message' so that this hook
266 ;; runs only if the user agreed to change a record.
267 (cond ((or bbdb-read-only
268 (eq bbdb-update-records-p 'search))
269 ;; Search for records having this mail address
270 ;; but do not modify an existing record.
271 ;; This does not run `bbdb-notice-mail-hook'.
272 (bbdb-message-search (car address)
273 (cadr address)))
274 ((eq bbdb-update-records-p 'update)
275 (bbdb-annotate-message address 'update))
276 ((eq bbdb-update-records-p 'query)
277 (bbdb-annotate-message
278 address 'bbdb-query-create))
279 ((eq bbdb-update-records-p 'create)
280 (bbdb-annotate-message address 'create))))
281 nil)))
282 (cond ((eq task 'quit)
283 (setq address-list nil))
284 ((not (eq task 'next))
285 (dolist (hit (delq nil (nreverse hits)))
286 (bbdb-pushnew hit records))))
287 (if (and records (not bbdb-message-all-addresses))
288 (setq address-list nil))))
289 (setq records
290 (if sort (sort records 'bbdb-record-lessp)
291 ;; Make RECORDS a list ordered like ADDRESS-LIST.
292 (nreverse records))))
293
294 ;; `bbdb-message-search' might yield multiple records
295 (if (and records (not bbdb-message-all-addresses))
296 (setq records (list (car records))))
297
298 (unless bbdb-read-only
299 (bbdb-editable)
300 (dolist (record records)
301 (run-hook-with-args 'bbdb-notice-record-hook record)))
302
303 records))
304
305(defun bbdb-query-create ()
306 "Interactive query used by `bbdb-update-records'.
307Return t if the record should be created or `nil' otherwise.
308Honor previous answers such as `!'."
309 (let ((task bbdb-offer-to-create))
310 ;; If we have remembered what the user typed previously,
311 ;; `bbdb-offer-to-create' holds a character, i.e., a number.
312 ;; -- Right now, we only remember "!".
313 (when (not (integerp task))
314 (let ((prompt (format "%s is not in BBDB; add? (y,!,n,s,q,?) "
315 (or (nth 0 bbdb-update-records-address)
316 (nth 1 bbdb-update-records-address))))
317 event)
318 (while (not event)
319 (setq event (read-key-sequence prompt))
320 (setq event (if (stringp event) (aref event 0))))
321 (setq task event)
322 (message ""))) ; clear the message buffer
323
324 (cond ((eq task ?y)
325 t)
326 ((eq task ?!)
327 (setq bbdb-offer-to-create task)
328 t)
329 ((or (eq task ?n)
330 (eq task ?\s))
331 (throw 'done 'next))
332 ((or (eq task ?q)
333 (eq task ?\a)) ; ?\a = C-g
334 (throw 'done 'quit))
335 ((eq task ?s)
336 (setq bbdb-update-records-p 'search)
337 (throw 'done 'next))
338 (t ; any other key sequence
339 (save-window-excursion
340 (let* ((buffer (get-buffer-create " *BBDB Help*"))
341 (window (or (get-buffer-window buffer)
342 (split-window (get-lru-window)))))
343 (with-current-buffer buffer
344 (special-mode)
345 (let (buffer-read-only)
346 (erase-buffer)
347 (insert
348 "Your answer controls how BBDB updates/searches for records.
349
350Type ? for this help.
351Type y to add the current record.
352Type ! to add all remaining records.
353Type n to skip the current record. (You might also type space)
354Type s to switch from annotate to search mode.
355Type q to quit updating records. No more search or annotation is done.")
356 (set-buffer-modified-p nil)
357 (goto-char (point-min)))
358 (set-window-buffer window buffer)
359 (fit-window-to-buffer window)))
360 ;; Try again!
361 (bbdb-query-create))))))
362
363\f
364
365(defun bbdb-annotate-message (address &optional update-p)
366 "Fill the records for message ADDRESS with as much info as possible.
367If a record for ADDRESS does not yet exist, UPDATE-P controls whether
368a new record is created for ADDRESS. UPDATE-P may take the values:
369 update or nil Update existing records, never create a new record.
370 query Query interactively whether to create a new record.
371 create or t Create a new record.
372 a function This functions will be called with no arguments.
373 It should return one of the above values.
374Return the records matching ADDRESS or nil."
375 (let* ((mail (nth 1 address)) ; possibly nil
376 (name (unless (equal mail (car address))
377 (car address)))
378 (records (bbdb-message-search name mail))
379 created-p new-records)
380 (if (and (not records) (functionp update-p))
381 (setq update-p (funcall update-p)))
382 (cond ((eq t update-p) (setq update-p 'create))
383 ((not update-p) (setq update-p 'update)))
384
385 ;; Create a new record if nothing else fits.
386 ;; In this way, we can fill the slots of the new record with
387 ;; the same code that updates the slots of existing records.
388 (unless (or records
389 (eq update-p 'update)
390 (not (or name mail)))
391 ;; If there is no name, try to use the mail address as name
392 (if (and bbdb-message-mail-as-name mail
393 (or (null name)
394 (string= "" name)))
395 (setq name (funcall bbdb-message-clean-name-function mail)))
396 (if (or (eq update-p 'create)
397 (and (eq update-p 'query)
398 (y-or-n-p (format "%s is not in the BBDB. Add? "
399 (or name mail)))))
400 (setq records (list (bbdb-empty-record))
401 created-p t)))
402
403 (dolist (record records)
404 (let* ((old-name (bbdb-record-name record))
405 (fullname (bbdb-divide-name (or name "")))
406 (fname (car fullname))
407 (lname (cdr fullname))
408 (mail mail) ;; possibly changed below
409 (created-p created-p)
410 (update-p update-p)
411 change-p add-mails add-name ignore-redundant)
412
413 ;; Analyze the name part of the record.
414 (cond ((or (not name)
415 ;; The following tests can differ for more complicated names
416 (bbdb-string= name old-name)
417 (and (equal fname (bbdb-record-firstname record)) ; possibly
418 (equal lname (bbdb-record-lastname record))) ; nil
419 (member-ignore-case name (bbdb-record-aka record)))) ; do nothing
420
421 (created-p ; new record
422 (bbdb-record-set-field record 'name (cons fname lname)))
423
424 ((not (setq add-name (bbdb-add-job bbdb-add-name record name)))) ; do nothing
425
426 ((numberp add-name)
427 (unless bbdb-silent
428 (message "name mismatch: \"%s\" changed to \"%s\""
429 old-name name)
430 (sit-for add-name)))
431
432 ((bbdb-eval-spec add-name
433 (if old-name
434 (format "Change name \"%s\" to \"%s\"? "
435 old-name name)
436 (format "Assign name \"%s\" to address \"%s\"? "
437 name (car (bbdb-record-mail record)))))
438 ;; Keep old-name as AKA?
439 (when (and old-name
440 (not (member-ignore-case old-name (bbdb-record-aka record))))
441 (if (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record old-name)
442 (format "Keep name \"%s\" as an AKA? " old-name))
443 (bbdb-record-set-field
444 record 'aka (cons old-name (bbdb-record-aka record)))
445 (bbdb-remhash old-name record)))
446 (bbdb-record-set-field record 'name (cons fname lname))
447 (setq change-p 'name))
448
449 ;; make new name an AKA?
450 ((and old-name
451 (not (member-ignore-case name (bbdb-record-aka record)))
452 (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record name)
453 (format "Make \"%s\" an alternate for \"%s\"? "
454 name old-name)))
455 (bbdb-record-set-field
456 record 'aka (cons name (bbdb-record-aka record)))
457 (setq change-p 'name)))
458
459 ;; Is MAIL redundant compared with the mail addresses
460 ;; that are already known for RECORD?
461 (if (and mail
462 (setq ignore-redundant
463 (bbdb-add-job bbdb-ignore-redundant-mails record mail)))
464 (let ((mails (bbdb-record-mail-canon record))
465 (case-fold-search t) redundant ml re)
466 (while (setq ml (pop mails))
467 (if (and (setq re (bbdb-mail-redundant-re ml))
468 (string-match re mail))
469 (setq redundant ml mails nil)))
470 (if redundant
471 (cond ((numberp ignore-redundant)
472 (unless bbdb-silent
473 (message "%s: redundant mail `%s'"
474 (bbdb-record-name record) mail)
475 (sit-for ignore-redundant)))
476 ((or (eq t ignore-redundant)
477 bbdb-silent
478 (y-or-n-p (format "Ignore redundant mail %s?" mail)))
479 (setq mail redundant))))))
480
481 ;; Analyze the mail part of the new records
482 (cond ((or (not mail) (equal mail "???")
483 (member-ignore-case mail (bbdb-record-mail-canon record)))) ; do nothing
484
485 (created-p ; new record
486 (bbdb-record-set-field record 'mail (list mail)))
487
488 ((not (setq add-mails (bbdb-add-job bbdb-add-mails record mail)))) ; do nothing
489
490 ((numberp add-mails)
491 (unless bbdb-silent
492 (message "%s: new address `%s'"
493 (bbdb-record-name record) mail)
494 (sit-for add-mails)))
495
496 ((or (eq add-mails t) ; add it automatically
497 bbdb-silent
498 (y-or-n-p (format "Add address \"%s\" to %s? " mail
499 (bbdb-record-name record)))
500 (and (or (and (functionp update-p)
501 (progn (setq update-p (funcall update-p)) nil))
502 (memq update-p '(t create))
503 (and (eq update-p 'query)
504 (y-or-n-p
505 (format "Create a new record for %s? "
506 (bbdb-record-name record)))))
507 (progn
508 (setq record (bbdb-empty-record))
509 (bbdb-record-set-name record fname lname)
510 (setq created-p t))))
511
512 (let ((mails (bbdb-record-mail record)))
513 (if ignore-redundant
514 ;; Does the new address MAIL make an old address redundant?
515 (let ((mail-re (bbdb-mail-redundant-re mail))
516 (case-fold-search t) okay redundant)
517 (dolist (ml mails)
518 (if (string-match mail-re ml) ; redundant mail address
519 (push ml redundant)
520 (push ml okay)))
521 (let ((form (format "redundant mail%s %s"
522 (if (< 1 (length redundant)) "s" "")
523 (bbdb-concat 'mail (nreverse redundant))))
524 (name (bbdb-record-name record)))
525 (if redundant
526 (cond ((numberp ignore-redundant)
527 (unless bbdb-silent
528 (message "%s: %s" name form)
529 (sit-for ignore-redundant)))
530 ((or (eq t ignore-redundant)
531 bbdb-silent
532 (y-or-n-p (format "Delete %s: " form)))
533 (if (eq t ignore-redundant)
534 (message "%s: deleting %s" name form))
535 (setq mails okay)))))))
536
537 ;; then modify RECORD
538 (bbdb-record-set-field
539 record 'mail
540 (if (and mails
541 (bbdb-eval-spec (bbdb-add-job bbdb-new-mails-primary
542 record mail)
543 (format "Make \"%s\" the primary address? " mail)))
544 (cons mail mails)
545 (nconc mails (list mail))))
546 (unless change-p (setq change-p t)))))
547
548 (cond (created-p
549 (unless bbdb-silent
550 (if (bbdb-record-name record)
551 (message "created %s's record with address \"%s\""
552 (bbdb-record-name record) mail)
553 (message "created record with naked address \"%s\"" mail)))
554 (bbdb-change-record record))
555
556 (change-p
557 (unless bbdb-silent
558 (cond ((eq change-p 'name)
559 (message "noticed \"%s\"" (bbdb-record-name record)))
560 ((bbdb-record-name record)
561 (message "noticed %s's address \"%s\""
562 (bbdb-record-name record) mail))
563 (t
564 (message "noticed naked address \"%s\"" mail))))
565 (bbdb-change-record record)))
566
567 (run-hook-with-args 'bbdb-notice-mail-hook record)
568 (push record new-records)))
569
570 (nreverse new-records)))
571
572(defun bbdb-mua-update-records (&optional header-class update-p sort)
573 "Wrapper for `bbdb-update-records'.
574HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
575use all classes in `bbdb-message-headers'.
576UPDATE-P is defined in `bbdb-update-records'.
577If SORT is non-nil, sort records according to `bbdb-record-lessp'."
578 (let ((mua (bbdb-mua)))
579 (save-current-buffer
580 (cond ;; VM
581 ((eq mua 'vm)
582 (vm-select-folder-buffer)
583 (vm-check-for-killed-summary)
584 (vm-error-if-folder-empty)
585 (let ((enable-local-variables t)) ; ...or vm bind this to nil.
586 (bbdb-update-records (bbdb-get-address-components header-class)
587 update-p sort)))
588 ;; Gnus
589 ((eq mua 'gnus)
590 (set-buffer gnus-article-buffer)
591 (bbdb-update-records (bbdb-get-address-components header-class)
592 update-p sort))
593 ;; MH-E
594 ((eq mua 'mh)
595 (if mh-show-buffer (set-buffer mh-show-buffer))
596 (bbdb-update-records (bbdb-get-address-components header-class)
597 update-p sort))
598 ;; Rmail
599 ((eq mua 'rmail)
600 (set-buffer rmail-buffer)
601 (bbdb-update-records (bbdb-get-address-components header-class)
602 update-p sort))
603 ;; mu4e
604 ((eq mua 'mu4e)
605 (set-buffer mu4e~view-buffer-name)
606 (bbdb-update-records (bbdb-get-address-components header-class)
607 update-p sort))
608 ;; Wanderlust
609 ((eq mua 'wl)
610 (bbdb-update-records (bbdb-get-address-components header-class)
611 update-p sort))
612 ;; Message and Mail
613 ((memq mua '(message mail))
614 (bbdb-update-records (bbdb-get-address-components header-class)
615 update-p sort))))))
616
617(defmacro bbdb-mua-wrapper (&rest body)
618 "Perform BODY in a MUA buffer."
619 (declare (debug t))
620 `(let ((mua (bbdb-mua)))
621 ;; Here we replicate BODY multiple times which gets clumsy
622 ;; for a larger BODY!
623 (cond ((eq mua 'gnus)
624 ;; This fails in *Article* buffers, where
625 ;; `gnus-article-read-summary-keys' provides an additional wrapper
626 (save-current-buffer
627 (gnus-summary-select-article) ; sets buffer `gnus-summary-buffer'
628 ,@body))
629 ((memq mua '(mail message rmail mh vm mu4e wl))
630 (cond ((eq mua 'vm) (vm-follow-summary-cursor))
631 ((eq mua 'mh) (mh-show)))
632 ;; rmail, mail, message, mu4e and wl do not require any wrapper
633 ,@body))))
634
635(defun bbdb-mua-update-interactive-p ()
636 "Interactive spec for arg UPDATE-P of `bbdb-mua-display-records' and friends.
637If these commands are called without a prefix, the value of their arg
638UPDATE-P is the car of the variable `bbdb-mua-update-interactive-p'.
639Called with a prefix, the value of UPDATE-P is the cdr of this variable."
640 (let ((update-p (if current-prefix-arg
641 (cdr bbdb-mua-update-interactive-p)
642 (car bbdb-mua-update-interactive-p))))
643 (if (eq update-p 'read)
644 (let ((str (completing-read "Action: " '((query) (search) (create))
645 nil t)))
646 (unless (string= "" str) (intern str))) ; nil otherwise
647 update-p)))
648
649(defun bbdb-mua-window-p ()
650 "Return lambda function matching the MUA window.
651This return value can be used as arg HORIZ-P of `bbdb-display-records'."
652 (let ((mm-alist bbdb-mua-mode-alist)
653 elt fun)
654 (while (setq elt (cdr (pop mm-alist)))
655 (if (memq major-mode elt)
656 (setq fun `(lambda (window)
657 (with-current-buffer (window-buffer window)
658 (memq major-mode ',elt)))
659 mm-alist nil)))
660 fun))
661
662;;;###autoload
663(defun bbdb-mua-display-records (&optional header-class update-p all)
664 "Display the BBDB record(s) for the addresses in this message.
665This looks into the headers of a message according to HEADER-CLASS.
666Then for the mail addresses found the corresponding BBDB records are displayed.
667UPDATE-P determines whether only existing BBDB records are displayed
668or whether also new records are created for these mail addresses.
669
670HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
671use all classes in `bbdb-message-headers'.
672UPDATE-P may take the same values as `bbdb-update-records-p'.
673For interactive calls, see function `bbdb-mua-update-interactive-p'.
674If ALL is non-nil, bind `bbdb-message-all-addresses' to ALL."
675 (interactive (list nil (bbdb-mua-update-interactive-p)))
676 (let ((bbdb-pop-up-window-size bbdb-mua-pop-up-window-size)
677 (bbdb-message-all-addresses (or all bbdb-message-all-addresses))
678 records)
679 (bbdb-mua-wrapper
680 (setq records (bbdb-mua-update-records header-class update-p t)))
681 (if records (bbdb-display-records records nil nil nil (bbdb-mua-window-p)))
682 records))
683
684;; The following commands are some frontends for `bbdb-mua-display-records',
685;; which is always doing the real work. In your init file, you can further
686;; modify or adapt these simple commands to your liking.
687
688;;;###autoload
689(defun bbdb-mua-display-sender (&optional update-p)
690 "Display the BBDB record(s) for the sender of this message.
691UPDATE-P may take the same values as `bbdb-update-records-p'.
692For interactive calls, see function `bbdb-mua-update-interactive-p'."
693 (interactive (list (bbdb-mua-update-interactive-p)))
694 (bbdb-mua-display-records 'sender update-p))
695
696;;;###autoload
697(defun bbdb-mua-display-recipients (&optional update-p)
698 "Display the BBDB record(s) for the recipients of this message.
699UPDATE-P may take the same values as `bbdb-update-records-p'.
700For interactive calls, see function `bbdb-mua-update-interactive-p'."
701 (interactive (list (bbdb-mua-update-interactive-p)))
702 (bbdb-mua-display-records 'recipients update-p))
703
704;;;###autoload
705(defun bbdb-mua-display-all-records (&optional update-p)
706 "Display the BBDB record(s) for all addresses in this message.
707UPDATE-P may take the same values as `bbdb-update-records-p'.
708For interactive calls, see function `bbdb-mua-update-interactive-p'."
709 (interactive (list (bbdb-mua-update-interactive-p)))
710 (bbdb-mua-display-records nil update-p t))
711
712;;;###autoload
713(defun bbdb-mua-display-all-recipients (&optional update-p)
714 "Display BBDB records for all recipients of this message.
715UPDATE-P may take the same values as `bbdb-update-records-p'.
716For interactive calls, see function `bbdb-mua-update-interactive-p'."
717 (interactive (list (bbdb-mua-update-interactive-p)))
718 (bbdb-mua-display-records 'recipients update-p t))
719
720;; The commands `bbdb-annotate-record' and `bbdb-mua-edit-field'
721;; have kind of similar goals, yet they use rather different strategies.
722;; `bbdb-annotate-record' is less obtrusive. It does not display
723;; the records it operates on, nor does it display the content
724;; of the field before or after adding or replacing the annotation.
725;; Hence the user needs to know what she is doing.
726;; `bbdb-mua-edit-field' is more explicit: It displays the records
727;; as well as the current content of the field that gets edited.
728
729;; In principle, this function can be used not only with MUAs.
730(defun bbdb-annotate-record (record annotation &optional field replace)
731 "In RECORD add an ANNOTATION to field FIELD.
732FIELD defaults to `bbdb-annotate-field'.
733If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
734If ANNOTATION is an empty string and REPLACE is non-nil, delete FIELD."
735 (if (memq field '(name firstname lastname phone address xfields))
736 (error "Field `%s' illegal" field))
737 (setq annotation (bbdb-string-trim annotation))
738 (cond ((memq field '(affix organization mail aka))
739 (setq annotation (list annotation)))
740 ((not field) (setq field bbdb-annotate-field)))
741 (bbdb-record-set-field record field annotation (not replace))
742 (bbdb-change-record record))
743
744;; FIXME: For interactive calls of the following commands, the arg UPDATE-P
745;; should have the same meaning as for `bbdb-mua-display-records',
746;; that is, it should use `bbdb-mua-update-interactive-p'.
747;; But here the prefix arg is already used in a different way.
748;; We could possibly solve this problem if all `bbdb-mua-*' commands
749;; used another prefix arg that is consistently used only for
750;; `bbdb-mua-update-interactive-p'.
751;; Yet this prefix arg must be defined within the key space of the MUA(s).
752;; This results in lots of conflicts...
753;;
754;; Current workaround:
755;; These commands use merely the car of `bbdb-mua-update-interactive-p'.
756;; If one day someone proposes a smart solution to this problem (suggestions
757;; welcome!), this solution will hopefully include the current workaround
758;; as a subset of all its features.
759
760(defun bbdb-mua-annotate-field-interactive ()
761 "Interactive specification for `bbdb-mua-annotate-sender' and friends."
762 (bbdb-editable)
763 (let ((field (if (eq 'all-fields bbdb-annotate-field)
764 (intern (completing-read
765 "Field: "
766 (mapcar 'symbol-name
767 (append '(affix organization mail aka)
768 bbdb-xfield-label-list))))
769 bbdb-annotate-field)))
770 (list (read-string (format "Annotate `%s': " field))
771 field current-prefix-arg
772 (car bbdb-mua-update-interactive-p))))
773
774;;;###autoload
775(defun bbdb-mua-annotate-sender (annotation &optional field replace update-p)
776 "Add ANNOTATION to field FIELD of the BBDB record(s) of message sender(s).
777FIELD defaults to `bbdb-annotate-field'.
778If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
779UPDATE-P may take the same values as `bbdb-update-records-p'.
780For interactive calls, use car of `bbdb-mua-update-interactive-p'."
781 (interactive (bbdb-mua-annotate-field-interactive))
782 (bbdb-mua-wrapper
783 (dolist (record (bbdb-mua-update-records 'sender update-p))
784 (bbdb-annotate-record record annotation field replace))))
785
786;;;###autoload
787(defun bbdb-mua-annotate-recipients (annotation &optional field replace
788 update-p)
789 "Add ANNOTATION to field FIELD of the BBDB records of message recipients.
790FIELD defaults to `bbdb-annotate-field'.
791If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
792UPDATE-P may take the same values as `bbdb-update-records-p'.
793For interactive calls, use car of `bbdb-mua-update-interactive-p'."
794 (interactive (bbdb-mua-annotate-field-interactive))
795 (bbdb-mua-wrapper
796 (dolist (record (bbdb-mua-update-records 'recipients update-p))
797 (bbdb-annotate-record record annotation field replace))))
798
799(defun bbdb-mua-edit-field-interactive ()
800 "Interactive specification for command `bbdb-mua-edit-field' and friends."
801 (bbdb-editable)
802 (list (if (eq 'all-fields bbdb-mua-edit-field)
803 (intern (completing-read
804 "Field: "
805 (mapcar 'symbol-name
806 (append '(name affix organization aka mail)
807 bbdb-xfield-label-list))))
808 bbdb-mua-edit-field)
809 (bbdb-mua-update-interactive-p)))
810
811;;;###autoload
812(defun bbdb-mua-edit-field (&optional field update-p header-class)
813 "Edit FIELD of the BBDB record(s) of message sender(s) or recipients.
814FIELD defaults to value of variable `bbdb-mua-edit-field'.
815UPDATE-P may take the same values as `bbdb-update-records-p'.
816For interactive calls, see function `bbdb-mua-update-interactive-p'.
817HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
818use all classes in `bbdb-message-headers'."
819 (interactive (bbdb-mua-edit-field-interactive))
820 (cond ((memq field '(firstname lastname address phone xfields))
821 (error "Field `%s' not editable this way" field))
822 ((not field)
823 (setq field bbdb-mua-edit-field)))
824 (bbdb-mua-wrapper
825 (let ((records (bbdb-mua-update-records header-class update-p))
826 (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
827 (when records
828 (bbdb-display-records records nil nil nil (bbdb-mua-window-p))
829 (dolist (record records)
830 (bbdb-edit-field record field))))))
831
832;;;###autoload
833(defun bbdb-mua-edit-field-sender (&optional field update-p)
834 "Edit FIELD of record corresponding to sender of this message.
835FIELD defaults to value of variable `bbdb-mua-edit-field'.
836UPDATE-P may take the same values as `bbdb-update-records-p'.
837For interactive calls, see function `bbdb-mua-update-interactive-p'."
838 (interactive (bbdb-mua-edit-field-interactive))
839 (bbdb-mua-edit-field field update-p 'sender))
840
841;;;###autoload
842(defun bbdb-mua-edit-field-recipients (&optional field update-p)
843 "Edit FIELD of record corresponding to recipient of this message.
844FIELD defaults to value of variable `bbdb-mua-edit-field'.
845UPDATE-P may take the same values as `bbdb-update-records-p'.
846For interactive calls, see function `bbdb-mua-update-interactive-p'."
847 (interactive (bbdb-mua-edit-field-interactive))
848 (bbdb-mua-edit-field field update-p 'recipients))
849
850;; Functions for noninteractive use in MUA hooks
851
852;;;###autoload
853(defun bbdb-mua-auto-update (&optional header-class update-p)
854 "Update BBDB automatically based on incoming and outgoing messages.
855This looks into the headers of a message according to HEADER-CLASS.
856Then for the mail addresses found the corresponding BBDB records are updated.
857UPDATE-P determines whether only existing BBDB records are taken
858or whether also new records are created for these mail addresses.
859Return matching records.
860
861HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
862use all classes in `bbdb-message-headers'.
863UPDATE-P may take the same values as `bbdb-mua-auto-update-p'.
864If UPDATE-P is nil, use `bbdb-mua-auto-update-p' (which see).
865
866If `bbdb-mua-pop-up' is non-nil, BBDB pops up the *BBDB* buffer
867along with the MUA window(s), displaying the matching records
868using `bbdb-pop-up-layout'.
869If this is nil, BBDB is updated silently.
870
871This function is intended for noninteractive use via appropriate MUA hooks.
872Call `bbdb-mua-auto-update-init' in your init file to put this function
873into the respective MUA hooks.
874See `bbdb-mua-display-records' and friends for interactive commands."
875 (let* ((bbdb-silent-internal t)
876 (records (bbdb-mua-update-records header-class
877 (or update-p
878 bbdb-mua-auto-update-p)))
879 (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
880 (if bbdb-mua-pop-up
881 (if records
882 (bbdb-display-records records bbdb-pop-up-layout
883 nil nil (bbdb-mua-window-p))
884 ;; If there are no records, empty the BBDB window.
885 (bbdb-undisplay-records)))
886 records))
887
888;; Should the following be replaced by a minor mode??
889;; Or should we make this function interactive in some other way?
890
891;;;###autoload
892(defun bbdb-mua-auto-update-init (&rest muas)
893 "For MUAS add `bbdb-mua-auto-update' to their presentation hook.
894If a MUA is not an element of MUAS, `bbdb-mua-auto-update' is removed
895from the respective presentation hook.
896
897Call this function in your init file to use the auto update feature with MUAS.
898This function is separate from the general function `bbdb-initialize'
899as this allows one to initialize the auto update feature for some MUAs only,
900for example only for outgoing messages.
901
902See `bbdb-mua-auto-update' for details about the auto update feature."
903 (dolist (mua '((message . message-send-hook)
904 (mail . mail-send-hook)
905 (rmail . rmail-show-message-hook)
906 (gnus . gnus-article-prepare-hook)
907 (mh . mh-show-hook)
908 (vm . vm-select-message-hook)
909 (wl . wl-message-redisplay-hook)))
910 (if (memq (car mua) muas)
911 (add-hook (cdr mua) 'bbdb-mua-auto-update)
912 (remove-hook (cdr mua) 'bbdb-mua-auto-update))))
913
914;;;###autoload
915(defun bbdb-auto-notes (record)
916 "Automatically annotate RECORD based on the headers of the current message.
917See the variables `bbdb-auto-notes-rules', `bbdb-auto-notes-ignore-messages'
918and `bbdb-auto-notes-ignore-headers'.
919For use as an element of `bbdb-notice-record-hook'."
920 ;; This code re-evaluates the annotations each time a message is viewed.
921 ;; It would be faster if we could somehow store (permanently?) that we
922 ;; have already annotated a message.
923 (let ((case-fold-search t))
924 (unless (or bbdb-read-only
925 ;; check the ignore-messages pattern
926 (let ((ignore-messages bbdb-auto-notes-ignore-messages)
927 ignore rule)
928 (while (and (not ignore) (setq rule (pop ignore-messages)))
929 (if (cond ((functionp rule)
930 ;; RULE may use `bbdb-update-records-address'
931 (funcall rule record))
932 ((symbolp rule)
933 (eq rule (nth 4 bbdb-update-records-address)))
934 ((eq 1 (safe-length rule))
935 (bbdb-message-header-re (car rule) (cdr rule)))
936 ((eq 2 (safe-length rule))
937 (and (eq (car rule) (nth 4 bbdb-update-records-address))
938 (bbdb-message-header-re (nth 1 rule) (nth 2 rule)))))
939 (setq ignore t)))
940 ignore))
941 (bbdb-editable)
942
943 ;; For speed-up expanded rules are stored in `bbdb-auto-notes-rules-expanded'.
944 (when (and bbdb-auto-notes-rules
945 (not bbdb-auto-notes-rules-expanded))
946 (let (expanded mua from-to header)
947 (dolist (rule bbdb-auto-notes-rules)
948 ;; Which MUA do we want?
949 (if (or (stringp (car rule))
950 (stringp (nth 1 rule)))
951 (setq mua t)
952 (setq mua (if (symbolp (car rule)) (listp (car rule)) (car rule))
953 rule (cdr rule)))
954 ;; Which FROM-TO headers do we want?
955 (if (stringp (car rule))
956 (setq from-to t)
957 (setq from-to (car rule)
958 rule (cdr rule)))
959 (setq header (car rule))
960 (let (string field replace elt-e)
961 (dolist (elt (cdr rule))
962 (if (consp (setq string (cdr elt)))
963 (setq field (car string) ; (REGEXP FIELD-NAME STRING REPLACE)
964 replace (nth 2 string) ; perhaps nil
965 string (nth 1 string))
966 ;; else it's simple (REGEXP . STRING)
967 (setq field bbdb-default-xfield
968 replace nil))
969 (push (list (car elt) field string replace) elt-e))
970 (push (append (list mua from-to header) (nreverse elt-e)) expanded)))
971 (setq bbdb-auto-notes-rules-expanded (nreverse expanded))))
972
973 (dolist (rule bbdb-auto-notes-rules-expanded)
974 (let ((mua (car rule)) (from-to (nth 1 rule)) (header (nth 2 rule))
975 hd-val string annotation)
976 (when (and (or (eq mua t)
977 (memq (nth 4 bbdb-update-records-address) mua))
978 (or (eq from-to t)
979 (member-ignore-case
980 (nth 2 bbdb-update-records-address) from-to)
981 (memq (nth 3 bbdb-update-records-address) from-to))
982 (setq hd-val (bbdb-message-header header)))
983 (dolist (elt (nthcdr 3 rule))
984 (when (and (string-match (car elt) hd-val)
985 (let ((ignore (cdr (assoc-string
986 header
987 bbdb-auto-notes-ignore-headers t))))
988 (not (and ignore (string-match ignore hd-val)))))
989 (setq string (nth 2 elt)
990 annotation
991 (cond ((integerp string)
992 (match-string string hd-val))
993 ((stringp string)
994 (replace-match string nil nil hd-val))
995 ((functionp string)
996 (funcall string hd-val))
997 (t (error "Illegal value: %s" string))))
998 (bbdb-annotate-record record annotation
999 (nth 1 elt) (nth 3 elt))))))))))
1000
1001;;; Mark BBDB records in the MUA summary buffer
1002
1003(defun bbdb-mua-summary-unify (address)
1004 "Unify mail ADDRESS displayed for a message in the MUA Summary buffer.
1005Typically ADDRESS refers to the value of the From header of a message.
1006If ADDRESS matches a record in BBDB display a unified name instead of ADDRESS
1007in the MUA Summary buffer.
1008
1009Unification uses `bbdb-mua-summary-unification-list' (see there).
1010The first match in this list becomes the text string displayed
1011for a message in the MUA Summary buffer instead of ADDRESS.
1012If variable `bbdb-mua-summary-mark' is non-nil use it to precede known addresses.
1013Return the unified mail address.
1014
1015Currently this works with Gnus and VM. It requires the BBDB insinuation
1016of these MUAs. Also, the MUA Summary format string must use
1017`bbdb-mua-summary-unify-format-letter' (see there)."
1018 ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
1019 (let* ((data (bbdb-extract-address-components address))
1020 (name (car data))
1021 (mail (cadr data))
1022 (record (car (bbdb-message-search name mail)))
1023 (u-list bbdb-mua-summary-unification-list)
1024 elt val)
1025 (while (setq elt (pop u-list))
1026 (setq val (cond ((eq elt 'message-name) name)
1027 ((eq elt 'message-mail) mail)
1028 ((eq elt 'message-address) address)
1029 (record (let ((result (bbdb-record-field record elt)))
1030 (if (stringp result) result
1031 (car result)))))) ; RESULT is list.
1032 (if val (setq u-list nil)))
1033 (format "%s%s"
1034 (cond ((not bbdb-mua-summary-mark) "")
1035 ((not record) " ")
1036 ((functionp bbdb-mua-summary-mark-field)
1037 (funcall bbdb-mua-summary-mark-field record))
1038 ((bbdb-record-xfield record bbdb-mua-summary-mark-field))
1039 (t bbdb-mua-summary-mark))
1040 (or val name mail address "**UNKNOWN**"))))
1041
1042(defun bbdb-mua-summary-mark (address)
1043 "In the MUA Summary buffer mark messages matching a BBDB record.
1044ADDRESS typically refers to the value of the From header of a message.
1045If ADDRESS matches a record in BBDB return a mark, \" \" otherwise.
1046The mark itself is the value of the xfield `bbdb-mua-summary-mark-field'
1047if this xfield is in the poster's record, and `bbdb-mua-summary-mark' otherwise."
1048 (if (not bbdb-mua-summary-mark)
1049 "" ; for consistency
1050 ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
1051 (let* ((data (bbdb-extract-address-components address))
1052 (record (car (bbdb-message-search (car data) (cadr data)))))
1053 (if record
1054 (or (when (functionp bbdb-mua-summary-mark-field)
1055 (funcall bbdb-mua-summary-mark-field record)
1056 t)
1057 (bbdb-record-xfield record bbdb-mua-summary-mark-field)
1058 bbdb-mua-summary-mark)
1059 " "))))
1060
1061(provide 'bbdb-mua)
1062
1063;;; bbdb-mua.el ends here