git.shemshak.org - ~bandali/configs/blob - lisp/bbdb/bbdb-snarf.el

   1 ;;; bbdb-snarf.el --- convert free-form text to BBDB records -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2010-2017  Free Software Foundation, Inc.
   4
   5 ;; This file is part of the Insidious Big Brother Database (aka BBDB),
   6
   7 ;; BBDB is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; BBDB is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with BBDB.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; The commands `bbdb-snarf', `bbdb-snarf-yank' and `bbdb-snarf-paragraph'
  23 ;; create BBDB records by picking the name, addresses, phones, etc.
  24 ;; out of a (buffer) string.  Things are recognized by context (e.g., URLs
  25 ;; start with http:// or www.).  See `bbdb-snarf-rule-alist' for details.
  26 ;;
  27 ;; The rule `eu' should work out of the box for many continental
  28 ;; European countries.  It can be further customized by defining
  29 ;; a suitable postcode regexp passed to `bbdb-snarf-address-eu'.
  30 ;; `mail' is a simple rule that can pick a single mail address from,
  31 ;; say, a long list of mail addresses in a message.
  32 ;;
  33 ;; RW: `bbdb-snarf' is an interesting proof of concept.  Yet I find
  34 ;; its snarfing algorithms often too simplistic to be useful in real life.
  35 ;; How can this possibly be improved?  Suggestions welcome.
  36
  37 ;;; Code:
  38
  39 (require 'bbdb-com)
  40
  41 (defcustom bbdb-snarf-rule-alist
  42   '((us bbdb-snarf-surrounding-space
  43         bbdb-snarf-phone-nanp
  44         bbdb-snarf-url
  45         bbdb-snarf-mail
  46         bbdb-snarf-empty-lines
  47         bbdb-snarf-name
  48         bbdb-snarf-address-us
  49         bbdb-snarf-empty-lines
  50         bbdb-snarf-notes
  51         bbdb-snarf-name-mail) ; currently useless
  52     (eu bbdb-snarf-surrounding-space
  53         bbdb-snarf-phone-eu
  54         bbdb-snarf-url
  55         bbdb-snarf-mail
  56         bbdb-snarf-empty-lines
  57         bbdb-snarf-name
  58         bbdb-snarf-address-eu
  59         bbdb-snarf-empty-lines
  60         bbdb-snarf-notes
  61         bbdb-snarf-name-mail) ; currently useless
  62    (mail bbdb-snarf-mail-address))
  63   "Alist of rules for snarfing.
  64 Each rule is of the form (KEY FUNCTION FUNCTION ...).
  65 The symbol KEY identifies the rule, see also `bbdb-snarf-rule-default'.
  66
  67 Snarfing is a cumulative process.  The text is copied to a temporary
  68 snarf buffer that becomes current during snarfing.
  69 Each FUNCTION is called with one arg, the RECORD we are snarfing,
  70 and with point at the beginning of the snarf buffer.  FUNCTION should populate
  71 the fields of RECORD.  It may delete the part of the snarf buffer
  72 that it has processed so that the remaining FUNCTIONs operate only
  73 on those parts that were not yet snarfed.  The order of the FUNCTION calls
  74 in a rule is then crucial.
  75 Unlike other parts of BBDB, FUNCTIONs need not update the cache and
  76 hash table for RECORD which is done at the end by `bbdb-snarf'."
  77   :group 'bbdb-utilities-snarf
  78   :type '(repeat (cons (symbol :tag "Key")
  79                        (repeat (function :tag "Snarf function")))))
  80
  81 (defcustom bbdb-snarf-rule-default 'us
  82   "Default rule for snarfing."
  83   :group 'bbdb-utilities-snarf
  84   :type 'symbol)
  85
  86 (defcustom bbdb-snarf-name-regexp
  87   "^[ \t'\"]*\\([- .,[:word:]]*[[:word:]]\\)"
  88   "Regexp matching a name.  Case is ignored.
  89 The first subexpression becomes the name."
  90   :group 'bbdb-utilities-snarf
  91   :type 'regexp)
  92
  93 (defcustom bbdb-snarf-mail-regexp
  94   (concat "\\(?:\\(?:mailto:\\|e?mail:?\\)[ \t]*\\)?"
  95           "<?\\([^ \t\n<]+@[^ \t\n>]+\\)>?")
  96   "Regexp matching a mail address.  Case is ignored.
  97 The first subexpression becomes the mail address."
  98   :group 'bbdb-utilities-snarf
  99   :type 'regexp)
 100
 101 (defcustom bbdb-snarf-phone-nanp-regexp
 102   (concat "\\(?:phone:?[ \t]*\\)?"
 103           "\\(\\(?:([2-9][0-9][0-9])[-. ]?\\|[2-9][0-9][0-9][-. ]\\)?"
 104           "[0-9][0-9][0-9][-. ][0-9][0-9][0-9][0-9]"
 105           "\\(?: *\\(?:x\\|ext\\.?\\) *[0-9]+\\)?\\)")
 106   "Regexp matching a NANP phone number.  Case is ignored.
 107 NANP is the North American Numbering Plan used in North and Central America.
 108 The first subexpression becomes the phone number."
 109   :group 'bbdb-utilities-snarf
 110   :type 'regexp)
 111
 112 (defcustom bbdb-snarf-phone-eu-regexp
 113   (concat "\\(?:phone?:?[ \t]*\\)?"
 114           "\\(\\(?:\\+[1-9]\\|(\\)[-0-9()\s]+\\)")
 115   "Regexp matching a European phone number.
 116 The first subexpression becomes the phone number."
 117   :group 'bbdb-utilities-snarf
 118   :type 'regexp)
 119
 120 (defcustom bbdb-snarf-postcode-us-regexp
 121   ;; US postcode appears at end of line
 122   (concat "\\(\\<[0-9][0-9][0-9][0-9][0-9]"
 123           "\\(-[0-9][0-9][0-9][0-9]\\)?"
 124           "\\>\\)$")
 125   "Regexp matching US postcodes.
 126 The first subexpression becomes the postcode."
 127   :group 'bbdb-utilities-snarf
 128   :type 'regexp)
 129
 130 (defcustom bbdb-snarf-address-us-country nil
 131   "Country to use for US addresses.  If nil leave country blank."
 132   :group 'bbdb-utilities-snarf
 133   :type '(choice (const :tag "Leave blank" nil)
 134                  (string :tag "Country")))
 135
 136 (defcustom bbdb-snarf-postcode-eu-regexp
 137   "^\\([0-9][0-9][0-9][0-9][0-9]?\\)" ; four or five digits
 138   "Regexp matching many European postcodes.
 139 `bbdb-snarf-address-eu' assumes that the address appears at the beginning
 140 of a line followed by the name of the city."
 141   :group 'bbdb-utilities-snarf
 142   :type 'regexp)
 143
 144 (defcustom bbdb-snarf-address-eu-country nil
 145   "Country to use for EU addresses.  If nil leave country blank."
 146   :group 'bbdb-utilities-snarf
 147   :type '(choice (const :tag "Leave blank" nil)
 148                  (string :tag "Country")))
 149
 150 (defcustom bbdb-snarf-default-label-alist
 151   '((phone . "work") (address . "work"))
 152   "Default labels for snarfing.
 153 This is an alist where each element is a cons pair (FIELD . LABEL).
 154 The symbol FIELD denotes a record field like `phone' or `address'.
 155 The string LABEL denotes the default label for FIELD."
 156   :group 'bbdb-utilities-snarf
 157   :type '(repeat (cons (symbol :tag "Field")
 158                        (string :tag "Label"))))
 159
 160 (defcustom bbdb-snarf-url 'url
 161   "What xfield BBDB should use for URLs, or nil to not snarf URLs."
 162   :group 'bbdb-utilities-snarf
 163   :type 'symbol)
 164
 165 (defcustom bbdb-snarf-url-regexp "\\(\\(?:http://\\|www\\.\\)[^ \t\n]+\\)"
 166   "Regexp matching a URL.  Case is ignored.
 167 The first subexpression becomes the URL."
 168   :group 'bbdb-utilities-snarf
 169   :type 'regexp)
 170
 171 (defun bbdb-snarf-surrounding-space (_record)
 172   "Discard beginning and trailing space when snarfing RECORD."
 173   (while (re-search-forward "^[ \t]+" nil t)
 174     (replace-match ""))
 175   (goto-char (point-min))
 176   (while (re-search-forward "\\s-+$" nil t)
 177     (replace-match "")))
 178
 179 (defun bbdb-snarf-empty-lines (_record)
 180   "Discard empty lines when snarfing RECORD."
 181   (while (re-search-forward "^[ \t]*\n" nil t)
 182     (replace-match "")))
 183
 184 (defun bbdb-snarf-name (record)
 185   "Snarf name for RECORD."
 186   (if (and (not (bbdb-record-lastname record))
 187            (let ((case-fold-search t))
 188              (re-search-forward bbdb-snarf-name-regexp nil t)))
 189       (let ((name (match-string 1)))
 190         (replace-match "")
 191         (setq name (bbdb-divide-name name))
 192         (bbdb-record-set-firstname record (car name))
 193         (bbdb-record-set-lastname record (cdr name)))))
 194
 195 (defun bbdb-snarf-name-mail (record)
 196   "Snarf name from mail address for RECORD."
 197   ;; Fixme: This is currently useless because `bbdb-snarf-mail-regexp'
 198   ;; cannot handle names in RFC 5322-like addresses "John Smith <foo@bar.com>".
 199   (let ((name (bbdb-record-lastname record)))
 200     (when (and (not name)
 201                (bbdb-record-mail record)
 202                (setq name (car (bbdb-extract-address-components
 203                                 (car (bbdb-record-mail record)))))
 204                (setq name (bbdb-divide-name name)))
 205       (bbdb-record-set-firstname record (car name))
 206       (bbdb-record-set-lastname record (cadr name)))))
 207
 208 (defun bbdb-snarf-mail-address (record)
 209   "Snarf name and mail address for RECORD."
 210   ;; The voodoo of `mail-extract-address-components' makes
 211   ;; the following quite powerful.  If this function is used as part of
 212   ;; a more complex rule, the buffer should be narrowed appropriately.
 213   (let* ((data (bbdb-extract-address-components (buffer-string)))
 214          (name (and (car data) (bbdb-divide-name (car data)))))
 215     (bbdb-record-set-firstname record (car name))
 216     (bbdb-record-set-lastname  record (cdr name))
 217     (bbdb-record-set-mail record (list (cadr data)))
 218     (delete-region (point-min) (point-max))))
 219
 220 (defun bbdb-snarf-mail (record)
 221   "Snarf mail addresses for RECORD.
 222 This uses the first subexpresion of `bbdb-snarf-mail-regexp'."
 223   (let ((case-fold-search t) mails)
 224     (while (re-search-forward bbdb-snarf-mail-regexp nil t)
 225       (push (match-string 1) mails)
 226       (replace-match ""))
 227     (bbdb-record-set-mail record (nconc (bbdb-record-mail record) mails))))
 228
 229 (defun bbdb-snarf-label (field)
 230   "Extract the label before point, or return default label for FIELD."
 231   (save-match-data
 232     (if (looking-back "\\(?:^\\|[,:]\\)\\([^\n,:]+\\):[ \t]*"
 233                       (line-beginning-position))
 234         (prog1 (match-string 1)
 235           (delete-region (match-beginning 1) (match-end 0)))
 236       (cdr (assq field bbdb-snarf-default-label-alist)))))
 237
 238 (defun bbdb-snarf-phone-nanp (record)
 239   "Snarf NANP phone numbers for RECORD.
 240 NANP is the North American Numbering Plan used in North and Central America.
 241 This uses the first subexpresion of `bbdb-snarf-phone-nanp-regexp'."
 242   (let ((case-fold-search t) phones)
 243     (while (re-search-forward bbdb-snarf-phone-nanp-regexp nil t)
 244       (goto-char (match-beginning 0))
 245       (if (save-match-data
 246             (looking-back "[0-9A-Z]" nil)) ;; not really an NANP phone number
 247           (goto-char (match-end 0))
 248         (push (vconcat (list (bbdb-snarf-label 'phone))
 249                        (save-match-data
 250                          (bbdb-parse-phone (match-string 1))))
 251               phones)
 252         (replace-match "")))
 253     (bbdb-record-set-phone record (nconc (bbdb-record-phone record)
 254                                          (nreverse phones)))))
 255
 256 (defun bbdb-snarf-phone-eu (record &optional phone-regexp)
 257   "Snarf European phone numbers for RECORD.
 258 PHONE-REGEXP is the regexp to match a phone number.
 259 It defaults to `bbdb-snarf-phone-eu-regexp'."
 260   (let ((case-fold-search t) phones)
 261     (while (re-search-forward (or phone-regexp
 262                                   bbdb-snarf-phone-eu-regexp) nil t)
 263       (goto-char (match-beginning 0))
 264       (push (vector (bbdb-snarf-label 'phone)
 265                     (match-string 1))
 266             phones)
 267       (replace-match ""))
 268     (bbdb-record-set-phone record (nconc (bbdb-record-phone record)
 269                                          (nreverse phones)))))
 270
 271 (defun bbdb-snarf-streets (address)
 272   "Snarf streets for ADDRESS.  This assumes a narrowed region."
 273   (bbdb-address-set-streets address (bbdb-split "\n" (buffer-string)))
 274   (delete-region (point-min) (point-max)))
 275
 276 (defun bbdb-snarf-address-us (record)
 277   "Snarf a US address for RECORD."
 278   (let ((address (make-vector bbdb-address-length nil)))
 279     (cond ((re-search-forward bbdb-snarf-postcode-us-regexp nil t)
 280            ;; Streets, City, State Postcode
 281            (save-restriction
 282              (narrow-to-region (point-min) (match-end 0))
 283              ;; Postcode
 284              (goto-char (match-beginning 0))
 285              (bbdb-address-set-postcode address
 286               (bbdb-parse-postcode (match-string 1)))
 287              ;; State
 288              (skip-chars-backward " \t")
 289              (let ((pos (point)))
 290                (skip-chars-backward "^ \t,")
 291                (bbdb-address-set-state address (buffer-substring (point) pos)))
 292              ;; City
 293              (skip-chars-backward " \t,")
 294              (let ((pos (point)))
 295                (beginning-of-line)
 296                (bbdb-address-set-city address (buffer-substring (point) pos)))
 297              ;; Toss it
 298              (forward-char -1)
 299              (delete-region (point) (point-max))
 300              ;; Streets
 301              (goto-char (point-min))
 302              (bbdb-snarf-streets address)))
 303           ;; Try for just Streets, City, State
 304           ((let (case-fold-search)
 305              (re-search-forward "^\\(.*\\), \\([A-Z][A-Za-z]\\)$" nil t))
 306            (bbdb-address-set-city address (match-string 1))
 307            (bbdb-address-set-state address (match-string 2))
 308            (replace-match "")
 309            (save-restriction
 310              (narrow-to-region (point-min) (match-beginning 0))
 311              (goto-char (point-min))
 312              (bbdb-snarf-streets address))))
 313     (when (bbdb-address-city address)
 314       (if bbdb-snarf-address-us-country
 315           (bbdb-address-set-country address bbdb-snarf-address-us-country))
 316       ;; Fixme: There are no labels anymore.  `bbdb-snarf-streets' snarfed
 317       ;; everything that was left!
 318       (bbdb-address-set-label address (bbdb-snarf-label 'address))
 319       (bbdb-record-set-address record
 320                                (nconc (bbdb-record-address record)
 321                                       (list address))))))
 322
 323 (defun bbdb-snarf-address-eu (record &optional postcode-regexp country)
 324   "Snarf a European address for RECORD.
 325 POSTCODE-REGEXP is a regexp matching the postcode assumed to appear
 326 at the beginning of a line followed by the name of the city.  This format
 327 is used in many continental European countries.
 328 POSTCODE-REGEXP defaults to `bbdb-snarf-postcode-eu-regexp'.
 329 COUNTRY is the country to use.  It defaults to `bbdb-snarf-address-eu-country'."
 330   (when (re-search-forward (or postcode-regexp
 331                                bbdb-snarf-postcode-eu-regexp) nil t)
 332     (let ((address (make-vector bbdb-address-length nil)))
 333       (save-restriction
 334         (goto-char (match-end 0))
 335         (narrow-to-region (point-min) (line-end-position))
 336         ;; Postcode
 337         (bbdb-address-set-postcode address (match-string 1))
 338         ;; City
 339         (skip-chars-forward " \t")
 340         (bbdb-address-set-city address (buffer-substring (point) (point-max)))
 341         ;; Toss it
 342         (delete-region (match-beginning 0) (point-max))
 343         ;; Streets
 344         (goto-char (point-min))
 345         (bbdb-snarf-streets address))
 346       (unless country (setq country bbdb-snarf-address-eu-country))
 347       (if country (bbdb-address-set-country address country))
 348       (bbdb-address-set-label address (bbdb-snarf-label 'address))
 349       (bbdb-record-set-address record
 350                                (nconc (bbdb-record-address record)
 351                                       (list address))))))
 352
 353 (defun bbdb-snarf-url (record)
 354   "Snarf URL for RECORD.
 355 This uses the first subexpresion of `bbdb-snarf-url-regexp'."
 356   (when (and bbdb-snarf-url
 357              (let ((case-fold-search t))
 358                (re-search-forward bbdb-snarf-url-regexp nil t)))
 359     (bbdb-record-set-xfields
 360      record
 361      (nconc (bbdb-record-xfields record)
 362             (list (cons bbdb-snarf-url (match-string 1)))))
 363     (replace-match "")))
 364
 365 (defun bbdb-snarf-notes (record)
 366   "Snarf notes for RECORD."
 367   (when (/= (point-min) (point-max))
 368     (bbdb-record-set-xfields
 369      record
 370      (nconc (bbdb-record-xfields record)
 371             (list (cons bbdb-default-xfield (buffer-string)))))
 372     (erase-buffer)))
 373
 374 (defsubst bbdb-snarf-rule-interactive ()
 375   "Read snarf rule interactively."
 376   (intern
 377    (completing-read
 378     (format "Rule: (default `%s') " bbdb-snarf-rule-default)
 379     bbdb-snarf-rule-alist nil t nil nil
 380     (symbol-name bbdb-snarf-rule-default))))
 381
 382 ;;;###autoload
 383 (defun bbdb-snarf-paragraph (pos &optional rule)
 384   "Snarf BBDB record from paragraph around position POS using RULE.
 385 The paragraph is the one that contains POS or follows POS.
 386 Interactively POS is the position of point.
 387 RULE defaults to `bbdb-snarf-rule-default'.
 388 See `bbdb-snarf-rule-alist' for details."
 389   (interactive (list (point) (bbdb-snarf-rule-interactive)))
 390   (bbdb-snarf (save-excursion
 391                 (goto-char pos)
 392                 ;; similar to `mark-paragraph'
 393                 (let ((end (progn (forward-paragraph 1) (point))))
 394                   (buffer-substring-no-properties
 395                    (progn (backward-paragraph 1) (point))
 396                    end)))
 397               rule))
 398
 399 ;;;###autoload
 400 (defun bbdb-snarf-yank (&optional rule)
 401   "Snarf a BBDB record from latest kill using RULE.
 402 The latest kill may also be a window system selection, see `current-kill'.
 403 RULE defaults to `bbdb-snarf-rule-default'.
 404 See `bbdb-snarf-rule-alist' for details."
 405   (interactive (list (bbdb-snarf-rule-interactive)))
 406   (bbdb-snarf (current-kill 0) rule))
 407
 408 ;;;###autoload
 409 (defun bbdb-snarf (string &optional rule)
 410   "Snarf a BBDB record in STRING using RULE.  Display and return this record.
 411 Interactively, STRING is the current region.
 412 RULE defaults to `bbdb-snarf-rule-default'.
 413 See `bbdb-snarf-rule-alist' for details."
 414   (interactive
 415    (list (buffer-substring-no-properties (region-beginning) (region-end))
 416          (bbdb-snarf-rule-interactive)))
 417
 418   (bbdb-editable)
 419   (let ((record (bbdb-empty-record)))
 420     (with-current-buffer (get-buffer-create " *BBDB Snarf*")
 421       (erase-buffer)
 422       (insert (substring-no-properties string))
 423       (mapc (lambda (fun)
 424               (goto-char (point-min))
 425               (funcall fun record))
 426             (cdr (assq (or rule bbdb-snarf-rule-default)
 427                        bbdb-snarf-rule-alist))))
 428     (let ((old-record (car (bbdb-message-search
 429                             (bbdb-concat 'name-first-last
 430                                          (bbdb-record-firstname record)
 431                                          (bbdb-record-lastname record))
 432                             (car (bbdb-record-mail record))))))
 433       ;; Install RECORD after searching for OLD-RECORD
 434       (bbdb-change-record record)
 435       (if old-record (bbdb-merge-records old-record record)))
 436     (bbdb-display-records (list record))
 437     record))
 438
 439 ;; Some test cases
 440 ;;
 441 ;; US:
 442 ;;
 443 ;; another test person
 444 ;; 1234 Gridley St.
 445 ;; Los Angeles, CA 91342
 446 ;; 555-1212
 447 ;; test@person.net
 448 ;; http://www.foo.bar/
 449 ;; other stuff about this person
 450 ;;
 451 ;; test person
 452 ;; 1234 Gridley St.
 453 ;; St. Los Angeles, CA 91342-1234
 454 ;; 555-1212
 455 ;; <test@person.net>
 456 ;;
 457 ;; x test person
 458 ;; 1234 Gridley St.
 459 ;; Los Angeles, California 91342-1234
 460 ;; work: 555-1212
 461 ;; home: 555-1213
 462 ;; test@person.net
 463 ;;
 464 ;; y test person
 465 ;; 1234 Gridley St.
 466 ;; Los Angeles, CA
 467 ;; 555-1212
 468 ;; test@person.net
 469 ;;
 470 ;; z test person
 471 ;; 555-1212
 472 ;; test@person.net
 473 ;;
 474 ;; EU:
 475 ;;
 476 ;; Maja Musterfrau
 477 ;; Strasse 15
 478 ;; 12345 Ort
 479 ;; +49 12345
 480 ;; phon: (110) 123 456
 481 ;; mobile: (123) 456 789
 482 ;; xxx.xxx@xxxx.xxx
 483 ;; http://www.xxx.xx
 484 ;; notes bla bla bla
 485
 486 (provide 'bbdb-snarf)
 487
 488 ;;; bbdb-snarf.el ends here