diff options
Diffstat (limited to 'html/patches/multi-record.patch')
-rw-r--r-- | html/patches/multi-record.patch | 1493 |
1 files changed, 1493 insertions, 0 deletions
diff --git a/html/patches/multi-record.patch b/html/patches/multi-record.patch new file mode 100644 index 0000000..e664ea2 --- /dev/null +++ b/html/patches/multi-record.patch @@ -0,0 +1,1493 @@ +I have split all my diffs into three sets: + +#1 Removed a number of unused variables (cleaned up builds so I + could see real errors). Small changes in a few auxiliary bbdb files. + Very low risk, but very little gain. + +#2 Small patch to bbdb-print.el adds support for abbreviating 'places' + in phone numbers. Fairly low risk, moderate gain. + +#3 Large patch to bbdb-com.el and bbdb.el (small patch to bbdb-gnus.el) + To support 'duplicate' entries in bbdb. This defines a new variable + bbdb-no-duplicates-p, when true bbdb will not allows new duplicate + records to be defined. + + The largest single change is to the completing read support. + The format of the hash table is also changed. + + Moderate risk (I've been using it daily for almost a year now), + significant gain in functionality. + +diff -ur bbdb-2.00.06/lisp/bbdb-gnus.el bbdb-2.01/lisp/bbdb-gnus.el +--- bbdb-2.00.06/lisp/bbdb-gnus.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-gnus.el Tue Sep 28 11:01:14 1999 +@@ -42,8 +42,7 @@ + (or (search-forward "\n\n" nil t) + (error "message unexists")) + (- (point) 2))) +- (let ((from (mail-fetch-field "from")) +- name net) ++ (let ((from (mail-fetch-field "from"))) + (if (or (null from) + (string-match (bbdb-user-mail-names) + (mail-strip-quoted-names from))) +diff -ur bbdb-2.00.06/lisp/bbdb-mhe.el bbdb-2.01/lisp/bbdb-mhe.el +--- bbdb-2.00.06/lisp/bbdb-mhe.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-mhe.el Tue Sep 28 11:01:17 1999 +@@ -71,8 +71,7 @@ + (let ((msg (bbdb/mh-cache-key buffer-file-name))) + (if (eq msg 0) (setq msg nil)) ; 0 could mean trouble; be safe. + (or (bbdb-message-cache-lookup msg nil) ; nil = current-buffer +- (let ((from (bbdb/mh-get-field "^From[ \t]*:")) +- name net) ++ (let ((from (bbdb/mh-get-field "^From[ \t]*:"))) + (if (or (string= "" from) + (string-match (bbdb-user-mail-names) + (mail-strip-quoted-names from))) +diff -ur bbdb-2.00.06/lisp/bbdb-migrate.el bbdb-2.01/lisp/bbdb-migrate.el +--- bbdb-2.00.06/lisp/bbdb-migrate.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-migrate.el Tue Sep 28 11:01:17 1999 +@@ -97,7 +97,7 @@ + (cond + ;; Version 2 -> 3 + ((= (car bbdb-file-format-migration) 2) +- (let (newrecs currec) ++ (let (newrecs) + (while records + (setq newrecs (append newrecs + (list (bbdb-migrate-record +diff -ur bbdb-2.00.06/lisp/bbdb-rmail.el bbdb-2.01/lisp/bbdb-rmail.el +--- bbdb-2.00.06/lisp/bbdb-rmail.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-rmail.el Tue Sep 28 11:01:18 1999 +@@ -51,8 +51,7 @@ + (if rmail-current-message + (or (bbdb-message-cache-lookup rmail-current-message nil) + (save-excursion +- (let ((from (mail-fetch-field "from")) +- name net) ++ (let ((from (mail-fetch-field "from"))) + (if (or (null from) + (string-match (bbdb-user-mail-names) + (mail-strip-quoted-names from))) + +--OqlPABmjKp +Content-Type: text/plain +Content-Description: Add support for 'places' abbreviations (ala palm) +Content-Disposition: inline; + filename="bbdb-print-diffs" +Content-Transfer-Encoding: 7bit + +diff -ur bbdb-2.00.06/lisp/bbdb-print.el bbdb-2.01/lisp/bbdb-print.el +--- bbdb-2.00.06/lisp/bbdb-print.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-print.el Tue Sep 28 11:01:17 1999 +@@ -241,6 +241,11 @@ + which should be a valid regular expression. + - n-phones: maximum number of phone numbers to include. + - n-addresses: maximum number of addresses to include. ++ - place-abbrev: Abbreviation for phone number 'places'. This is a ++ list of pairs the first element is the full string to be matched ++ the second element is the replacement text. This can be used in ++ any of the bbdb-print-*-alist variables. This allows you to ++ expand as well as contract 'place' names. + - include-files: list of TeX files to \\input. If these filenames are not + absolute, the files must be located somewhere that TeX will find them. + - ps-fonts: nonnil means to use them, nil to use standard TeX fonts. +@@ -270,6 +275,8 @@ + (separator . 1) + (n-phones . 2) + (n-addresses . 1) ++ (place-abbrev ("Work" . "W") ++ ("Home" . "H")) + (include-files "bbdb-print-brief" "bbdb-cols")) + "*Extra Options for bbdb-print, brief format. + These supplement or override entries in `bbdb-print-alist'; see description +@@ -403,8 +410,7 @@ + (bbdb-record-phones record))) + (address (and (bbdb-field-shown-p 'address) + (bbdb-record-addresses record))) +- (notes (bbdb-record-raw-notes record)) +- (begin (point))) ++ (notes (bbdb-record-raw-notes record))) + + (if (not (eval bbdb-print-require)) + nil ; lacks required fields +@@ -423,7 +429,10 @@ + (setq name (bbdb-print-tex-quote company) + company nil)) + +- (let ((rightside "") p) ++ ;; Expand Phone numbers if needed... ++ (if n-phones (setq phone (bbdb-print-firstn n-phones phone brief))) ++ ++ (let ((rightside "")) + (cond ((null phone)) + ((eq t pofl) + (setq rightside (bbdb-print-phone-string (car phone)) +@@ -431,7 +440,7 @@ + ((stringp pofl) + (let ((p (bbdb-print-front-if + (function (lambda (ph) +- (string-match pofl (aref ph 0)))) ++ (if ph (string-match pofl (aref ph 0))))) + phone))) + (if p + (setq rightside (bbdb-print-phone-string (car p)) +@@ -443,19 +452,16 @@ + (if company + (insert (format "\\comp{%s}\n" (bbdb-print-tex-quote company)))) + +- ;; Phone numbers +- +- (if n-phones +- (setq phone (bbdb-print-firstn (- n-phones (if pofl 1 0)) +- phone brief))) + (while phone + (if (car phone) +- (let ((place (aref (car phone) 0)) ++ (let ((place (bbdb-print-abbrev-place (aref (car phone) 0) brief)) + (number (bbdb-print-phone-string (car phone)))) + (insert (format "\\phone{%s%s}\n" + (bbdb-print-tex-quote +- (bbdb-print-if-not-blank place ": ")) +- (bbdb-print-tex-quote number)))) ++ (bbdb-print-if-not-blank place ":")) ++ (bbdb-print-tex-quote number) ++ )) ++ ) + (insert (format "\\phone{}\n"))) + (setq phone (cdr phone))) + +@@ -522,6 +528,27 @@ + (setq current-letter first-letter))) + + current-letter) ++ ++(defun bbdb-print-abbrev-place (place &optional brief) ++ "See if there is an abbreviation for PLACE if so return that" ++ ++ (let* ((alist (append (if brief bbdb-print-brief-alist bbdb-print-full-alist) ++ bbdb-print-alist)) ++ (abbrevs (cdr (assoc 'place-abbrev alist))) ++ (ret place) ++ abbrev) ++ (while abbrevs ++ (setq abbrev (car abbrevs)) ++ (if (string-match (car abbrev) place) ++ (setq abbrevs '() ++ ret (cdr abbrev)) ++ (setq abbrevs (cdr abbrevs)) ++ ) ++ ) ++ ret ++ ) ++ ) ++ + + (defun bbdb-print-phone-string (phone) + "Format PHONE-NUMBER as a string, obeying omit-area-code setting. + +--OqlPABmjKp +Content-Type: text/plain +Content-Description: Add support for duplicate records to bbdb. +Content-Disposition: inline; + filename="bbdb-duplicate-diffs" +Content-Transfer-Encoding: 7bit + +diff -ur bbdb-2.00.06/lisp/bbdb-com.el bbdb-2.01/lisp/bbdb-com.el +--- bbdb-2.00.06/lisp/bbdb-com.el Tue Sep 28 09:56:39 1999 ++++ bbdb-2.01/lisp/bbdb-com.el Tue Feb 29 11:20:07 2000 +@@ -201,10 +201,10 @@ + (bbdb-with-db-buffer + bbdb-changed-records)))) + +-(defun bbdb-display (record) ++(defun bbdb-display (records) + "Prompts for and displays a single record (this is faster than searching.)" + (interactive (list (bbdb-completing-read-record "Display record of: "))) +- (bbdb-display-records (list record))) ++ (bbdb-display-records records)) + + (defun bbdb-display-some (function) + "Display records according to FUNCTION. FUNCTION is called with one +@@ -366,9 +366,10 @@ + lastname (nth 1 names)))) + (if (string= firstname "") (setq firstname nil)) + (if (string= lastname "") (setq lastname nil)) +- (if (bbdb-gethash (downcase (if (and firstname lastname) (concat firstname " " lastname) +- (or firstname lastname "")))) +- (error "%s %s is already in the database" (or firstname "") (or lastname ""))))) ++ (if (and bbdb-no-duplicates-p ++ (bbdb-gethash (bbdb-build-name firstname lastname))) ++ (error "%s %s is already in the database" ++ (or firstname "") (or lastname ""))))) + (let ((company (bbdb-read-string "Company: ")) + (net (bbdb-split (bbdb-read-string "Network Address: ") ",")) + (addrs (let (L L-tail str addr) +@@ -456,26 +457,28 @@ + [\"location\" \"phone-number\"] + NOTES is a string, or an alist associating symbols with strings." + (let (firstname lastname aka) +- (while (progn +- (setq name (and name (bbdb-divide-name name))) +- (setq firstname (car name) lastname (nth 1 name)) +- (bbdb-gethash (downcase (if (and firstname lastname) +- (concat firstname " " lastname) +- (or firstname lastname ""))))) ++ (while (and (progn ++ (setq name (and name (bbdb-divide-name name)) ++ firstname (car name) ++ lastname (nth 1 name)) ++ (bbdb-gethash (bbdb-build-name firstname lastname))) ++ bbdb-no-duplicates-p) + (setq name (signal 'error + (list (format "%s %s is already in the database" + (or firstname "") (or lastname "")))))) + (and company (bbdb-check-type company stringp)) + (if (stringp net) + (setq net (bbdb-split net ","))) +- (let ((rest net)) +- (while rest +- (while (bbdb-gethash (downcase (car rest))) +- (setcar rest +- (signal 'error (list (format +- "%s is already in the database" +- (car rest)))))) +- (setq rest (cdr rest)))) ++ (if bbdb-no-duplicates-p ++ (let ((rest net)) ++ (while rest ++ (while (bbdb-gethash (downcase (car rest))) ++ (setcar rest ++ (signal 'error (list (format ++ "%s is already in the database" ++ (car rest)))))) ++ (setq rest (cdr rest)))) ++ ) + (setq addrs + (mapcar + (function (lambda (addr) +@@ -587,7 +590,8 @@ + ;; get to beginning of this record + (beginning-of-line) + (let ((p (point))) +- (while (not (or (eobp) (bobp) (looking-at "^[^ \t\n]"))) ++ ;; ' - ' is the start of a record with no name. ++ (while (not (or (eobp) (bobp) (looking-at "^\\([^ \t\n]\\| - \\)"))) + (forward-line -1)) + (let* ((record (or (bbdb-current-record planning-on-modifying) + (error "unperson"))) +@@ -704,14 +708,17 @@ + (if (stringp contents) + (setq contents (bbdb-split contents ","))) + ;; first detect any conflicts.... +- (let ((nets contents)) +- (while nets +- (let ((old (bbdb-gethash (downcase (car nets))))) +- (if (and old (not (eq old record))) +- (error "net address \"%s\" is used by \"%s\"" +- (car nets) +- (or (bbdb-record-name old) (car (bbdb-record-net old)))))) +- (setq nets (cdr nets)))) ++ (if bbdb-no-duplicates-p ++ (let ((nets contents)) ++ (while nets ++ (let ((old (bbdb-gethash (downcase (car nets))))) ++ (if (and old (not (eq old record))) ++ (error "net address \"%s\" is used by \"%s\"" ++ (car nets) ++ (or (bbdb-record-name old) ++ (car (bbdb-record-net old)))))) ++ (setq nets (cdr nets)))) ++ ) + ;; then store. + (let ((nets contents)) + (while nets +@@ -725,15 +732,17 @@ + (if (stringp contents) + (setq contents (bbdb-split contents ";"))) + ;; first detect any conflicts.... +- (let ((aka contents)) +- (while aka +- (let ((old (bbdb-gethash (downcase (car aka))))) +- (if (and old (not (eq old record))) +- (error "alternate name \"%s\" is used by \"%s\"" +- (car aka) +- (or (bbdb-record-name old) +- (car (bbdb-record-net old)))))) +- (setq aka (cdr aka)))) ++ (if bbdb-no-duplicates-p ++ (let ((aka contents)) ++ (while aka ++ (let ((old (bbdb-gethash (downcase (car aka))))) ++ (if (and old (not (eq old record))) ++ (error "alternate name \"%s\" is used by \"%s\"" ++ (car aka) ++ (or (bbdb-record-name old) ++ (car (bbdb-record-net old)))))) ++ (setq aka (cdr aka)))) ++ ) + ;; then store. + (let ((aka contents)) + (while aka +@@ -832,7 +841,8 @@ + (setq new-name (if (and fn ln) (concat fn " " ln) + (or fn ln)) + old-name (bbdb-record-name bbdb-record)) +- (if (and new-name ++ (if (and bbdb-no-duplicates-p ++ new-name + (not (and old-name (string= (downcase new-name) + (downcase old-name)))) + (bbdb-gethash (downcase new-name))) +@@ -847,8 +857,13 @@ + "")))))) + ;; + ;; delete the old hash entry +- (and (bbdb-record-name bbdb-record) +- (bbdb-remhash (downcase (bbdb-record-name bbdb-record)))) ++ (let ((name (bbdb-record-name bbdb-record)) ++ (company (bbdb-record-company bbdb-record))) ++ (if (> (length name) 0) ++ (bbdb-remhash (downcase name) bbdb-record)) ++ (if (> (length company) 0) ++ (bbdb-remhash (downcase company) bbdb-record)) ++ ) + (bbdb-record-set-namecache bbdb-record nil) + (bbdb-record-set-firstname bbdb-record fn) + (bbdb-record-set-lastname bbdb-record ln) +@@ -906,17 +921,19 @@ + (let ((oldnets (bbdb-record-net bbdb-record)) + (newnets (bbdb-split str ","))) + ;; first check for any conflicts... +- (let ((rest newnets)) +- (while rest +- (let ((old (bbdb-gethash (downcase (car rest))))) +- (if (and old (not (eq old bbdb-record))) +- (error "net address \"%s\" is used by \"%s\"" +- (car rest) (bbdb-record-name old)))) +- (setq rest (cdr rest)))) ++ (if bbdb-no-duplicates-p ++ (let ((rest newnets)) ++ (while rest ++ (let ((old (bbdb-gethash (downcase (car rest))))) ++ (if (and old (not (eq old bbdb-record))) ++ (error "net address \"%s\" is used by \"%s\"" ++ (car rest) (bbdb-record-name old)))) ++ (setq rest (cdr rest)))) ++ ) + ;; then update. + (let ((rest oldnets)) + (while rest +- (bbdb-remhash (downcase (car rest))) ++ (bbdb-remhash (downcase (car rest)) bbdb-record) + (setq rest (cdr rest)))) + (let ((nets newnets)) + (while nets +@@ -934,17 +951,19 @@ + (let ((oldaka (bbdb-record-aka bbdb-record)) + (newaka (bbdb-split str ";"))) + ;; first check for any conflicts... +- (let ((rest newaka)) +- (while rest +- (let ((old (bbdb-gethash (downcase (car rest))))) +- (if (and old (not (eq old bbdb-record))) +- (error "alternate name address \"%s\" is used by \"%s\"" +- (car rest) (bbdb-record-name old)))) +- (setq rest (cdr rest)))) ++ (if bbdb-no-duplicates-p ++ (let ((rest newaka)) ++ (while rest ++ (let ((old (bbdb-gethash (downcase (car rest))))) ++ (if (and old (not (eq old bbdb-record))) ++ (error "alternate name address \"%s\" is used by \"%s\"" ++ (car rest) (bbdb-record-name old)))) ++ (setq rest (cdr rest)))) ++ ) + ;; then update. + (let ((rest oldaka)) + (while rest +- (bbdb-remhash (downcase (car rest))) ++ (bbdb-remhash (downcase (car rest)) bbdb-record) + (setq rest (cdr rest)))) + (let ((aka newaka)) + (while aka +@@ -1115,7 +1134,7 @@ + ((memq type '(net aka)) + (let ((rest (bbdb-record-get-field-internal record type))) + (while rest +- (bbdb-remhash (downcase (car rest))) ++ (bbdb-remhash (downcase (car rest)) record) + (setq rest (cdr rest)))) + (bbdb-record-store-field-internal record type nil)) + ((eq type 'property) +@@ -1276,6 +1295,140 @@ + string1 + string2)) + ++(defun bbdb-merge-lists! (l1 l2 cmp &optional mod) ++ "Merge two lists l1 l2 (modifies l1) only adds elements from l2 ++if cmp returns false for all elements of l1. If optional mod ++is provided it is applied to each element of l1 and l2 prior to cmp" ++ (if (null l1) ++ l2 ++ (let ((end (last l1)) ++ (src2 l2) ++ (chk (if mod (mapcar mod l1) (append l1 '())))) ++ (while src2 ++ (let ((fail '()) ++ (src1 chk) ++ (val (if mod (apply mod (car src2) '()) (car src2)))) ++ (while src1 ++ (if (apply cmp (car src1) val '()) ++ (setq src1 '() ++ fail 't) ++ (setq src1 (cdr src1)))) ++ (if fail '() ++ (setcdr end (cons (car src2) '())) ++ (setq end (cdr end))) ++ (setq src2 (cdr src2)))) ++ l1))) ++ ++(defun bbdb-merge-records (old-record new-record) ++"Merge the contents of old-record into new-record, old-record ++remains unchanged. For name and company it queries about which to use ++if they differ. All other fields are concatinated. Idealy this would ++be better about checking for duplicate entires in other fields, as ++well as possibly querying about differing values. ++ ++This function does nothing to ensure the integrity of the rest of the ++database, that is somebody elses problem (something like ++bbdb-refile-record)." ++ ++ (if (or (null new-record) (eq old-record new-record)) ++ (error "those are the same")) ++ (let ((new-name (bbdb-record-name new-record)) ++ (new-co (bbdb-record-company new-record)) ++ (old-name (bbdb-record-name old-record)) ++ (old-co (bbdb-record-company old-record)) ++ (old-nets (bbdb-record-net old-record)) ++ (old-aka (bbdb-record-aka old-record)) ++ extra-name) ++ (let ((name ++ (cond ((= 0 (length old-name)) ++ (cons (bbdb-record-firstname new-record) ++ (bbdb-record-lastname new-record))) ++ ((= 0 (length new-name)) ++ (cons (bbdb-record-firstname old-record) ++ (bbdb-record-lastname old-record))) ++ ((string-equal (downcase old-name) (downcase new-name)) ++ (cons (bbdb-record-firstname new-record) ++ (bbdb-record-lastname new-record))) ++ (t (prog1 ++ (if (bbdb-y-or-n-p ++ (format "Use name \"%s\" instead of \"%s\"? " ++ old-name new-name)) ++ (progn ++ (setq extra-name new-record) ++ (cons (bbdb-record-firstname old-record) ++ (bbdb-record-lastname old-record))) ++ (setq extra-name old-record) ++ (cons (bbdb-record-firstname new-record) ++ (bbdb-record-lastname new-record))) ++ (or (and bbdb-use-alternate-names ++ (bbdb-y-or-n-p ++ (format "Keep \"%s\" as an alternate name? " ++ (bbdb-record-name extra-name)))) ++ (setq extra-name nil)) ++ )) ++ )) ++ (comp (cond ((= 0 (length old-co)) new-co) ++ ((= 0 (length new-co)) old-co) ++ ((string-equal old-co new-co) new-co) ++ (t (if (bbdb-y-or-n-p ++ (format "Use company \"%s\" instead of \"%s\"? " ++ old-co new-co)) ++ old-co new-co)))) ++ ) ++ ++ (if extra-name ++ (setq old-aka (cons (bbdb-record-name extra-name) old-aka))) ++ ++ (bbdb-record-set-phones new-record ++ (bbdb-merge-lists! ++ (bbdb-record-phones new-record) ++ (bbdb-record-phones old-record) ++ 'equal)) ++ (bbdb-record-set-addresses new-record ++ (bbdb-merge-lists! ++ (bbdb-record-addresses new-record) ++ (bbdb-record-addresses old-record) ++ 'equal)) ++ (bbdb-record-set-company new-record comp) ++ ++ (let ((n1 (bbdb-record-raw-notes new-record)) ++ (n2 (bbdb-record-raw-notes old-record)) ++ tmp) ++ (or (equal n1 n2) ++ (progn ++ (or (listp n1) (setq n1 (list (cons 'notes n1)))) ++ (or (listp n2) (setq n2 (list (cons 'notes n2)))) ++ (while n2 ++ (if (setq tmp (assq (car (car n2)) n1)) ++ (setcdr tmp ++ (funcall (or (cdr (assq (car (car n2)) ++ bbdb-refile-notes-generate-alist)) ++ bbdb-refile-notes-default-merge-function) ++ (cdr tmp) (cdr (car n2)))) ++ (setq n1 (nconc n1 (list (car n2))))) ++ (setq n2 (cdr n2))) ++ (bbdb-record-set-raw-notes new-record n1) ++ ) ++ ) ++ ) ++ ++ (bbdb-record-set-firstname new-record (car name)) ++ (bbdb-record-set-lastname new-record (cdr name)) ++ (bbdb-record-set-namecache new-record nil) ++ ++ (bbdb-record-set-net new-record ++ (bbdb-merge-lists! ++ (bbdb-record-net new-record) old-nets ++ 'string= 'downcase)) ++ (bbdb-record-set-aka new-record ++ (bbdb-merge-lists! ++ (bbdb-record-aka new-record) old-aka ++ 'string= 'downcase)) ++ new-record ++ ) ++ ) ++ ) ++ + ;;;###autoload + (defun bbdb-refile-record (old-record new-record) + "Merge the current record into some other record; that is, delete the +@@ -1290,99 +1443,27 @@ + (interactive + (let ((r (bbdb-current-record))) + (list r +- (bbdb-completing-read-record ++ (bbdb-completing-read-one-record + (format "merge record \"%s\" into: " + (or (bbdb-record-name r) (car (bbdb-record-net r)) +- "???")))))) ++ "???")) (list r))))) + (if (or (null new-record) (eq old-record new-record)) + (error "those are the same")) +- (let*(extra-name +- (name +- (cond ((and (/= 0 (length (bbdb-record-name old-record))) +- (/= 0 (length (bbdb-record-name new-record)))) +- (prog1 +- (if (bbdb-y-or-n-p +- (format "Use name \"%s\" instead of \"%s\"? " +- (bbdb-record-name old-record) +- (bbdb-record-name new-record))) +- (progn +- (setq extra-name new-record) +- (cons (bbdb-record-firstname old-record) +- (bbdb-record-lastname old-record))) +- (setq extra-name old-record) +- (cons (bbdb-record-firstname new-record) +- (bbdb-record-lastname new-record))) +- (or (and bbdb-use-alternate-names +- (bbdb-y-or-n-p +- (format "Keep \"%s\" as an alternate name? " +- (bbdb-record-name extra-name)))) +- (setq extra-name nil)) +- )) +- ((= 0 (length (bbdb-record-name old-record))) +- (cons (bbdb-record-firstname new-record) +- (bbdb-record-lastname new-record))) +- (t (cons (bbdb-record-firstname old-record) +- (bbdb-record-lastname old-record))))) +- (comp +- (cond ((and (/= 0 (length (bbdb-record-company old-record))) +- (/= 0 (length (bbdb-record-company new-record)))) +- (if (bbdb-y-or-n-p (format +- "Use company \"%s\" instead of \"%s\"? " +- (bbdb-record-company old-record) +- (bbdb-record-company new-record))) +- (bbdb-record-company old-record) +- (bbdb-record-company new-record))) +- ((= 0 (length (bbdb-record-company old-record))) +- (bbdb-record-company new-record)) +- (t (bbdb-record-company old-record)))) +- (old-nets (bbdb-record-net old-record)) +- (old-aka (bbdb-record-aka old-record)) +- ) +- (if extra-name +- (setq old-aka (cons (bbdb-record-name extra-name) old-aka))) +- (bbdb-record-set-phones new-record +- (nconc (bbdb-record-phones new-record) +- (bbdb-record-phones old-record))) +- (bbdb-record-set-addresses new-record +- (nconc (bbdb-record-addresses new-record) +- (bbdb-record-addresses old-record))) +- (bbdb-record-set-company new-record comp) +- (let ((n1 (bbdb-record-raw-notes new-record)) +- (n2 (bbdb-record-raw-notes old-record)) +- tmp) +- (or (equal n1 n2) +- (progn +- (or (listp n1) (setq n1 (list (cons 'notes n1)))) +- (or (listp n2) (setq n2 (list (cons 'notes n2)))) +- (while n2 +- (if (setq tmp (assq (car (car n2)) n1)) +- (setcdr tmp +- (funcall (or (cdr (assq (car (car n2)) +- bbdb-refile-notes-generate-alist)) +- bbdb-refile-notes-default-merge-function) +- (cdr tmp) (cdr (car n2)))) +- (setq n1 (nconc n1 (list (car n2))))) +- (setq n2 (cdr n2))) +- (bbdb-record-set-raw-notes new-record n1)))) +- (bbdb-delete-current-record old-record 'noprompt) +- (bbdb-record-set-net new-record +- (nconc (bbdb-record-net new-record) old-nets)) +- (bbdb-record-set-firstname new-record (car name)) +- (bbdb-record-set-lastname new-record (cdr name)) +- (bbdb-record-set-namecache new-record nil) +- (bbdb-record-set-aka new-record +- (nconc (bbdb-record-aka new-record) old-aka)) +- (bbdb-change-record new-record t) ; don't always need-to-sort... +- (let ((bbdb-elided-display nil)) +- (if (assq new-record bbdb-records) +- (bbdb-redisplay-one-record new-record)) +- (bbdb-with-db-buffer +- (if (not (memq new-record bbdb-changed-records)) +- (setq bbdb-changed-records +- (cons new-record bbdb-changed-records)))) +- (if (null bbdb-records) ; nothing displayed, display something. +- (bbdb-display-records (list new-record))))) +- (message "records merged.")) ++ (setq new-record (bbdb-merge-records old-record new-record)) ++ ++ (bbdb-delete-current-record old-record 'noprompt) ++ (bbdb-change-record new-record t) ; don't always need-to-sort... ++ (let ((bbdb-elided-display nil)) ++ (if (assq new-record bbdb-records) ++ (bbdb-redisplay-one-record new-record)) ++ (bbdb-with-db-buffer ++ (if (not (memq new-record bbdb-changed-records)) ++ (setq bbdb-changed-records ++ (cons new-record bbdb-changed-records)))) ++ (if (null bbdb-records) ; nothing displayed, display something. ++ (bbdb-display-records (list new-record)))) ++ (message "records merged.") ++ ) + + + ;;; Send-Mail interface +@@ -1613,47 +1694,97 @@ + + ;;; completion + ++(defun bbdb-completion-check-record (sym rec) ++ (let ((name (downcase (or (bbdb-record-name rec) ++ (bbdb-record-company rec)))) ++ (nets (bbdb-record-net rec)) ++ ok) ++ ++ (if (null bbdb-completion-type) ++ (setq ok 't) ++ (if (memq bbdb-completion-type ++ '(name primary-or-name name-or-primary)) ++ (setq ok (string= sym name))) ++ ++ ;; #### handle AKA, mail-name or mail-alias here? ++ (if ok '() ++ (if (eq bbdb-completion-type 'net) ++ (while (and nets (not ok)) ++ (setq ok (string= sym (downcase (car nets))) ++ nets (cdr nets)))) ++ (if (memq bbdb-completion-type ++ '(primary primary-or-name name-or-primary)) ++ (setq ok (string= sym (downcase (car nets)))) ++ ) ++ ) ++ ) ++ ok ++ ) ++ ) ++ ++ + ;;;###autoload + (defun bbdb-completion-predicate (symbol) + "For use as the third argument to completing-read, to obey the + semantics of bbdb-completion-type." +- (let (name r n) +- (and (boundp symbol) +- (setq name (symbol-name symbol) +- r (symbol-value symbol)) +- (or (null bbdb-completion-type) +- (and (memq bbdb-completion-type +- '(name primary-or-name name-or-primary)) +- (setq n (or (bbdb-record-name r) +- (bbdb-record-company r))) +- (string= name (downcase n))) +- ;; #### do something about AKA or mail-name or mail-alias here? +- (and (setq n (bbdb-record-net r)) +- (or (and (memq bbdb-completion-type +- '(primary primary-or-name name-or-primary)) +- (string= name (downcase (car n)))) +- (and (eq bbdb-completion-type 'net) +- (let ((done nil)) +- (while (and n (not done)) +- (if (string= name (downcase (car n))) +- (setq done t)) +- (setq n (cdr n))) +- done)))))))) ++ (cond ((null bbdb-completion-type) 't) ++ ((not (boundp symbol)) '()) ++ (t (let ((sym (symbol-name symbol)) ++ (recs (symbol-value symbol)) ++ ok) ++ (while (and recs (not ok)) ++ (setq ok (bbdb-completion-check-record sym (car recs)) ++ recs (cdr recs))) ++ ok)) ++ )) + +-(defun bbdb-completing-read-record (prompt) ++(defun bbdb-completing-read-record (prompt &optional omit-records) + "Prompt for and return a record from the bbdb; completion is done according + to bbdb-completion-type. If the user just hits return, nil is returned. + Otherwise, a valid response is forced." + (let* ((ht (bbdb-hashtable)) ++ (completion-ignore-case 't) + (string (completing-read prompt ht 'bbdb-completion-predicate t)) + (symbol (and (not (= 0 (length string))) + (intern-soft string ht)))) + (if symbol + (if (and (boundp symbol) (symbol-value symbol)) +- (symbol-value symbol) +- (error "selecting deleted (unhashed) record \"%s\"!" symbol)) ++ (let ((recs (symbol-value symbol)) ret) ++ (while recs ++ (if (and (not (memq (car recs) omit-records)) ++ (bbdb-completion-check-record (symbol-name symbol) ++ (car recs))) ++ (setq ret (cons (car recs) ret))) ++ (setq recs (cdr recs))) ++ ret) ++ (error "selecting deleted (unhashed) record \"%s\"!" symbol)) + nil))) + ++(defun bbdb-completing-read-one-record (prompt &optional omit-records) ++ "Prompt for and return a single record from the bbdb; ++completion is done according to bbdb-completion-type. If the user ++just hits return, nil is returned. Otherwise, a valid response is forced. ++if omit-records is non-nil it should be a list of records to dis-allow ++completion with." ++ (let ((records (bbdb-remove-memq-duplicates ++ (bbdb-completing-read-record prompt omit-records)))) ++ (if (eq (length records) 1) ++ (car records) ++ (let ((count (length records)) ++ prompts result) ++ (bbdb-display-records records) ++ (while (> count 0) ++ (setq prompts (cons (list (number-to-string count) count) prompts) ++ count (1- count))) ++ (setq result ++ (completing-read (format "Which duplicate record (1-%s): " ++ (length records)) ++ prompts nil t "1")) ++ (nth (1- (string-to-number result)) records) ++ ) ++ ) ++ ) ++ ) + + (defvar bbdb-read-addresses-with-completion-map + (let ((map (copy-keymap minibuffer-local-completion-map))) +@@ -1697,7 +1828,23 @@ + (insert (extent-string extent)) + (bbdb-complete-name beg))) + +- ++ ++(defun bbdb-list-overlap (l1 l2) ++ (let (ok) ++ (while (and (not ok) l1) ++ (if (memq (car l1) l2) (setq ok t l1 '()) ++ (setq l1 (cdr l1)))) ++ ok)) ++ ++(defun bbdb-remove-assoc-duplicates (l) ++ (if (null l) '() ++ (if (assoc (car (car l)) (cdr l)) ++ (bbdb-remove-assoc-duplicates (cdr l)) ++ (cons (car l) (bbdb-remove-assoc-duplicates (cdr l))) ++ ) ++ ) ++) ++ + ;;;###autoload + (defun bbdb-complete-name (&optional start-pos) + "Complete the user full-name or net-address before point (up to the +@@ -1724,19 +1871,26 @@ + (yeah-yeah-this-one nil) + (only-one-p t) + (all-the-completions nil) +- (pred (function (lambda (sym) +- (and (bbdb-completion-predicate sym) +- (let* ((rec (symbol-value sym)) +- (net (bbdb-record-net rec))) +- (if (and yeah-yeah-this-one +- (not (eq rec yeah-yeah-this-one))) +- (setq only-one-p nil)) +- (setq all-the-completions +- (cons sym all-the-completions)) +- (if (eq rec yeah-yeah-this-one) +- nil +- (and net (setq yeah-yeah-this-one rec)) +- net)))))) ++ (pred (function ++ (lambda (sym) ++ (and (bbdb-completion-predicate sym) ++ (let* ((recs (and (boundp sym) (symbol-value sym))) ++ nets) ++ (while (and (not nets) recs) ++ (if (not (setq nets (bbdb-record-net (car recs)))) ++ () ++ (if (memq (car recs) yeah-yeah-this-one) ++ (setq nets '()) ;; already have it... ++ (setq only-one-p nil ++ yeah-yeah-this-one ++ (cons (car recs) yeah-yeah-this-one))) ++ (if (not (memq sym all-the-completions)) ++ (setq all-the-completions ++ (cons sym all-the-completions))) ++ ) ++ (setq recs (cdr recs))) ++ nets)) ++ ))) + (completion (try-completion pattern ht pred))) + ;; If there were multiple completions for this record, the one that was + ;; picked is random (hash order.) So canonicalize that to be the one +@@ -1744,8 +1898,12 @@ + (if (and (stringp completion) + yeah-yeah-this-one + only-one-p) +- (let ((addrs (bbdb-record-net yeah-yeah-this-one)) +- (rest all-the-completions)) ++ (let ((rest all-the-completions) addrs) ++ (while yeah-yeah-this-one ++ (setq addrs (append addrs ++ (bbdb-record-net (car yeah-yeah-this-one))) ++ yeah-yeah-this-one (cdr yeah-yeah-this-one)) ++ ) + (while rest + (if (member (symbol-name (car rest)) addrs) + (setq completion (symbol-name (car rest)) +@@ -1753,94 +1911,146 @@ + (setq rest (cdr rest))))) + (setq yeah-yeah-this-one nil + all-the-completions nil) +- (cond ((eq completion t) +- (let* ((sym (intern-soft pattern ht)) +- (val (symbol-value sym))) +- (delete-region beg end) +- (insert (bbdb-dwim-net-address val +- (if (string= (symbol-name sym) +- (downcase (or (bbdb-record-name val) ""))) +- nil +- ;; get the case right +- (let ((nets (bbdb-record-net val)) +- (want (symbol-name sym)) +- (the-one nil)) +- (while (and nets (not the-one)) +- (if (string= want (downcase (car nets))) +- (setq the-one (car nets)) +- (setq nets (cdr nets)))) +- the-one)))) +- ;; +- ;; if we're past fill-column, wrap at the previous comma. +- (if (and +- (if (boundp 'auto-fill-function) ; the emacs19 name. +- auto-fill-function +- auto-fill-hook) +- (>= (current-column) fill-column)) +- (let ((p (point)) +- bol) +- (save-excursion +- (beginning-of-line) +- (setq bol (point)) +- (goto-char p) +- (if (search-backward "," bol t) +- (progn +- (forward-char 1) +- (insert "\n ")))))) +- ;; +- ;; Update the *BBDB* buffer if desired. +- (if bbdb-completion-display-record +- (let ((bbdb-gag-messages t)) +- (bbdb-display-records-1 (list val) t))) +- (bbdb-complete-name-cleanup) +- )) +- ((null completion) +- (bbdb-complete-name-cleanup) +- (message "completion for \"%s\" unfound." pattern) +- (ding)) +- ((not (string= pattern completion)) +- (delete-region beg end) +- (insert completion) +- (setq end (point)) +- (let ((last "")) +- (while (and (stringp completion) +- (not (string= completion last)) +- (setq last completion +- pattern (downcase (buffer-substring beg end)) +- completion (try-completion pattern ht pred))) +- (if (stringp completion) +- (progn (delete-region beg end) +- (insert completion)))) +- (bbdb-complete-name beg) +- )) +- (t +- (or (eq (selected-window) (minibuffer-window)) +- (message "Making completion list...")) +- (let* ((list (all-completions pattern ht pred)) +-;; (recs (delq nil (mapcar (function (lambda (x) +-;; (symbol-value (intern-soft x ht)))) +-;; list))) ++ (cond ++ ;; No match ++ ((null completion) ++ (bbdb-complete-name-cleanup) ++ (message "completion for \"%s\" unfound." pattern) ++ (ding)) ++ ++ ;; Perfect match... ++ ((eq completion t) ++ (let* ((sym (intern-soft pattern ht)) ++ (recs (symbol-value sym)) ++ the-net match-recs lst primary matched) ++ (while recs ++ (if (not (bbdb-record-net (car recs))) () ++ ++ (if (string= pattern ++ (downcase (or (bbdb-record-name (car recs)) ""))) ++ (setq match-recs (cons (car recs) match-recs) ++ matched t)) ++ ++ ;; put aka's at end of match list... ++ (setq lst (bbdb-record-aka (car recs))) ++ (if (not matched) ++ (while lst ++ (if (string= pattern (downcase (car lst))) ++ (setq match-recs (append match-recs (list (car recs))) ++ matched t ++ lst '()) ++ (setq lst (cdr lst)) ++ ) + ) +- (if (and (not (eq bbdb-completion-type 'net)) +- (= 2 (length list)) +- (eq (symbol-value (intern (car list) ht)) +- (symbol-value (intern (nth 1 list) ht))) +- (not (string= completion (car list)))) +- (progn +- (delete-region beg end) +- (insert (car list)) +- (message " ") +- (bbdb-complete-name beg)) +- (if (not (get-buffer-window "*Completions*")) +- (setq bbdb-complete-name-saved-window-config +- (current-window-configuration))) +- (let ((arg (list (current-buffer) +- (set-marker (make-marker) beg) +- (set-marker (make-marker) end)))) +- (with-output-to-temp-buffer "*Completions*" +- (bbdb-display-completion-list list 'bbdb-complete-clicked-name arg))) +- (or (eq (selected-window) (minibuffer-window)) +- (message "Making completion list...done")))))))) ++ ) ++ ++ ;; Name didn't match name so check net matching ++ (setq lst (bbdb-record-net (car recs))) ++ (setq primary 't);; primary wins over secondary... ++ (if (not matched) ++ (while lst ++ (if (string= pattern (downcase (car lst))) ++ (setq the-net (car lst) ++ lst nil ++ match-recs ++ (if primary (cons (car recs) match-recs) ++ (append match-recs (list (car recs)))))) ++ (setq lst (cdr lst) ++ primary nil))) ++ ) ++ (setq recs (cdr recs) ++ matched nil)) ++ ++ (if (and (null the-net) ++ (> (length match-recs) 1)) ++ (let ((lst (mapcar (lambda (x) ++ (cons (car (bbdb-record-net x)) x)) ++ match-recs)) ++ (completion-ignore-case 't) ++ comp) ++ (setq lst (bbdb-remove-assoc-duplicates lst) ++ comp (completing-read "Which primary net: " lst '() 't ++ (cons (car (car lst)) 0)) ++ match-recs (list (cdr (assoc comp lst))) ++ the-net comp) ++ ) ++ ) ++ ++ ++ (delete-region beg end) ++ (insert (bbdb-dwim-net-address (car match-recs) the-net)) ++ ;; ++ ;; if we're past fill-column, wrap at the previous comma. ++ (if (and ++ (if (boundp 'auto-fill-function) ; the emacs19 name. ++ auto-fill-function ++ auto-fill-hook) ++ (>= (current-column) fill-column)) ++ (let ((p (point)) ++ bol) ++ (save-excursion ++ (beginning-of-line) ++ (setq bol (point)) ++ (goto-char p) ++ (if (search-backward "," bol t) ++ (progn ++ (forward-char 1) ++ (insert "\n ")))))) ++ ++ ;; ++ ;; Update the *BBDB* buffer if desired. ++ (if bbdb-completion-display-record ++ (let ((bbdb-gag-messages t)) ++ (bbdb-display-records-1 match-recs t))) ++ (bbdb-complete-name-cleanup) ++ )) ++ ++ ;; Partial match ++ ((not (string= pattern completion)) ++ (delete-region beg end) ++ (insert completion) ++ (setq end (point)) ++ (let ((last "")) ++ (while (and (stringp completion) ++ (not (string= completion last)) ++ (setq last completion ++ pattern (downcase (buffer-substring beg end)) ++ completion (try-completion pattern ht pred))) ++ (if (stringp completion) ++ (progn (delete-region beg end) ++ (insert completion)))) ++ (bbdb-complete-name beg) ++ )) ++ ++ ;; Matched again and got no new chars so show options... ++ (t ++ (or (eq (selected-window) (minibuffer-window)) ++ (message "Making completion list...")) ++ (let* ((list (all-completions pattern ht pred)) ++ ;; (recs (delq nil (mapcar (function (lambda (x) ++ ;; (symbol-value (intern-soft x ht)))) ++ ;; list))) ++ ) ++ (if (and (not (eq bbdb-completion-type 'net)) ++ (= 2 (length list)) ++ (eq (symbol-value (intern (car list) ht)) ++ (symbol-value (intern (nth 1 list) ht))) ++ (not (string= completion (car list)))) ++ (progn ++ (delete-region beg end) ++ (insert (car list)) ++ (message " ") ++ (bbdb-complete-name beg)) ++ (if (not (get-buffer-window "*Completions*")) ++ (setq bbdb-complete-name-saved-window-config ++ (current-window-configuration))) ++ (let ((arg (list (current-buffer) ++ (set-marker (make-marker) beg) ++ (set-marker (make-marker) end)))) ++ (with-output-to-temp-buffer "*Completions*" ++ (bbdb-display-completion-list list 'bbdb-complete-clicked-name arg))) ++ (or (eq (selected-window) (minibuffer-window)) ++ (message "Making completion list...done")))))))) + + ;;;###autoload + (defun bbdb-yank () +@@ -2135,6 +2345,61 @@ + (setq bbdb-remaining-addrs-to-finger (cdr addrs)) + (bbdb-finger-internal (car addrs)))))) + ++ ++(defun bbdb-find-duplicates (&optional fields) ++ "*Find all records that have duplicate entries for given FIELDS. ++FIELDS should be a list of the symbols `name', `net', and/or `aka'. ++Note that overlap between these fields is noted if either is selected ++(most common case `aka' and `name'). If FIELDS is not given it ++defaults to all of them. ++ ++The results of the search is returned as a list of records." ++ (setq fields (or fields '(name net aka))) ++ (let ((records (bbdb-records)) ++ rec hash ret) ++ (while records ++ (setq rec (car records)) ++ ++ (and (memq 'name fields) ++ (setq hash (bbdb-gethash (downcase (bbdb-record-name rec)))) ++ (> (length hash) 1) ++ (setq ret (append hash ret))) ++ ++ (if (memq 'net fields) ++ (let ((nets (bbdb-record-net rec))) ++ (while nets ++ (setq hash (bbdb-gethash (downcase (car nets)))) ++ (if (> (length hash) 1) ++ (setq ret (append hash ret))) ++ (setq nets (cdr nets)) ++ ))) ++ ++ (if (memq 'aka fields) ++ (let ((aka (bbdb-record-aka rec))) ++ (while aka ++ (setq hash (bbdb-gethash (downcase (car aka)))) ++ (if (> (length hash) 1) ++ (setq ret (append hash ret))) ++ (setq aka (cdr aka)) ++ ))) ++ (setq records (cdr records)) ++ ) ++ (bbdb-remove-memq-duplicates ret) ++ ) ++) ++ ++(defun bbdb-show-duplicates (&optional fields) ++"*Find all records that have duplicate entries for given FIELDS. ++FIELDS should be a list of the symbols `name', `net', and/or `aka'. ++Note that overlap between these fields is noted if either is selected ++(most common case `aka' and `name'). If FIELDS is not given it ++defaults to all of them. ++ ++The results are displayed in the bbdb buffer." ++ (interactive) ++ (setq fields (or fields '(name net aka))) ++ (bbdb-display-records (bbdb-find-duplicates fields)) ++) + + ;;; Time-based functions + (defun bbdb-kill-older (date &optional compare function) +diff -ur bbdb-2.00.06/lisp/bbdb-ftp.el bbdb-2.01/lisp/bbdb-ftp.el +--- bbdb-2.00.06/lisp/bbdb-ftp.el Tue Sep 28 09:56:40 1999 ++++ bbdb-2.01/lisp/bbdb-ftp.el Tue Sep 28 11:01:14 1999 +@@ -172,7 +172,8 @@ + (progn + (setq site (bbdb-read-string "Ftp Site: ")) + (setq site (concat bbdb-ftp-site-name-designator-prefix site)) +- (if (bbdb-gethash (downcase site)) ++ (if (and bbdb-no-duplicates-p ++ (bbdb-gethash (downcase site))) + (error "%s is already in the database" site)))) + (let* ((dir (bbdb-read-string "Ftp Directory: " + bbdb-default-ftp-dir)) +diff -ur bbdb-2.00.06/lisp/bbdb.el bbdb-2.01/lisp/bbdb.el +--- bbdb-2.00.06/lisp/bbdb.el Tue Sep 28 09:56:42 1999 ++++ bbdb-2.01/lisp/bbdb.el Tue Feb 29 09:09:18 2000 +@@ -49,6 +49,11 @@ + nil if the database was read in and is to be written in the current + version.") + ++(defvar bbdb-no-duplicates-p '() ++ "Should BBDB allow entries with duplicate names. This may lead to ++confusion when doing completion. If 't it will prompt the users on how ++to merge records when duplicates are detected.") ++ + ;; This nonsense is to get the definition of defsubst loaded in when this file + ;; is loaded,without necessarily forcing the compiler to be loaded if we're + ;; running in an emacs with bytecomp-runtime.el predumped. We are using +@@ -900,11 +905,15 @@ + (save-window-excursion + (if (and (boundp 'epoch::version) epoch::version) + nil ; this breaks epoch... +- (let ((w (selected-window))) +- (select-window (minibuffer-window)) +- (enlarge-window (max 0 (- n (window-height)))) +- (sit-for 0) ; avoid redisplay glitch +- (select-window w))) ++ (let ((w (selected-window)) ++ (mini (minibuffer-window))) ++ (if (eq mini (next-window mini 't (window-frame mini))) ++ nil ;; Can't enlarge if only window in frame... ++ (select-window mini) ++ (enlarge-window (max 0 (- n (window-height)))) ++ (sit-for 0) ; avoid redisplay glitch ++ (select-window w) ++ ))) + (bbdb-string-trim + (read-string prompt default)))))) + +@@ -1186,7 +1195,7 @@ + (catch 'Blow-off-the-error + (setq bbdb-electric-completed-normally nil) + (unwind-protect +- (progn ++ (progn + (catch 'electric-bbdb-list-select + (Electric-command-loop 'electric-bbdb-list-select + "-> " t)) +@@ -1268,37 +1277,95 @@ + (defun bbdb-changed-records () + (bbdb-with-db-buffer (bbdb-records nil t) bbdb-changed-records)) + ++(defmacro bbdb-build-name (f l) ++ (list 'downcase ++ (list 'if (list 'and f l) ++ (list 'concat f " " l) ++ (list 'or f l ""))) ++ ) ++ ++(defun bbdb-remove! (e l) ++ (if (null l) l ++ (let ((ret l) ++ (n (cdr l))) ++ (while n ++ (if (eq e (car n)) ++ (setcdr l (cdr n)) ; skip n ++ (setq l n)) ; keep n ++ (setq n (cdr n)) ++ ) ++ (if (eq e (car ret)) (cdr ret) ++ ret) ++ )) ++ ) ++ ++(defun bbdb-remove-memq-duplicates (l) ++ (let (ret tail) ++ (setq ret (cons '() '()) ++ tail ret) ++ (while l ++ (if (not (memq (car l) ret)) ++ (setq tail (setcdr tail (cons (car l) '())))) ++ (setq l (cdr l))) ++ (cdr ret) ++ ) ++) ++ + (defmacro bbdb-gethash (name &optional ht) + (list 'symbol-value + (list 'intern-soft name + (or ht '(bbdb-hashtable))))) + + (defmacro bbdb-puthash (name record &optional ht) +- (list 'set (list 'intern name +- (or ht '(bbdb-hashtable))) +- record)) ++ (list 'let (list (list 'sym (list 'intern name (or ht '(bbdb-hashtable))))) ++ (list 'set 'sym (list 'cons record ++ '(and (boundp sym) (symbol-value sym)))) ++ ) ++ ) + +-(defmacro bbdb-remhash (name &optional ht) ++(defmacro bbdb-remhash (name record &optional ht) + (list 'let (list (list 's (list 'intern-soft name + (or ht '(bbdb-hashtable))))) +- '(and s (set s nil)))) +- ++ (list 'and 's (list 'set 's (list 'bbdb-remove! record ++ (list 'symbol-value 's)))))) + + (defsubst bbdb-search-simple (name net) + "name is a string; net is a string or list of strings." + (if (eq 0 (length name)) (setq name nil)) + (if (eq 0 (length net)) (setq net nil)) + (bbdb-records t) ; make sure db is parsed; don't check disk (faster) +- (or (and name (bbdb-gethash (downcase name))) +- (and net +- (if (stringp net) +- (bbdb-gethash (downcase net)) +- (let ((answer nil)) +- (while (and net (null answer)) +- (setq answer (bbdb-gethash (downcase (car net))) +- net (cdr net))) +- answer))))) +- ++ (let ((name-recs (and name ++ (bbdb-gethash (downcase name)))) ++ (net-recs (if (stringp net) (bbdb-gethash (downcase net)) ++ (let (answer) ++ (while (and net (null answer)) ++ (setq answer (bbdb-gethash (downcase (car net))) ++ net (cdr net))) ++ answer))) ++ ret) ++ (if (not (and name-recs net-recs)) ++ (or (and name-recs (car name-recs)) ++ (and net-recs (car net-recs))) ++ ++ (while name-recs ++ (let ((name-rec (car name-recs)) ++ (nets net-recs)) ++ (while nets ++ (if (eq (car nets) name-rec) ++ (setq nets '() ++ name-recs '() ++ ret name-rec) ++ (setq nets (cdr nets)) ++ ) ++ ) ++ (if name-recs (setq name-recs (cdr name-recs)) ++ name-rec) ++ ) ++ ) ++ ret ++ ) ++ ) ++ ) + + (defun bbdb-net-convert (record) + "Given a record whose net field is a comma-separated string, convert it to +@@ -1333,25 +1400,21 @@ + (defsubst bbdb-hash-record (record) + "Insert the record in the appropriate hashtables. This must be called + while the .bbdb buffer is selected." +- (let ((name (bbdb-record-name-1 record)) ; faster version ++ (let ((name (bbdb-record-name-1 record)) ; faster version + (company (bbdb-record-company record)) +- (aka (bbdb-record-aka record)) +- (net (bbdb-record-net record))) +- (if (not (= 0 (length name))) ; could be nil or "" +- (bbdb-puthash (downcase name) record bbdb-hashtable)) +- ;; #### we don't do hash collision detection on company names, so this +- ;; is a potentially dangerous thing to do I guess. But it's useful. +- ;; This makes completion possible on company fields of records that +- ;; have a company but no name. +- (if (and (= 0 (length name)) +- (not (= 0 (length company)))) ++ (aka (bbdb-record-aka record)) ++ (net (bbdb-record-net record))) ++ (if (> (length name) 0) ++ (bbdb-puthash (downcase name) record bbdb-hashtable)) ++ (if (> (length company) 0) + (bbdb-puthash (downcase company) record bbdb-hashtable)) + (while aka + (bbdb-puthash (downcase (car aka)) record bbdb-hashtable) + (setq aka (cdr aka))) + (while net + (bbdb-puthash (downcase (car net)) record bbdb-hashtable) +- (setq net (cdr net))))) ++ (setq net (cdr net))) ++ )) + + + ;;; Reading the BBDB +@@ -1568,36 +1631,45 @@ + (forward-line 1)) + (widen) + (bbdb-debug (message "Parsing BBDB... (frobnicating...)")) +- (let ((rest records) ++ (setq bbdb-records records) ++ (let* ((head (cons '() records)) ++ (rest head) + record) +- (while rest +- (setq record (car rest)) ++ (while (cdr rest) ++ (setq record (car (cdr rest))) + ;; yow, are we stack-driven yet?? Damn byte-compiler... + ;; Make a cache. Put it in the record. Put a marker in the cache. + ;; Add record to hash tables. + (bbdb-cache-set-marker + (bbdb-record-set-cache record (make-vector bbdb-cache-length nil)) + (point-marker)) +- (bbdb-debug +- (let ((name (bbdb-record-name record)) +- tmp) +- (if (and name +- (setq tmp (bbdb-gethash (setq name (downcase name)) +- bbdb-hashtable))) +- (signal 'error (list "duplicate bbdb entries" record tmp))))) +- (bbdb-hash-record record) + (forward-line 1) +- (setq rest (cdr rest)) ++ ++ (if bbdb-no-duplicates-p ++ ;; warn the user that there is a duplicate... ++ (let* ((name (bbdb-record-name record)) ++ (tmp (and name (bbdb-gethash (downcase name) ++ bbdb-hashtable)))) ++ (if tmp (message "Duplicate BBDB record encountered: %s" name)) ++ ) ++ ) ++ ++ (bbdb-hash-record record) ++ (setq rest (cdr rest)) ++ + (bbdb-debug +- (if (and rest (not (looking-at "[\[]"))) ++ (if (and (cdr rest) (not (looking-at "[\[]"))) + (error "bbdb corrupted: junk between records at %s" (point)))) +- )) ++ ) ++ ;; In case we removed some of the leading entries... ++ (setq bbdb-records (cdr head)) ++ ) + ;; all done. +- (setq bbdb-records records) + (setq bbdb-end-marker (point-marker)) + (run-hooks 'bbdb-after-read-db-hook) + (bbdb-debug (message "Parsing BBDB... (frobnicating...done)")) +- records) ++ bbdb-records ++) + + (defmacro bbdb-user-mail-names () + "Returns a regexp matching the address of the logged-in user" +@@ -1632,17 +1704,21 @@ + (if (cdr tail) + (bbdb-record-marker (car (cdr tail))) + bbdb-end-marker)) +- (if (bbdb-record-name record) +- (let ((name (downcase (bbdb-record-name record)))) +- (bbdb-remhash name bbdb-hashtable))) +- (let ((nets (bbdb-record-net record))) ++ (let ((name (bbdb-record-name record)) ++ (company (bbdb-record-company record)) ++ (aka (bbdb-record-aka record)) ++ (nets (bbdb-record-net record))) ++ (if (> (length name) 0) ++ (bbdb-remhash (downcase name) record bbdb-hashtable)) ++ (if (> (length company) 0) ++ (bbdb-remhash (downcase company) record bbdb-hashtable)) + (while nets +- (bbdb-remhash (downcase (car nets)) bbdb-hashtable) +- (setq nets (cdr nets)))) +- (let ((aka (bbdb-record-aka record))) ++ (bbdb-remhash (downcase (car nets)) record bbdb-hashtable) ++ (setq nets (cdr nets))) + (while aka +- (bbdb-remhash (downcase (car aka)) bbdb-hashtable) +- (setq aka (cdr aka)))) ++ (bbdb-remhash (downcase (car aka)) record bbdb-hashtable) ++ (setq aka (cdr aka))) ++ ) + (bbdb-record-set-sortkey record nil) + (setq bbdb-modified-p t)))) + +@@ -2333,7 +2409,7 @@ + old-name)) + (bbdb-record-set-aka record + (cons old-name (bbdb-record-aka record))) +- (bbdb-remhash (downcase old-name)))) ++ (bbdb-remhash (downcase old-name) record))) + (bbdb-record-set-namecache record nil) + (bbdb-record-set-firstname record fname) + (bbdb-record-set-lastname record lname) +@@ -2820,6 +2896,7 @@ + (defun bbdb-insinuate-sendmail () + "Call this function to hook BBDB into sendmail (that is, M-x mail)." + (define-key mail-mode-map "\M-\t" 'bbdb-complete-name) ++ (define-key mail-mode-map [(meta tab)] 'bbdb-complete-name) + ) + + |