(bbdb/vm-update-records): Searching for existing records is limited to the

	net, as a search for a name may	no return the right record.
	Adding of new records can be controlled similar to query-replace,
	with y,!,n,s,q
	The new variable `bbdb/prompt-for-create-p' can be set to `t' in
	order to force VM to ask the user before adding a new BBBD record,
	caused by the automatic update of the popup buffer.

1 files changed, 118 insertions, 48 deletions

diff --git a/lisp/bbdb-vm.el b/lisp/bbdb-vm.el
index 73a4e3b..486516e 100644
--- a/lisp/bbdb-vm.el
+++ b/lisp/bbdb-vm.el
@@ -67,7 +67,7 @@ The headers to search can be configured by `bbdb/vm-get-from-headers'."
       (setq header (vm-get-header-contents msg (car headers)))
       (when header
     (setq adlist (bbdb-extract-address-components
-              (vm-decode-mime-encoded-words-in-string header)))
+		  (vm-decode-mime-encoded-words-in-string header)))
     (while adlist
       (setq fn (caar adlist)
         ad (cadar adlist))
@@ -77,10 +77,10 @@ The headers to search can be configured by `bbdb/vm-get-from-headers'."
       (if (or
            (not (stringp vm-summary-uninteresting-senders))
            (not
-        (or (and fn
-             (string-match vm-summary-uninteresting-senders fn))
-            (and ad
-             (string-match vm-summary-uninteresting-senders ad)))))
+	    (or (and fn
+		     (string-match vm-summary-uninteresting-senders fn))
+		(and ad
+		     (string-match vm-summary-uninteresting-senders ad)))))
           (add-to-list 'fromlist (car adlist)))
 
       (if (and only-first-from fromlist)
@@ -117,64 +117,132 @@ The headers to search can be configured by `bbdb/vm-get-from-headers'."
 
 ;;;###autoload
 (defun bbdb/vm-update-records (&optional offer-to-create)
-  "Returns the record corresponding to the current VM message,
-creating or modifying it as necessary.  A record will be created if
+  "Returns the records corresponding to the current VM message,
+creating or modifying them as necessary.  A record will be created if
 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 the user confirms the creation.
-When hitting C-g you will not be asked anymore for new people listed
-in this message."
+
+When hitting C-g once you will not be asked anymore for new people listed
+in this message, but it will search only for existing records.  When hitting
+C-g again it will stop scanning."
   (vm-select-folder-buffer)
   (vm-check-for-killed-summary)
   (vm-error-if-folder-empty)
 
   (let ((msg (car vm-message-pointer))
-    (inhibit-local-variables nil)   ; vm binds this to t...
-    (enable-local-variables t)  ; ...or vm bind this to nil.
-    (inhibit-quit nil)      ; vm better not bind this to t!
-    cache records)
+	(inhibit-local-variables nil)   ; vm binds this to t...
+	(enable-local-variables t)	; ...or vm bind this to nil.
+	(inhibit-quit nil)		; vm better not bind this to t!
+	(bbdb/vm-offer-to-create offer-to-create)
+	cache records)
 
     ;; ignore cache if we may be creating a record, since the cache
     ;; may otherwise tell us that the user didn't want a record for
     ;; this person.
-    (if (not offer-to-create)
+    (if (not bbdb/vm-offer-to-create)
         (setq cache (and msg (bbdb/vm-message-cache-lookup msg))))
 
     (if cache
         (setq records (if bbdb/vm-get-only-first-from-p
-                          (if (cadr cache) ;; stop it from returning '(nil)
+                          (if (cadr cache);; stop it from returning '(nil)
                               (list (cadr cache))
                             nil)
                         (cdr cache)))
       (and msg
            (let ((addrs (bbdb/vm-get-from msg bbdb/vm-get-only-first-from-p))
                  (bbdb-records (bbdb-records))
-                 rec
-                 (create-p t))
-             (mapc (lambda (address)
-                     (condition-case nil
-                         (setq rec
-                               (if create-p
-                                   (bbdb-annotate-message-sender
-                                    address t
-                                    (or (bbdb-invoke-hook-for-value
-                                         bbdb/mail-auto-create-p)
-                                        offer-to-create) ;; force create
-                                    t)
-                                 (let ((name (car address))
-                                       (net (cadr address)))
-                                   (if name
-                                       (setq name (bbdb-search bbdb-records
-                                                               name nil net)))
-                                   (if name (car name) nil))))
-                       (quit (setq create-p nil)))
-                     ;; people should be listed only once so we use
-                     ;; add-to-list
-                     (if rec (add-to-list 'records rec)))
-                   addrs)
+		 (processed-addresses 0)
+		 (bbdb/vm-update-records-mode 'annotating)
+		 rec)
+             (mapc (lambda (bbdb/vm-address)
+		     (condition-case nil
+			 (progn
+			   (setq rec
+				 (cond ((eq bbdb/vm-update-records-mode
+					    'annotating)
+					(bbdb-annotate-message-sender
+					 bbdb/vm-address t
+					 (or (bbdb-invoke-hook-for-value
+					      bbdb/mail-auto-create-p)
+					     bbdb/vm-offer-to-create);; force create
+					 'bbdb/vm-prompt-for-create))
+				       ((eq bbdb/vm-update-records-mode 'searching)
+					;; search for the first record having
+					;; this net  
+					(let ((net (cadr bbdb/vm-address))
+					      record)
+					  (setq record (bbdb-search
+							bbdb-records
+							nil nil net))
+					  (if record (car record) nil))))
+				 processed-addresses (+ processed-addresses 1))
+			   (when (and (not (eq bbdb/vm-offer-to-create 'quit))
+				      (= 0 (% processed-addresses 5)))
+			     (display-message 'progress
+			       (format "Hit C-g to stop BBDB from %s.  %d of %d addresses processed." bbdb/vm-update-records-mode processed-addresses (length addrs)))
+			     (sit-for 0))
+			   )
+		       (quit (cond ((eq bbdb/vm-update-records-mode
+					'annotating)
+				    (setq bbdb/vm-update-records-mode
+					  'searching))
+				   ((eq bbdb/vm-update-records-mode 'searching)
+				    nil)
+				   ((eq bbdb/vm-update-records-mode 'next)
+				    (setq bbdb/vm-update-records-mode
+					  'annotating))
+				   (t
+				    (setq bbdb/vm-update-records-mode 'quit)))
+			     nil))
+
+		     ;; people should be listed only once so we use
+		     ;; add-to-list
+		     (if rec (add-to-list 'records rec)))
+
+		   addrs)
              (setq records (nreverse records))
              (bbdb/vm-encache-message msg records))))
     records))
 
+(defvar bbdb/vm-offer-to-create nil
+  "Used for inter-function communication between the functions
+`bbdb/vm-update-records' and `bbdb/vm-prompt-for-create'.")
+(defvar bbdb/vm-update-records-mode nil
+  "Used for inter-function communication between the functions
+`bbdb/vm-update-records' and `bbdb/vm-prompt-for-create'.")
+(defvar bbdb/vm-address nil
+  "Used for inter-function communication between the functions
+`bbdb/vm-update-records' and `bbdb/vm-prompt-for-create'.")
+
+;; This is a hack.  The function is called by bbdb-annotate-message-sender and
+;; uses the above variable in order to manipulate bbdb/vm-update-records.
+;; Some cases are handled with signals in order to keep the changes in 
+;; bbdb-annotate-message-sender as minimal as possible.
+(defun bbdb/vm-prompt-for-create ()
+  (let ((old-offer-to-create bbdb/vm-offer-to-create))
+    (when (or (bbdb-invoke-hook-for-value bbdb/prompt-for-create-p)
+	      bbdb/vm-offer-to-create)
+      (when (not (characterp bbdb/vm-offer-to-create))
+	(message (format "%s is not in the db; add? (y,!,n,s,q)"
+			 (or (car bbdb/vm-address) (cadr bbdb/vm-address))))
+	(setq bbdb/vm-offer-to-create (read-char)))
+      
+      (cond ((eq bbdb/vm-offer-to-create ?y)
+	     (setq bbdb/vm-offer-to-create old-offer-to-create)
+	     nil) 
+	    ((eq bbdb/vm-offer-to-create ?!)
+	     nil)
+	    ((eq bbdb/vm-offer-to-create ?n)
+	     (setq bbdb/vm-update-records-mode 'next
+		   bbdb/vm-offer-to-create old-offer-to-create)
+	     (signal 'quit nil))
+	    ((eq bbdb/vm-offer-to-create ?q)
+	     (setq bbdb/vm-update-records-mode 'quit)
+	     (signal 'quit nil))
+	    ((eq bbdb/vm-offer-to-create ?s)
+	     (setq bbdb/vm-update-records-mode 'searching)
+	     (signal 'quit nil))))))
+	  
 ;;;###autoload
 (defun bbdb/vm-annotate-sender (string &optional replace)
   "Add a line to the end of the Notes field of the BBDB record
@@ -254,13 +322,14 @@ configuration of what is being displayed."
 Respects vm-summary-uninteresting-senders."
   (if (and vm-summary-uninteresting-senders (not to-p))
       (let ((case-fold-search nil))
-    (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
-        (concat vm-summary-uninteresting-senders-arrow
-            (vm-summary-function-B m t))
-      (or (bbdb/vm-alternate-full-name  (vm-su-from m))
-          (vm-su-full-name m))))
+	(if (string-match vm-summary-uninteresting-senders (vm-su-from m))
+	    (concat vm-summary-uninteresting-senders-arrow
+		    (vm-summary-function-B m t))
+	  (or (bbdb/vm-alternate-full-name  (vm-su-from m))
+	      (vm-su-full-name m))))
     (or (bbdb/vm-alternate-full-name (if to-p (vm-su-to m) (vm-su-from m)))
-    (if to-p (vm-su-to-names m) (vm-su-full-name m)))))
+	(vm-decode-mime-encoded-words-in-string
+	 (if to-p (vm-su-to-names m) (vm-su-full-name m))))))
 
 (defun bbdb/vm-alternate-full-name (address)
   (if address
@@ -394,7 +463,11 @@ matches a value in `bbdb/vm-auto-add-label-list' then a VM
 label will be added to the message.
 
 This works great when `bbdb-user-mail-names' is set.  As a result
-mail that you send to people (and copy yourself on) is labeled as well."
+mail that you send to people (and copy yourself on) is labeled as well.
+
+This is how you hook it in.
+;;   (add-hook 'bbdb-notice-hook 'bbdb/vm-auto-add-label)
+"
   (let (field aliases sep)
     (and (eq major-mode 'vm-mode)
      (mapcar #'(lambda(x)
@@ -425,9 +498,6 @@ mail that you send to people (and copy yourself on) is labeled as well."
              " ")
       1))))
 
-;; this is how you hook it in.
-;;(add-hook 'bbdb-notice-hook 'bbdb/vm-auto-add-label)
-
 
 ;;;###autoload
 (defun bbdb-insinuate-vm ()