cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-merge.el

   1 ;;; BBDB merge/sync framework
   2 ;;; GNU Public License to go here. This file is under GPL, thanks guys.
   3 ;;; Copyright (c) 2000 Waider
   4
   5 (require 'bbdb)
   6 (require 'bbdb-com)
   7
   8 ;;; to do:
   9 ;;; smarter phone, notes and address merging.
  10
  11 ;;;###autoload
  12 (defun bbdb-merge-record (new-record &optional merge-record override)
  13   "Generic merge function.
  14
  15 Merges new-record into your bbdb, using DATE to check who's more
  16 up-to-date and OVERRIDE to decide who gets precedence if two dates
  17 match. DATE can be extracted from a notes if it's an alist with an
  18 element marked timestamp. Set OVERRIDE to 'new to allow the new record
  19 to stomp on existing data, 'old to preserve existing data or nil to
  20 merge both together. If it can't find a record to merge with, it will
  21 create a new record. If MERGE-RECORD is set, it's a record discovered
  22 by other means that should be merged with.
  23
  24 Returns the Grand Unified Record."
  25
  26   (let* ((firstname (bbdb-record-firstname new-record))
  27          (lastname (bbdb-record-lastname new-record))
  28          (aka (bbdb-record-aka new-record))
  29          (nets (bbdb-record-net new-record))
  30          (addrs (bbdb-record-addresses new-record))
  31          (phones (bbdb-record-phones new-record))
  32          (company (bbdb-record-company new-record))
  33          (notes (bbdb-record-raw-notes new-record))
  34          (name (bbdb-string-trim (concat firstname " " lastname)))
  35          (date (if (listp notes) (cdr (assq 'timestamp notes)) nil))
  36          olddate)
  37
  38     ;; for convenience
  39     (if (stringp notes)
  40         (setq notes (list (cons 'notes notes))))
  41
  42     ;; See if we have a record that looks right, using an intertwingle
  43     ;; search. Could probably parameterize that.
  44     ;; bbdb-merge-search-function or some such.
  45     (if (null merge-record)
  46         (setq merge-record (bbdb-search-simple name nets)))
  47
  48     (if merge-record
  49         (progn
  50           ;; if date is unset, set it to the existing record's date.
  51           (setq olddate (bbdb-record-getprop merge-record 'timestamp)
  52                 date (or date olddate))
  53           ;; FIXME if date & olddate are STILL unset, set to today's date.
  54
  55           ;; if the old record is actually newer, invert the sense of override
  56           (if (string-lessp olddate date)
  57               (setq override (cond ((eq 'old override) 'new)
  58                                    ((eq 'new override) 'old)
  59                                    (t nil))))
  60
  61           (bbdb-record-set-firstname merge-record
  62            (if (null override)
  63                (bbdb-merge-strings (bbdb-record-firstname merge-record)
  64                                    firstname " ")
  65              (if (eq 'new override) firstname
  66                (bbdb-record-firstname merge-record))))
  67
  68           (bbdb-record-set-lastname merge-record
  69            (if (null override)
  70                (bbdb-merge-strings (bbdb-record-lastname merge-record)
  71                                    lastname " ")
  72              (if (eq 'new override) lastname
  73                (bbdb-record-lastname merge-record))))
  74
  75           (bbdb-record-set-company merge-record
  76            (if (null override)
  77                (bbdb-merge-strings (bbdb-record-company merge-record)
  78                                    company " ")
  79              (if (eq 'new override) company
  80                (bbdb-record-company merge-record))))
  81
  82           (bbdb-record-set-aka
  83            merge-record
  84            (if (null override)
  85                (bbdb-merge-lists!
  86                 (bbdb-record-aka merge-record)
  87                 (if (listp aka) aka (list aka)) 'string= 'downcase)
  88              (if (eq 'new override) aka
  89                (bbdb-record-aka merge-record))))
  90
  91           (bbdb-record-set-net
  92            merge-record
  93            (if (null override)
  94                (bbdb-merge-lists!
  95                 (bbdb-record-net merge-record) nets 'string= 'downcase)
  96              (if (eq 'new override) nets
  97                (bbdb-record-net merge-record))))
  98
  99           (bbdb-record-set-phones
 100            merge-record
 101            (if (null override)
 102                (bbdb-merge-lists!
 103                 (bbdb-record-phones merge-record) phones 'equal)
 104              (if (eq 'new override) phones
 105                (bbdb-record-phones merge-record))))
 106
 107           (bbdb-record-set-addresses
 108            merge-record
 109            (if (null override)
 110                (bbdb-merge-lists!
 111                 (bbdb-record-addresses merge-record) addrs 'equal)
 112              (if (eq 'new override) addrs
 113                (bbdb-record-addresses merge-record))))
 114
 115           ;; lifted from bbdb-com.el
 116           (let ((n1 (bbdb-record-raw-notes merge-record))
 117                 (n2 notes)
 118                 tmp
 119                 (bbdb-refile-notes-default-merge-function ;; XXX
 120                  'bbdb-merge-strings))
 121             (or (equal n1 n2)
 122                 (progn
 123                   (or (listp n1) (setq n1 (list (cons 'notes n1))))
 124                   (or (listp n2) (setq n2 (list (cons 'notes n2))))
 125                   (while n2
 126                     (if (setq tmp (assq (car (car n2)) n1))
 127                         (setcdr tmp
 128                                 (funcall (or (cdr (assq (car (car n2))
 129                                                         bbdb-refile-notes-generate-alist))
 130                                              bbdb-refile-notes-default-merge-function)
 131                                          (cdr tmp) (cdr (car n2))))
 132                       (setq n1 (nconc n1 (list (car n2)))))
 133                     (setq n2 (cdr n2)))
 134                   (bbdb-record-set-raw-notes merge-record n1)))))
 135
 136       ;; we couldn't find a record, so create one
 137       (setq merge-record
 138             (bbdb-create-internal name company nets addrs phones notes))
 139       ;; bite me, bbdb-create-internal
 140       (bbdb-record-set-firstname merge-record firstname)
 141       (bbdb-record-set-lastname merge-record lastname))
 142
 143     ;; more general bitingness
 144     (if (equal (bbdb-record-firstname merge-record) "")
 145         (bbdb-record-set-firstname merge-record nil))
 146     (if (equal (bbdb-record-lastname merge-record) "")
 147         (bbdb-record-set-lastname merge-record nil))
 148
 149     ;; fix up the in-memory copy.
 150     (bbdb-change-record merge-record t)
 151     (let ((name    (bbdb-record-name    merge-record))
 152           (lastname    (bbdb-record-lastname    merge-record))
 153           (company (bbdb-record-company merge-record)))
 154       (if (> (length name) 0)
 155           (bbdb-remhash (downcase name) merge-record))
 156       (if (> (length lastname) 0)
 157           (bbdb-remhash (downcase lastname) merge-record))
 158       (if (> (length company) 0)
 159           (bbdb-remhash (downcase company) merge-record)))
 160     (bbdb-record-set-namecache merge-record nil)
 161     (if (or (bbdb-record-lastname merge-record)
 162             (bbdb-record-firstname merge-record))
 163         (bbdb-puthash (downcase (bbdb-record-name merge-record)) merge-record))
 164     (if (bbdb-record-company merge-record)
 165         (bbdb-puthash (downcase (bbdb-record-company merge-record))
 166                       merge-record))
 167     (bbdb-with-db-buffer
 168      (if (not (memq merge-record bbdb-changed-records))
 169          (setq bbdb-changed-records
 170                (cons merge-record bbdb-changed-records))))
 171
 172     ;; your record, sir.
 173     merge-record))
 174
 175 ;; fixme these could be a macros, I guess.
 176 (defun bbdb-instring( s1 s2 )
 177 ;;  (and case-fold-search
 178 ;;       (setq s1 (downcase s1)
 179 ;;             s2 (downcase s2)))
 180   (catch 'done
 181     (while (>= (length s1) (length s2))
 182       (if (string= s2 (substring s1 0 (length s2)))
 183           (throw 'done t)
 184         (setq s1 (substring s1 1))))
 185     (throw 'done nil)))
 186
 187 (defun bbdb-merge-strings (s1 s2 &optional sep)
 188   "Merge two strings together uniquely.
 189 If s1 doesn't contain s2, return s1+sep+s2."
 190   (cond ((or (null s1) (string-equal s1 "")) s2)
 191         ((or (null s2) (string-equal s2 "")) s1)
 192         (t (if (bbdb-instring s2 s1) s1
 193              (concat s1 (or sep "") s2)))))
 194
 195 ;;;###autoload
 196 (defun bbdb-merge-file (&optional bbdb-new override match-fun)
 197   "Merge a bbdb file into the in-core bbdb."
 198   (interactive "fMerge bbdb file: ")
 199   (or bbdb-gag-messages
 200       bbdb-silent-running
 201       (message "Merging %s" bbdb-new))
 202   ;; argh urgle private environment
 203   (let* ((bbdb-live-file bbdb-file)
 204          (bbdb-file bbdb-new)
 205          (bbdb-live-buffer-name bbdb-buffer-name)
 206          (bbdb-buffer-name "*BBDB-merge*")
 207          (bbdb-buffer nil) ;; hack hack
 208          (new-records (bbdb-records))
 209          (bbdb-buffer nil) ;; hack hack
 210          (bbdb-file bbdb-live-file)
 211          (bbdb-buffer-name bbdb-live-buffer-name)
 212          (bbdb-refile-notes-default-merge-function 'bbdb-merge-strings))
 213
 214     ;; merge everything
 215     (mapcar (lambda(rec)
 216               (bbdb-merge-record rec
 217                                  (and match-fun
 218                                       (funcall match-fun rec))
 219                                  override))
 220             new-records))
 221   ;; hack
 222   (setq bbdb-buffer (or (get-file-buffer bbdb-file) nil)))
 223
 224 (defun bbdb-add-or-update-phone ( record location phone-string )
 225   "Add or update a phone number in the current record.
 226
 227 Insert into RECORD phone number for LOCATION consisting of
 228 PHONE-STRING. Will automatically overwrite an existing phone entry for
 229 the same location."
 230   (let* ((phone (make-vector (if bbdb-north-american-phone-numbers-p
 231                                  bbdb-phone-length
 232                                2)
 233                              nil)))
 234     (if (= 2 (length phone))
 235         (aset phone 1 phone-string)
 236       (let ((newp (bbdb-parse-phone-number phone-string)))
 237         (bbdb-phone-set-area phone (nth 0 newp))
 238         (bbdb-phone-set-exchange phone (nth 1 newp))
 239         (bbdb-phone-set-suffix phone (nth 2 newp))
 240         (bbdb-phone-set-extension phone (or (nth 3 newp) 0))))
 241     (bbdb-phone-set-location phone location)
 242
 243     ;; "phone" now contains a suitable record
 244     ;; we need to check if this is already in the phones list
 245     (let ((phones (bbdb-record-phones record))
 246           phones-list)
 247       (setq phones-list phones)
 248       (while (car phones-list)
 249         (if (string= (bbdb-phone-location (car phones-list))
 250                      location)
 251             (setq phones (delete (car phones-list) phones)))
 252         (setq phones-list (cdr phones-list)))
 253
 254
 255       (bbdb-record-set-phones record
 256                               (nconc phones (list phone))))
 257     (bbdb-change-record record nil)
 258
 259     ;; update display if record is visible
 260     (and (get-buffer-window bbdb-buffer-name)
 261          (bbdb-display-records (list record)))
 262     nil))
 263
 264 (provide 'bbdb-merge)