[emacs] manually add bbdb into lisp/bbdb/

1 files changed, 1063 insertions, 0 deletions

diff --git a/lisp/bbdb/bbdb-mua.el b/lisp/bbdb/bbdb-mua.el
new file mode 100644
index 0000000..db31b06
--- /dev/null
+++ b/lisp/bbdb/bbdb-mua.el
@@ -0,0 +1,1063 @@
+;;; bbdb-mua.el --- various MUA functionality for BBDB -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017  Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; BBDB is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with BBDB.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file provides various additional functionality for BBDB
+;; See the BBDB info manual for documentation.
+
+;; This file lets you do stuff like
+;;
+;; o  automatically add some string to some field(s) based on the
+;;    contents of header fields of the current message
+;; o  only automatically create records when certain header fields
+;;    are matched
+;; o  do not automatically create records when certain header fields
+;;    are matched
+;;
+;; Read the docstrings; read the texinfo file.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+(eval-and-compile
+  (autoload 'gnus-fetch-original-field "gnus-utils")
+  (autoload 'gnus-summary-select-article "gnus-sum")
+  (defvar gnus-article-buffer)
+
+  (autoload 'bbdb/vm-header "bbdb-vm")
+  (autoload 'vm-follow-summary-cursor "vm-motion")
+  (autoload 'vm-select-folder-buffer "vm-macro")
+  (autoload 'vm-check-for-killed-summary "vm-misc")
+  (autoload 'vm-error-if-folder-empty "vm-misc")
+
+  (autoload 'bbdb/rmail-header "bbdb-rmail")
+  (defvar rmail-buffer)
+
+  (autoload 'bbdb/mh-header "bbdb-mhe")
+  (autoload 'mh-show "mh-show")
+  (defvar mh-show-buffer)
+
+  (defvar mu4e~view-buffer-name)
+
+  (autoload 'bbdb/wl-header "bbdb-wl")
+
+  (autoload 'message-field-value "message")
+  (autoload 'mail-decode-encoded-word-string "mail-parse"))
+
+(defconst bbdb-mua-mode-alist
+  '((vm vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode)
+    (gnus gnus-summary-mode gnus-article-mode gnus-tree-mode)
+    (rmail rmail-mode rmail-summary-mode)
+    (mh mhe-mode mhe-summary-mode mh-folder-mode)
+    (mu4e mu4e-view-mode)  ; Tackle `mu4e-headers-mode' later
+    (wl wl-summary-mode wl-draft-mode)
+    (message message-mode mu4e-compose-mode notmuch-message-mode)
+    (mail mail-mode))
+  "Alist of MUA modes supported by BBDB.
+Each element is of the form (MUA MODE MODE ...), where MODEs are used by MUA.")
+
+(defun bbdb-mua ()
+  "For the current message return the MUA.
+Return values include
+  gnus      Newsreader Gnus
+  rmail     Reading Mail in Emacs
+  vm        Viewmail
+  mh        Emacs interface to the MH mail system (aka MH-E)
+  mu4e      Mu4e
+  wl        Wanderlust
+  message   Mail and News composition mode that goes with Gnus
+  mail      Emacs Mail Mode."
+  (let ((mm-alist bbdb-mua-mode-alist)
+        elt mua)
+    (while (setq elt (pop mm-alist))
+      (if (memq major-mode (cdr elt))
+          (setq mua (car elt)
+                mm-alist nil)))
+    (or mua (error "BBDB: MUA `%s' not supported" major-mode))))
+
+;;;###autoload
+(defun bbdb-message-header (header)
+  "For the current message return the value of HEADER.
+MIME encoded headers are decoded.  Return nil if HEADER does not exist."
+  ;; RW: If HEADER was allowed to be a regexp and the content of multiple
+  ;; matching headers was concatenated as in `message-field-value',
+  ;; this would simplify the usage of `bbdb-accept-message-alist' and
+  ;; `bbdb-ignore-message-alist'.
+  ;; RW: If this function had a remember table, it could look up the value
+  ;; of a header if we request the value of the same header multiple times.
+  ;; (We would reset the remember table each time we move on to a new message.)
+  (let* ((mua (bbdb-mua))
+         (val (cond (;; It seems that `gnus-fetch-field' fetches decoded content of
+                     ;; `gnus-visible-headers', ignoring `gnus-ignored-headers'.
+                     ;; Here we use instead `gnus-fetch-original-field' that fetches
+                     ;; the encoded content of `gnus-original-article-buffer'.
+                     ;; Decoding makes this possibly a bit slower, but something like
+                     ;; `bbdb-select-message' does not get fooled by an apparent
+                     ;; absence of some headers.
+                     ;; See http://permalink.gmane.org/gmane.emacs.gnus.general/78741
+                     (eq mua 'gnus) (gnus-fetch-original-field header))
+                    ((eq mua 'vm) (bbdb/vm-header header))
+                    ((eq mua 'rmail) (bbdb/rmail-header header))
+                    ((eq mua 'mh) (bbdb/mh-header header))
+                    ((eq mua 'mu4e) (message-field-value header))
+                    ((eq mua 'wl) (bbdb/wl-header header))
+                    ((memq mua '(message mail)) (message-field-value header))
+                    (t (error "BBDB/%s: header function undefined" mua)))))
+    (if val (mail-decode-encoded-word-string val))))
+
+(defsubst bbdb-message-header-re (header regexp)
+  "Return non-nil if REGEXP matches value of HEADER."
+  (let ((val (bbdb-message-header header))
+        (case-fold-search t)) ; RW: Is this what we want?
+    (and val (string-match regexp val))))
+
+;;; Update database
+
+;;;###autoload
+(defun bbdb-accept-message (&optional invert)
+  "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages matching
+`bbdb-accept-message-alist'.  If INVERT is non-nil, accept messages
+not matching `bbdb-ignore-message-alist'."
+  (let ((rest (if invert bbdb-ignore-message-alist
+                bbdb-accept-message-alist))
+        done elt)
+    (if (eq rest t)
+        (setq done t)
+      (while (and (setq elt (pop rest)) (not done))
+        (dolist (header (if (stringp (car elt)) (list (car elt)) (car elt)))
+          (if (bbdb-message-header-re header (cdr elt))
+              (setq done t)))))
+    (if invert (setq done (not done)))
+    (if done bbdb-update-records-p)))
+
+;;;###autoload
+(defun bbdb-ignore-message (&optional invert)
+  "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages not matching
+`bbdb-ignore-message-alist'.  If INVERT is non-nil, accept messages
+matching `bbdb-accept-message-alist'."
+  (bbdb-accept-message (not invert)))
+
+;;;###autoload
+(defun bbdb-select-message ()
+  "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages both matching
+`bbdb-accept-message-alist' and not matching `bbdb-ignore-message-alist'."
+  (and (bbdb-accept-message)
+       (bbdb-ignore-message)))
+
+(defun bbdb-get-address-components (&optional header-class ignore-address)
+  "Extract mail addresses from a message.
+Return list with elements (NAME EMAIL HEADER HEADER-CLASS MUA).
+HEADER-CLASS is defined in `bbdb-message-headers'.  If HEADER-CLASS is nil,
+use all classes in `bbdb-message-headers'.
+If regexp IGNORE-ADDRESS matches NAME or EMAIL of an address, this address
+is ignored. If IGNORE-ADDRESS is nil, use value of `bbdb-user-mail-address-re'."
+  ;; We do not use `bbdb-message-all-addresses' here because only when we
+  ;; have compared the addresses with the records in BBDB do we know which
+  ;; address(es) are relevant for us.
+  (let ((message-headers (if header-class
+                             (list (assoc header-class bbdb-message-headers))
+                           bbdb-message-headers))
+        (mua (bbdb-mua))
+        (ignore-address (or ignore-address bbdb-user-mail-address-re))
+        address-list name mail mail-list content)
+    (dolist (headers message-headers)
+      (dolist (header (cdr headers))
+        (when (setq content (bbdb-message-header header))
+          ;; Always extract all addresses because we do not know yet which
+          ;; address might match IGNORE-ADDRESS.
+          (dolist (address (bbdb-extract-address-components content t))
+            ;; We canonicalize name and mail as early as possible.
+            (setq name (car address)
+                  mail (cadr address))
+            ;; ignore uninteresting addresses
+            (unless (or (and (stringp ignore-address)
+                             (or (and name (string-match ignore-address name))
+                                 (and mail (string-match ignore-address mail))))
+                        (and mail (member-ignore-case mail mail-list)))
+              ;; Add each address only once. (Use MAIL-LIST for book keeping.)
+              ;; Thus if we care about whether an address gets associated with
+              ;; one or another header, the order of elements in
+              ;; `bbdb-message-headers' is relevant.  The "most important"
+              ;; headers should be first in `bbdb-message-headers'.
+              (if mail (push mail mail-list))
+              (push (list name mail header (car headers) mua) address-list))))))
+    (or (nreverse address-list)
+        (and header-class bbdb-message-try-all-headers
+             ;; Try again the remaining header classes
+             (let ((bbdb-message-headers
+                    (remove (assoc header-class bbdb-message-headers)
+                            bbdb-message-headers)))
+               (bbdb-get-address-components nil ignore-address))))))
+
+;;;###autoload
+(defun bbdb-update-records (address-list &optional update-p sort)
+  "Return the list of BBDB records matching ADDRESS-LIST.
+ADDRESS-LIST is a list of mail addresses.  (It can be extracted from
+a mail message using `bbdb-get-address-components'.)
+UPDATE-P may take the following values:
+ search       Search for existing records matching ADDRESS.
+ update       Search for existing records matching ADDRESS;
+                update name and mail field if necessary.
+ query        Search for existing records matching ADDRESS;
+                query for creation of a new record if the record does not exist.
+ create or t  Search for existing records matching ADDRESS;
+                create a new record if it does not yet exist.
+ nil          Do nothing.
+ a function   This functions will be called with no arguments.
+                It should return one of the above values.
+
+If SORT is non-nil, sort records according to `bbdb-record-lessp'.
+Ottherwise, the records are ordered according to ADDRESS-LIST.
+
+Usually this function is called by the wrapper `bbdb-mua-update-records'."
+  ;; UPDATE-P allows filtering of complete messages.
+  ;; Filtering of individual addresses within an accepted message
+  ;; is done by `bbdb-get-address-components' using `bbdb-user-mail-address-re'.
+  ;; We resolve UPDATE-P repeatedly.  This is needed, for example,
+  ;; with the chain `bbdb-mua-auto-update-p' -> `bbdb-select-message'
+  ;; -> `bbdb-update-records-p'.
+  (while (and (functionp update-p)
+              ;; Bad! `search' is a function in `cl-seq.el'.
+              (not (eq update-p 'search)))
+    (setq update-p (funcall update-p)))
+  (cond ((eq t update-p)
+         (setq update-p 'create))
+        ((not (memq update-p '(search update query create nil)))
+         (error "Illegal value of arg update-p: %s" update-p)))
+
+  (let (;; `bbdb-update-records-p' and `bbdb-offer-to-create' are used here
+        ;; as internal variables for communication with `bbdb-query-create'.
+        ;; This does not affect the value of the global user variable
+        ;; `bbdb-update-records-p'.
+        (bbdb-offer-to-create 'start)
+        (bbdb-update-records-p update-p)
+        address records)
+
+    (when update-p
+      (while (setq address (pop address-list))
+        (let* ((bbdb-update-records-address address)
+               hits
+               (task
+                (catch 'done
+                  (setq hits
+                        ;; We put the call of `bbdb-notice-mail-hook'
+                        ;; into `bbdb-annotate-message' so that this hook
+                        ;; runs only if the user agreed to change a record.
+                        (cond ((or bbdb-read-only
+                                   (eq bbdb-update-records-p 'search))
+                               ;; Search for records having this mail address
+                               ;; but do not modify an existing record.
+                               ;; This does not run `bbdb-notice-mail-hook'.
+                               (bbdb-message-search (car address)
+                                                    (cadr address)))
+                              ((eq bbdb-update-records-p 'update)
+                               (bbdb-annotate-message address 'update))
+                              ((eq bbdb-update-records-p 'query)
+                               (bbdb-annotate-message
+                                address 'bbdb-query-create))
+                              ((eq bbdb-update-records-p 'create)
+                               (bbdb-annotate-message address 'create))))
+                  nil)))
+          (cond ((eq task 'quit)
+                 (setq address-list nil))
+                ((not (eq task 'next))
+                 (dolist (hit (delq nil (nreverse hits)))
+                   (bbdb-pushnew hit records))))
+          (if (and records (not bbdb-message-all-addresses))
+              (setq address-list nil))))
+      (setq records
+            (if sort (sort records 'bbdb-record-lessp)
+              ;; Make RECORDS a list ordered like ADDRESS-LIST.
+              (nreverse records))))
+
+    ;; `bbdb-message-search' might yield multiple records
+    (if (and records (not bbdb-message-all-addresses))
+        (setq records (list (car records))))
+
+    (unless bbdb-read-only
+      (bbdb-editable)
+      (dolist (record records)
+        (run-hook-with-args 'bbdb-notice-record-hook record)))
+
+    records))
+
+(defun bbdb-query-create ()
+  "Interactive query used by `bbdb-update-records'.
+Return t if the record should be created or `nil' otherwise.
+Honor previous answers such as `!'."
+  (let ((task bbdb-offer-to-create))
+    ;; If we have remembered what the user typed previously,
+    ;; `bbdb-offer-to-create' holds a character, i.e., a number.
+    ;; -- Right now, we only remember "!".
+    (when (not (integerp task))
+      (let ((prompt (format "%s is not in BBDB; add? (y,!,n,s,q,?) "
+                            (or (nth 0 bbdb-update-records-address)
+                                (nth 1 bbdb-update-records-address))))
+            event)
+        (while (not event)
+          (setq event (read-key-sequence prompt))
+          (setq event (if (stringp event) (aref event 0))))
+        (setq task event)
+        (message ""))) ; clear the message buffer
+
+    (cond ((eq task ?y)
+           t)
+          ((eq task ?!)
+           (setq bbdb-offer-to-create task)
+           t)
+          ((or (eq task ?n)
+               (eq task ?\s))
+           (throw 'done 'next))
+          ((or (eq task ?q)
+               (eq task ?\a)) ; ?\a = C-g
+           (throw 'done 'quit))
+          ((eq task ?s)
+           (setq bbdb-update-records-p 'search)
+           (throw 'done 'next))
+          (t ; any other key sequence
+           (save-window-excursion
+             (let* ((buffer (get-buffer-create " *BBDB Help*"))
+                    (window (or (get-buffer-window buffer)
+                                (split-window (get-lru-window)))))
+               (with-current-buffer buffer
+                 (special-mode)
+                 (let (buffer-read-only)
+                   (erase-buffer)
+                   (insert
+                    "Your answer controls how BBDB updates/searches for records.
+
+Type ?  for this help.
+Type y  to add the current record.
+Type !  to add all remaining records.
+Type n  to skip the current record. (You might also type space)
+Type s  to switch from annotate to search mode.
+Type q  to quit updating records.  No more search or annotation is done.")
+                   (set-buffer-modified-p nil)
+                   (goto-char (point-min)))
+                 (set-window-buffer window buffer)
+                 (fit-window-to-buffer window)))
+             ;; Try again!
+             (bbdb-query-create))))))
+
+
+
+(defun bbdb-annotate-message (address &optional update-p)
+  "Fill the records for message ADDRESS with as much info as possible.
+If a record for ADDRESS does not yet exist, UPDATE-P controls whether
+a new record is created for ADDRESS.  UPDATE-P may take the values:
+ update or nil  Update existing records, never create a new record.
+ query          Query interactively whether to create a new record.
+ create or t    Create a new record.
+ a function     This functions will be called with no arguments.
+                  It should return one of the above values.
+Return the records matching ADDRESS or nil."
+  (let* ((mail (nth 1 address)) ; possibly nil
+         (name (unless (equal mail (car address))
+                 (car address)))
+         (records (bbdb-message-search name mail))
+         created-p new-records)
+    (if (and (not records) (functionp update-p))
+        (setq update-p (funcall update-p)))
+    (cond ((eq t update-p) (setq update-p 'create))
+          ((not update-p) (setq update-p 'update)))
+
+    ;; Create a new record if nothing else fits.
+    ;; In this way, we can fill the slots of the new record with
+    ;; the same code that updates the slots of existing records.
+    (unless (or records
+                (eq update-p 'update)
+                (not (or name mail)))
+      ;; If there is no name, try to use the mail address as name
+      (if (and bbdb-message-mail-as-name mail
+               (or (null name)
+                   (string= "" name)))
+          (setq name (funcall bbdb-message-clean-name-function mail)))
+      (if (or (eq update-p 'create)
+              (and (eq update-p 'query)
+                   (y-or-n-p (format "%s is not in the BBDB.  Add? "
+                                     (or name mail)))))
+          (setq records (list (bbdb-empty-record))
+                created-p t)))
+
+    (dolist (record records)
+      (let* ((old-name (bbdb-record-name record))
+             (fullname (bbdb-divide-name (or name "")))
+             (fname (car fullname))
+             (lname (cdr fullname))
+             (mail mail) ;; possibly changed below
+             (created-p created-p)
+             (update-p update-p)
+             change-p add-mails add-name ignore-redundant)
+
+        ;; Analyze the name part of the record.
+        (cond ((or (not name)
+                   ;; The following tests can differ for more complicated names
+                   (bbdb-string= name old-name)
+                   (and (equal fname (bbdb-record-firstname record)) ; possibly
+                        (equal lname (bbdb-record-lastname record))) ; nil
+                   (member-ignore-case name (bbdb-record-aka record)))) ; do nothing
+
+              (created-p ; new record
+               (bbdb-record-set-field record 'name (cons fname lname)))
+
+              ((not (setq add-name (bbdb-add-job bbdb-add-name record name)))) ; do nothing
+
+              ((numberp add-name)
+               (unless bbdb-silent
+                 (message "name mismatch: \"%s\" changed to \"%s\""
+                          old-name name)
+                 (sit-for add-name)))
+
+              ((bbdb-eval-spec add-name
+                               (if old-name
+                                   (format "Change name \"%s\" to \"%s\"? "
+                                           old-name name)
+                                 (format "Assign name \"%s\" to address \"%s\"? "
+                                         name (car (bbdb-record-mail record)))))
+               ;; Keep old-name as AKA?
+               (when (and old-name
+                          (not (member-ignore-case old-name (bbdb-record-aka record))))
+                 (if (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record old-name)
+                                     (format "Keep name \"%s\" as an AKA? " old-name))
+                     (bbdb-record-set-field
+                      record 'aka (cons old-name (bbdb-record-aka record)))
+                   (bbdb-remhash old-name record)))
+               (bbdb-record-set-field record 'name (cons fname lname))
+               (setq change-p 'name))
+
+              ;; make new name an AKA?
+              ((and old-name
+                    (not (member-ignore-case name (bbdb-record-aka record)))
+                    (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record name)
+                                    (format "Make \"%s\" an alternate for \"%s\"? "
+                                            name old-name)))
+               (bbdb-record-set-field
+                record 'aka (cons name (bbdb-record-aka record)))
+               (setq change-p 'name)))
+
+        ;; Is MAIL redundant compared with the mail addresses
+        ;; that are already known for RECORD?
+        (if (and mail
+                 (setq ignore-redundant
+                       (bbdb-add-job bbdb-ignore-redundant-mails record mail)))
+            (let ((mails (bbdb-record-mail-canon record))
+                  (case-fold-search t) redundant ml re)
+              (while (setq ml (pop mails))
+                (if (and (setq re (bbdb-mail-redundant-re ml))
+                         (string-match re mail))
+                    (setq redundant ml mails nil)))
+              (if redundant
+                  (cond ((numberp ignore-redundant)
+                         (unless bbdb-silent
+                           (message "%s: redundant mail `%s'"
+                                    (bbdb-record-name record) mail)
+                           (sit-for ignore-redundant)))
+                        ((or (eq t ignore-redundant)
+                             bbdb-silent
+                             (y-or-n-p (format "Ignore redundant mail %s?" mail)))
+                         (setq mail redundant))))))
+
+        ;; Analyze the mail part of the new records
+        (cond ((or (not mail) (equal mail "???")
+                   (member-ignore-case mail (bbdb-record-mail-canon record)))) ; do nothing
+
+              (created-p ; new record
+               (bbdb-record-set-field record 'mail (list mail)))
+
+              ((not (setq add-mails (bbdb-add-job bbdb-add-mails record mail)))) ; do nothing
+
+              ((numberp add-mails)
+               (unless bbdb-silent
+                 (message "%s: new address `%s'"
+                          (bbdb-record-name record) mail)
+                 (sit-for add-mails)))
+
+              ((or (eq add-mails t) ; add it automatically
+                   bbdb-silent
+                   (y-or-n-p (format "Add address \"%s\" to %s? " mail
+                                     (bbdb-record-name record)))
+                   (and (or (and (functionp update-p)
+                                 (progn (setq update-p (funcall update-p)) nil))
+                            (memq update-p '(t create))
+                            (and (eq update-p 'query)
+                                 (y-or-n-p
+                                  (format "Create a new record for %s? "
+                                          (bbdb-record-name record)))))
+                        (progn
+                          (setq record (bbdb-empty-record))
+                          (bbdb-record-set-name record fname lname)
+                          (setq created-p t))))
+
+               (let ((mails (bbdb-record-mail record)))
+                 (if ignore-redundant
+                     ;; Does the new address MAIL make an old address redundant?
+                     (let ((mail-re (bbdb-mail-redundant-re mail))
+                           (case-fold-search t) okay redundant)
+                       (dolist (ml mails)
+                         (if (string-match mail-re ml) ; redundant mail address
+                             (push ml redundant)
+                           (push ml okay)))
+                       (let ((form (format "redundant mail%s %s"
+                                           (if (< 1 (length redundant)) "s" "")
+                                           (bbdb-concat 'mail (nreverse redundant))))
+                             (name (bbdb-record-name record)))
+                         (if redundant
+                             (cond ((numberp ignore-redundant)
+                                    (unless bbdb-silent
+                                      (message "%s: %s" name form)
+                                      (sit-for ignore-redundant)))
+                                   ((or (eq t ignore-redundant)
+                                        bbdb-silent
+                                        (y-or-n-p (format "Delete %s: " form)))
+                                    (if (eq t ignore-redundant)
+                                        (message "%s: deleting %s" name form))
+                                    (setq mails okay)))))))
+
+                 ;; then modify RECORD
+                 (bbdb-record-set-field
+                  record 'mail
+                  (if (and mails
+                           (bbdb-eval-spec (bbdb-add-job bbdb-new-mails-primary
+                                                         record mail)
+                                           (format "Make \"%s\" the primary address? " mail)))
+                      (cons mail mails)
+                    (nconc mails (list mail))))
+                 (unless change-p (setq change-p t)))))
+
+        (cond (created-p
+               (unless bbdb-silent
+                 (if (bbdb-record-name record)
+                     (message "created %s's record with address \"%s\""
+                              (bbdb-record-name record) mail)
+                   (message "created record with naked address \"%s\"" mail)))
+               (bbdb-change-record record))
+
+              (change-p
+               (unless bbdb-silent
+                 (cond ((eq change-p 'name)
+                        (message "noticed \"%s\"" (bbdb-record-name record)))
+                       ((bbdb-record-name record)
+                        (message "noticed %s's address \"%s\""
+                                 (bbdb-record-name record) mail))
+                       (t
+                        (message "noticed naked address \"%s\"" mail))))
+               (bbdb-change-record record)))
+
+        (run-hook-with-args 'bbdb-notice-mail-hook record)
+        (push record new-records)))
+
+    (nreverse new-records)))
+
+(defun bbdb-mua-update-records (&optional header-class update-p sort)
+  "Wrapper for `bbdb-update-records'.
+HEADER-CLASS is defined in `bbdb-message-headers'.  If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P is defined in `bbdb-update-records'.
+If SORT is non-nil, sort records according to `bbdb-record-lessp'."
+  (let ((mua (bbdb-mua)))
+    (save-current-buffer
+      (cond ;; VM
+       ((eq mua 'vm)
+        (vm-select-folder-buffer)
+        (vm-check-for-killed-summary)
+        (vm-error-if-folder-empty)
+        (let ((enable-local-variables t))  ; ...or vm bind this to nil.
+          (bbdb-update-records (bbdb-get-address-components header-class)
+                               update-p sort)))
+       ;; Gnus
+       ((eq mua 'gnus)
+        (set-buffer gnus-article-buffer)
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))
+       ;; MH-E
+       ((eq mua 'mh)
+        (if mh-show-buffer (set-buffer mh-show-buffer))
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))
+       ;; Rmail
+       ((eq mua 'rmail)
+        (set-buffer rmail-buffer)
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))
+       ;; mu4e
+       ((eq mua 'mu4e)
+        (set-buffer mu4e~view-buffer-name)
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))
+       ;; Wanderlust
+       ((eq mua 'wl)
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))
+      ;; Message and Mail
+       ((memq mua '(message mail))
+        (bbdb-update-records (bbdb-get-address-components header-class)
+                             update-p sort))))))
+
+(defmacro bbdb-mua-wrapper (&rest body)
+  "Perform BODY in a MUA buffer."
+  (declare (debug t))
+  `(let ((mua (bbdb-mua)))
+     ;; Here we replicate BODY multiple times which gets clumsy
+     ;; for a larger BODY!
+     (cond ((eq mua 'gnus)
+            ;; This fails in *Article* buffers, where
+            ;; `gnus-article-read-summary-keys' provides an additional wrapper
+            (save-current-buffer
+              (gnus-summary-select-article) ; sets buffer `gnus-summary-buffer'
+              ,@body))
+           ((memq mua '(mail message rmail mh vm mu4e wl))
+            (cond ((eq mua 'vm) (vm-follow-summary-cursor))
+                  ((eq mua 'mh) (mh-show)))
+            ;; rmail, mail, message, mu4e and wl do not require any wrapper
+            ,@body))))
+
+(defun bbdb-mua-update-interactive-p ()
+  "Interactive spec for arg UPDATE-P of `bbdb-mua-display-records' and friends.
+If these commands are called without a prefix, the value of their arg
+UPDATE-P is the car of the variable `bbdb-mua-update-interactive-p'.
+Called with a prefix, the value of UPDATE-P is the cdr of this variable."
+  (let ((update-p (if current-prefix-arg
+                      (cdr bbdb-mua-update-interactive-p)
+                    (car bbdb-mua-update-interactive-p))))
+    (if (eq update-p 'read)
+        (let ((str (completing-read "Action: " '((query) (search) (create))
+                                    nil t)))
+          (unless (string= "" str) (intern str))) ; nil otherwise
+      update-p)))
+
+(defun bbdb-mua-window-p ()
+  "Return lambda function matching the MUA window.
+This return value can be used as arg HORIZ-P of `bbdb-display-records'."
+  (let ((mm-alist bbdb-mua-mode-alist)
+        elt fun)
+    (while (setq elt (cdr (pop mm-alist)))
+      (if (memq major-mode elt)
+          (setq fun `(lambda (window)
+                       (with-current-buffer (window-buffer window)
+                         (memq major-mode ',elt)))
+                mm-alist nil)))
+    fun))
+
+;;;###autoload
+(defun bbdb-mua-display-records (&optional header-class update-p all)
+  "Display the BBDB record(s) for the addresses in this message.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding BBDB records are displayed.
+UPDATE-P determines whether only existing BBDB records are displayed
+or whether also new records are created for these mail addresses.
+
+HEADER-CLASS is defined in `bbdb-message-headers'.  If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'.
+If ALL is non-nil, bind `bbdb-message-all-addresses' to ALL."
+  (interactive (list nil (bbdb-mua-update-interactive-p)))
+  (let ((bbdb-pop-up-window-size bbdb-mua-pop-up-window-size)
+        (bbdb-message-all-addresses (or all bbdb-message-all-addresses))
+        records)
+    (bbdb-mua-wrapper
+     (setq records (bbdb-mua-update-records header-class update-p t)))
+    (if records (bbdb-display-records records nil nil nil (bbdb-mua-window-p)))
+    records))
+
+;; The following commands are some frontends for `bbdb-mua-display-records',
+;; which is always doing the real work.  In your init file, you can further
+;; modify or adapt these simple commands to your liking.
+
+;;;###autoload
+(defun bbdb-mua-display-sender (&optional update-p)
+  "Display the BBDB record(s) for the sender of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (list (bbdb-mua-update-interactive-p)))
+  (bbdb-mua-display-records 'sender update-p))
+
+;;;###autoload
+(defun bbdb-mua-display-recipients (&optional update-p)
+  "Display the BBDB record(s) for the recipients of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (list (bbdb-mua-update-interactive-p)))
+  (bbdb-mua-display-records 'recipients update-p))
+
+;;;###autoload
+(defun bbdb-mua-display-all-records (&optional update-p)
+  "Display the BBDB record(s) for all addresses in this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (list (bbdb-mua-update-interactive-p)))
+  (bbdb-mua-display-records nil update-p t))
+
+;;;###autoload
+(defun bbdb-mua-display-all-recipients (&optional update-p)
+  "Display BBDB records for all recipients of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (list (bbdb-mua-update-interactive-p)))
+  (bbdb-mua-display-records 'recipients update-p t))
+
+;; The commands `bbdb-annotate-record' and `bbdb-mua-edit-field'
+;; have kind of similar goals, yet they use rather different strategies.
+;; `bbdb-annotate-record' is less obtrusive.  It does not display
+;; the records it operates on, nor does it display the content
+;; of the field before or after adding or replacing the annotation.
+;; Hence the user needs to know what she is doing.
+;; `bbdb-mua-edit-field' is more explicit:  It displays the records
+;; as well as the current content of the field that gets edited.
+
+;; In principle, this function can be used not only with MUAs.
+(defun bbdb-annotate-record (record annotation &optional field replace)
+  "In RECORD add an ANNOTATION to field FIELD.
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+If ANNOTATION is an empty string and REPLACE is non-nil, delete FIELD."
+  (if (memq field '(name firstname lastname phone address xfields))
+      (error "Field `%s' illegal" field))
+  (setq annotation (bbdb-string-trim annotation))
+  (cond ((memq field '(affix organization mail aka))
+         (setq annotation (list annotation)))
+        ((not field) (setq field bbdb-annotate-field)))
+  (bbdb-record-set-field record field annotation (not replace))
+  (bbdb-change-record record))
+
+;; FIXME: For interactive calls of the following commands, the arg UPDATE-P
+;; should have the same meaning as for `bbdb-mua-display-records',
+;; that is, it should use `bbdb-mua-update-interactive-p'.
+;; But here the prefix arg is already used in a different way.
+;; We could possibly solve this problem if all `bbdb-mua-*' commands
+;; used another prefix arg that is consistently used only for
+;; `bbdb-mua-update-interactive-p'.
+;; Yet this prefix arg must be defined within the key space of the MUA(s).
+;; This results in lots of conflicts...
+;;
+;; Current workaround:
+;; These commands use merely the car of `bbdb-mua-update-interactive-p'.
+;; If one day someone proposes a smart solution to this problem (suggestions
+;; welcome!), this solution will hopefully include the current workaround
+;; as a subset of all its features.
+
+(defun bbdb-mua-annotate-field-interactive ()
+  "Interactive specification for `bbdb-mua-annotate-sender' and friends."
+  (bbdb-editable)
+  (let ((field (if (eq 'all-fields bbdb-annotate-field)
+                   (intern (completing-read
+                            "Field: "
+                            (mapcar 'symbol-name
+                                    (append '(affix organization mail aka)
+                                            bbdb-xfield-label-list))))
+                 bbdb-annotate-field)))
+    (list (read-string (format "Annotate `%s': " field))
+          field current-prefix-arg
+          (car bbdb-mua-update-interactive-p))))
+
+;;;###autoload
+(defun bbdb-mua-annotate-sender (annotation &optional field replace update-p)
+  "Add ANNOTATION to field FIELD of the BBDB record(s) of message sender(s).
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, use car of `bbdb-mua-update-interactive-p'."
+  (interactive (bbdb-mua-annotate-field-interactive))
+  (bbdb-mua-wrapper
+   (dolist (record (bbdb-mua-update-records 'sender update-p))
+     (bbdb-annotate-record record annotation field replace))))
+
+;;;###autoload
+(defun bbdb-mua-annotate-recipients (annotation &optional field replace
+                                                update-p)
+  "Add ANNOTATION to field FIELD of the BBDB records of message recipients.
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, use car of `bbdb-mua-update-interactive-p'."
+  (interactive (bbdb-mua-annotate-field-interactive))
+  (bbdb-mua-wrapper
+   (dolist (record (bbdb-mua-update-records 'recipients update-p))
+     (bbdb-annotate-record record annotation field replace))))
+
+(defun bbdb-mua-edit-field-interactive ()
+  "Interactive specification for command `bbdb-mua-edit-field' and friends."
+  (bbdb-editable)
+  (list (if (eq 'all-fields bbdb-mua-edit-field)
+            (intern (completing-read
+                     "Field: "
+                     (mapcar 'symbol-name
+                             (append '(name affix organization aka mail)
+                                     bbdb-xfield-label-list))))
+          bbdb-mua-edit-field)
+        (bbdb-mua-update-interactive-p)))
+
+;;;###autoload
+(defun bbdb-mua-edit-field (&optional field update-p header-class)
+  "Edit FIELD of the BBDB record(s) of message sender(s) or recipients.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'.
+HEADER-CLASS is defined in `bbdb-message-headers'.  If it is nil,
+use all classes in `bbdb-message-headers'."
+  (interactive (bbdb-mua-edit-field-interactive))
+  (cond ((memq field '(firstname lastname address phone xfields))
+         (error "Field `%s' not editable this way" field))
+        ((not field)
+         (setq field bbdb-mua-edit-field)))
+  (bbdb-mua-wrapper
+   (let ((records (bbdb-mua-update-records header-class update-p))
+         (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
+     (when records
+       (bbdb-display-records records nil nil nil (bbdb-mua-window-p))
+       (dolist (record records)
+         (bbdb-edit-field record field))))))
+
+;;;###autoload
+(defun bbdb-mua-edit-field-sender (&optional field update-p)
+  "Edit FIELD of record corresponding to sender of this message.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (bbdb-mua-edit-field-interactive))
+  (bbdb-mua-edit-field field update-p 'sender))
+
+;;;###autoload
+(defun bbdb-mua-edit-field-recipients (&optional field update-p)
+  "Edit FIELD of record corresponding to recipient of this message.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+  (interactive (bbdb-mua-edit-field-interactive))
+  (bbdb-mua-edit-field field update-p 'recipients))
+
+;; Functions for noninteractive use in MUA hooks
+
+;;;###autoload
+(defun bbdb-mua-auto-update (&optional header-class update-p)
+  "Update BBDB automatically based on incoming and outgoing messages.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding BBDB records are updated.
+UPDATE-P determines whether only existing BBDB records are taken
+or whether also new records are created for these mail addresses.
+Return matching records.
+
+HEADER-CLASS is defined in `bbdb-message-headers'.  If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P may take the same values as `bbdb-mua-auto-update-p'.
+If UPDATE-P is nil, use `bbdb-mua-auto-update-p' (which see).
+
+If `bbdb-mua-pop-up' is non-nil, BBDB pops up the *BBDB* buffer
+along with the MUA window(s), displaying the matching records
+using `bbdb-pop-up-layout'.
+If this is nil, BBDB is updated silently.
+
+This function is intended for noninteractive use via appropriate MUA hooks.
+Call `bbdb-mua-auto-update-init' in your init file to put this function
+into the respective MUA hooks.
+See `bbdb-mua-display-records' and friends for interactive commands."
+  (let* ((bbdb-silent-internal t)
+         (records (bbdb-mua-update-records header-class
+                                           (or update-p
+                                               bbdb-mua-auto-update-p)))
+         (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
+    (if bbdb-mua-pop-up
+        (if records
+              (bbdb-display-records records bbdb-pop-up-layout
+                                    nil nil (bbdb-mua-window-p))
+          ;; If there are no records, empty the BBDB window.
+          (bbdb-undisplay-records)))
+    records))
+
+;; Should the following be replaced by a minor mode??
+;; Or should we make this function interactive in some other way?
+
+;;;###autoload
+(defun bbdb-mua-auto-update-init (&rest muas)
+  "For MUAS add `bbdb-mua-auto-update' to their presentation hook.
+If a MUA is not an element of MUAS, `bbdb-mua-auto-update' is removed
+from the respective presentation hook.
+
+Call this function in your init file to use the auto update feature with MUAS.
+This function is separate from the general function `bbdb-initialize'
+as this allows one to initialize the auto update feature for some MUAs only,
+for example only for outgoing messages.
+
+See `bbdb-mua-auto-update' for details about the auto update feature."
+  (dolist (mua '((message . message-send-hook)
+                 (mail . mail-send-hook)
+                 (rmail . rmail-show-message-hook)
+                 (gnus . gnus-article-prepare-hook)
+                 (mh . mh-show-hook)
+                 (vm . vm-select-message-hook)
+                 (wl . wl-message-redisplay-hook)))
+    (if (memq (car mua) muas)
+        (add-hook (cdr mua) 'bbdb-mua-auto-update)
+      (remove-hook (cdr mua) 'bbdb-mua-auto-update))))
+
+;;;###autoload
+(defun bbdb-auto-notes (record)
+  "Automatically annotate RECORD based on the headers of the current message.
+See the variables `bbdb-auto-notes-rules', `bbdb-auto-notes-ignore-messages'
+and `bbdb-auto-notes-ignore-headers'.
+For use as an element of `bbdb-notice-record-hook'."
+  ;; This code re-evaluates the annotations each time a message is viewed.
+  ;; It would be faster if we could somehow store (permanently?) that we
+  ;; have already annotated a message.
+  (let ((case-fold-search t))
+    (unless (or bbdb-read-only
+                ;; check the ignore-messages pattern
+                (let ((ignore-messages bbdb-auto-notes-ignore-messages)
+                      ignore rule)
+                  (while (and (not ignore) (setq rule (pop ignore-messages)))
+                    (if (cond ((functionp rule)
+                               ;; RULE may use `bbdb-update-records-address'
+                               (funcall rule record))
+                              ((symbolp rule)
+                               (eq rule (nth 4 bbdb-update-records-address)))
+                              ((eq 1 (safe-length rule))
+                               (bbdb-message-header-re (car rule) (cdr rule)))
+                              ((eq 2 (safe-length rule))
+                               (and (eq (car rule) (nth 4 bbdb-update-records-address))
+                                    (bbdb-message-header-re (nth 1 rule) (nth 2 rule)))))
+                        (setq ignore t)))
+                  ignore))
+      (bbdb-editable)
+
+      ;; For speed-up expanded rules are stored in `bbdb-auto-notes-rules-expanded'.
+      (when (and bbdb-auto-notes-rules
+                 (not bbdb-auto-notes-rules-expanded))
+        (let (expanded mua from-to header)
+          (dolist (rule bbdb-auto-notes-rules)
+            ;; Which MUA do we want?
+            (if (or (stringp (car rule))
+                    (stringp (nth 1 rule)))
+                (setq mua t)
+              (setq mua (if (symbolp (car rule)) (listp (car rule)) (car rule))
+                    rule (cdr rule)))
+            ;; Which FROM-TO headers do we want?
+            (if (stringp (car rule))
+                (setq from-to t)
+              (setq from-to (car rule)
+                    rule (cdr rule)))
+            (setq header (car rule))
+            (let (string field replace elt-e)
+              (dolist (elt (cdr rule))
+                (if (consp (setq string (cdr elt)))
+                    (setq field (car string) ; (REGEXP FIELD-NAME STRING REPLACE)
+                          replace (nth 2 string) ; perhaps nil
+                          string (nth 1 string))
+                  ;; else it's simple (REGEXP . STRING)
+                  (setq field bbdb-default-xfield
+                        replace nil))
+                (push (list (car elt) field string replace) elt-e))
+              (push (append (list mua from-to header) (nreverse elt-e)) expanded)))
+          (setq bbdb-auto-notes-rules-expanded (nreverse expanded))))
+
+      (dolist (rule bbdb-auto-notes-rules-expanded)
+        (let ((mua (car rule)) (from-to (nth 1 rule)) (header (nth 2 rule))
+              hd-val string annotation)
+          (when (and (or (eq mua t)
+                         (memq (nth 4 bbdb-update-records-address) mua))
+                     (or (eq from-to t)
+                         (member-ignore-case
+                          (nth 2 bbdb-update-records-address) from-to)
+                         (memq (nth 3 bbdb-update-records-address) from-to))
+                     (setq hd-val (bbdb-message-header header)))
+            (dolist (elt (nthcdr 3 rule))
+              (when (and (string-match (car elt) hd-val)
+                         (let ((ignore (cdr (assoc-string
+                                             header
+                                             bbdb-auto-notes-ignore-headers t))))
+                           (not (and ignore (string-match ignore hd-val)))))
+                (setq string (nth 2 elt)
+                      annotation
+                      (cond ((integerp string)
+                             (match-string string hd-val))
+                            ((stringp string)
+                             (replace-match string nil nil hd-val))
+                            ((functionp string)
+                             (funcall string hd-val))
+                            (t (error "Illegal value: %s" string))))
+                (bbdb-annotate-record record annotation
+                                      (nth 1 elt) (nth 3 elt))))))))))
+
+;;; Mark BBDB records in the MUA summary buffer
+
+(defun bbdb-mua-summary-unify (address)
+  "Unify mail ADDRESS displayed for a message in the MUA Summary buffer.
+Typically ADDRESS refers to the value of the From header of a message.
+If ADDRESS matches a record in BBDB display a unified name instead of ADDRESS
+in the MUA Summary buffer.
+
+Unification uses `bbdb-mua-summary-unification-list' (see there).
+The first match in this list becomes the text string displayed
+for a message in the MUA Summary buffer instead of ADDRESS.
+If variable `bbdb-mua-summary-mark' is non-nil use it to precede known addresses.
+Return the unified mail address.
+
+Currently this works with Gnus and VM.  It requires the BBDB insinuation
+of these MUAs.  Also, the MUA Summary format string must use
+`bbdb-mua-summary-unify-format-letter' (see there)."
+  ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
+  (let* ((data (bbdb-extract-address-components address))
+         (name (car data))
+         (mail (cadr data))
+         (record (car (bbdb-message-search name mail)))
+         (u-list bbdb-mua-summary-unification-list)
+         elt val)
+    (while (setq elt (pop u-list))
+      (setq val (cond ((eq elt 'message-name) name)
+                      ((eq elt 'message-mail) mail)
+                      ((eq elt 'message-address) address)
+                      (record (let ((result (bbdb-record-field record elt)))
+                                (if (stringp result) result
+                                  (car result)))))) ; RESULT is list.
+      (if val (setq u-list nil)))
+    (format "%s%s"
+            (cond ((not bbdb-mua-summary-mark) "")
+                  ((not record) " ")
+                  ((functionp bbdb-mua-summary-mark-field)
+                   (funcall bbdb-mua-summary-mark-field record))
+                  ((bbdb-record-xfield record bbdb-mua-summary-mark-field))
+                  (t bbdb-mua-summary-mark))
+            (or val name mail address "**UNKNOWN**"))))
+
+(defun bbdb-mua-summary-mark (address)
+  "In the MUA Summary buffer mark messages matching a BBDB record.
+ADDRESS typically refers to the value of the From header of a message.
+If ADDRESS matches a record in BBDB return a mark, \" \" otherwise.
+The mark itself is the value of the xfield `bbdb-mua-summary-mark-field'
+if this xfield is in the poster's record, and `bbdb-mua-summary-mark' otherwise."
+  (if (not bbdb-mua-summary-mark)
+      "" ; for consistency
+    ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
+    (let* ((data (bbdb-extract-address-components address))
+           (record (car (bbdb-message-search (car data) (cadr data)))))
+      (if record
+          (or (when (functionp bbdb-mua-summary-mark-field)
+                (funcall bbdb-mua-summary-mark-field record)
+                t)
+              (bbdb-record-xfield record bbdb-mua-summary-mark-field)
+              bbdb-mua-summary-mark)
+        " "))))
+
+(provide 'bbdb-mua)
+
+;;; bbdb-mua.el ends here