[emacs] update 4 drones
[~bandali/configs] / lisp / bbdb / bbdb-snarf.el
CommitLineData
1a5de666
AB
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.
64Each rule is of the form (KEY FUNCTION FUNCTION ...).
65The symbol KEY identifies the rule, see also `bbdb-snarf-rule-default'.
66
67Snarfing is a cumulative process. The text is copied to a temporary
68snarf buffer that becomes current during snarfing.
69Each FUNCTION is called with one arg, the RECORD we are snarfing,
70and with point at the beginning of the snarf buffer. FUNCTION should populate
71the fields of RECORD. It may delete the part of the snarf buffer
72that it has processed so that the remaining FUNCTIONs operate only
73on those parts that were not yet snarfed. The order of the FUNCTION calls
74in a rule is then crucial.
75Unlike other parts of BBDB, FUNCTIONs need not update the cache and
76hash 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.
89The 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.
97The 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.
107NANP is the North American Numbering Plan used in North and Central America.
108The 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.
116The 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.
126The 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
140of 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.
153This is an alist where each element is a cons pair (FIELD . LABEL).
154The symbol FIELD denotes a record field like `phone' or `address'.
155The 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.
167The 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.
222This 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.
240NANP is the North American Numbering Plan used in North and Central America.
241This 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.
258PHONE-REGEXP is the regexp to match a phone number.
259It 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.
325POSTCODE-REGEXP is a regexp matching the postcode assumed to appear
326at the beginning of a line followed by the name of the city. This format
327is used in many continental European countries.
328POSTCODE-REGEXP defaults to `bbdb-snarf-postcode-eu-regexp'.
329COUNTRY 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.
355This 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.
385The paragraph is the one that contains POS or follows POS.
386Interactively POS is the position of point.
387RULE defaults to `bbdb-snarf-rule-default'.
388See `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.
402The latest kill may also be a window system selection, see `current-kill'.
403RULE defaults to `bbdb-snarf-rule-default'.
404See `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.
411Interactively, STRING is the current region.
412RULE defaults to `bbdb-snarf-rule-default'.
413See `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