Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-17 01:34:21 +00:00
Code Issues Projects Releases Packages Wiki Activity

BBDB: Import BBDB 3

Browse source 
Import revision 5ac6dbf7e9676d1e239b4f66fad54711e8da4341 from
the externals/bbdb branch of
git.sv.gnu.org:/srv/git/emacs/elpa.git.

* doc/misc/bbdb.texi,
lisp/bbdb/bbdb-anniv.el,
lisp/bbdb/bbdb-com.el,
lisp/bbdb/bbdb-ispell.el,
lisp/bbdb/bbdb-message.el,
lisp/bbdb/bbdb-mhe.el,
lisp/bbdb/bbdb-migrate.el,
lisp/bbdb/bbdb-mu4e.el,
lisp/bbdb/bbdb-mua.el,
lisp/bbdb/bbdb-pgp.el,
lisp/bbdb/bbdb-rmail.el,
lisp/bbdb/bbdb-snarf.el,
lisp/bbdb/bbdb-tex.el,
lisp/bbdb/bbdb-wl.el,
lisp/bbdb/bbdb.el,
lisp/bbdb/tex/bbdb.sty: New files.
* .gitignore: Add lisp/bbdb/subdirs.el.
This commit is contained in:
Thomas Fitzsimmons 2017-11-02 19:59:58 -04:00
parent 13248f7444
commit 9bfbbd499e
17 changed files with 11029 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -75,6 +75,7 @@ src/lisp.mk
# Lisp-level sources built by 'make'.
*cus-load.el
*loaddefs.el
lisp/bbdb/subdirs.el
lisp/cedet/semantic/bovine/c-by.el
lisp/cedet/semantic/bovine/make-by.el
lisp/cedet/semantic/bovine/scm-by.el

92
doc/misc/bbdb.texi Normal file
View file

@ -0,0 +1,92 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename bbdb.info
@settitle Insidious Big Brother Database (BBDB) User Manual
@c %**end of header
@copying
This file documents the Insidious Big Brother Database (BBDB)
Copyright (C) 2011-2017 Roland Winkler <winkler@@gnu.org>
@quotation
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with the Invariant Section being ``GNU GENERAL PUBLIC LICENSE,''
A copy of the license is included in the section entitled
``GNU Free Documentation License.''
@end quotation
@end copying
@dircategory Emacs misc features
@direntry
* BBDB: (bbdb). Insidious Big Brother Database (BBDB).
@end direntry
@titlepage
@title Insidious Big Brother Database (BBDB) User Manual
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@c Output the table of the contents at the beginning.
@contents
@ifnottex
@node Top, First Chapter, (dir), (dir)
@top BBDB User Manual
@insertcopying
@end ifnottex
@menu
* First Chapter:: The first chapter is the only chapter
in this sample.
Appendices
* Copying:: The GNU General Public License gives you permission
to redistribute GNU Emacs on certain terms;
it also explains that there is no warranty.
* GNU Free Documentation License:: The license for this documentation.
* Index:: Complete index.
@end menu
@node First Chapter, Copying, Top, Top
@chapter First Chapter
@cindex chapter, first
This is the first chapter.
@cindex index entry, another
Here is a numbered list.
@enumerate
@item
This is the first item.
@item
This is the second item.
@end enumerate
@node Copying, GNU Free Documentation License, First Chapter, Top
@appendix GNU GENERAL PUBLIC LICENSE
@include gpl.texi
@node GNU Free Documentation License, Index, Copying, Top
@appendix GNU Free Documentation License
@include doclicense.texi
@node Index, , GNU Free Documentation License, Top
@unnumbered Index
@printindex cp
@bye

211
lisp/bbdb/bbdb-anniv.el Normal file
View file

@ -0,0 +1,211 @@
;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'.
;; Each such field may contain multiple anniversaries entries with separators
;; defined via `bbdb-separator-alist' (newlines by default).
;; Each anniversary entry is a string DATE followed by optional TEXT.
;; DATE may take the same format as the date of ordinary diary entries.
;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'.
;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary,
;; FORM is used to display the anniversary entry in the diary buffer.
;; If FORM is nil, TEXT is used instead to display the anniversary entry
;; in the diary buffer.
;;
;; To display BBDB anniversaries in the Emacs diary,
;; call `bbdb-initialize' with arg `anniv'.
;;
;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(require 'bbdb-com)
(require 'diary-lib)
(eval-when-compile
(require 'cl-lib))
(defcustom bbdb-anniv-alist
'((birthday . "%n's %d%s birthday")
(wedding . "%n's %d%s wedding anniversary")
(anniversary))
"Alist of rules for formatting anniversaries in the diary buffer.
Each element is of the form (LABEL . FORM).
LABEL is the xfield where this type of anniversaries is stored.
FORM is a format string with the following substitutions:
%n name of the record
%d number of years
%s ordinal suffix (st, nd, rd, th) for the year.
%t the optional text following the date string in field LABEL.
If FORM is nil, use the text following the date string in field LABEL
as format string."
:type '(repeat (cons :tag "Rule"
(symbol :tag "Label")
(choice (string)
(const nil))))
:group 'bbdb-utilities-anniv)
;; `bbdb-anniv-diary-entries' becomes a member of `diary-list-entries-hook'.
;; When this hook is run by `diary-list-entries', the variable `original-date'
;; is bound to the value of arg DATE of `diary-list-entries'.
;; Also, `number' is arg NUMBER of `diary-list-entries'.
;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.
(defvar original-date) ; defined in diary-lib
(with-no-warnings (defvar number)) ; defined in diary-lib
;;;###autoload
(defun bbdb-anniv-diary-entries ()
"Add anniversaries from BBDB records to `diary-list-entries'.
This obeys `calendar-date-style' via `diary-date-forms'.
To enable this feature, put the following into your .emacs:
\(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)"
;; Loop over NUMBER dates starting from ORGINAL-DATE.
(let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
(end-date (+ num-date number)))
(while (<= (setq num-date (1+ num-date)) end-date)
(let* ((date (calendar-gregorian-from-absolute num-date))
(dd (calendar-extract-day date))
(mm (calendar-extract-month date))
(yy (calendar-extract-year date))
;; We construct a regexp that only uses shy groups,
;; except for the part of the regexp matching the year.
;; This way we can grab the year from the date string.
(year "\\([0-9]+\\)\\|\\*")
(dayname (format "%s\\|%s\\.?" (calendar-day-name date)
(calendar-day-name date 'abbrev)))
(lex-env `((day . ,(format "0*%d" dd))
(month . ,(format "0*%d" mm)) (year . ,year)
(dayname . ,dayname)
(monthname . ,(format "%s\\|%s" (calendar-month-name mm)
(calendar-month-name mm 'abbrev)))))
;; Require that the matched date is at the beginning of the string.
(fmt (format "\\`%s?\\(?:%%s\\)"
(regexp-quote diary-nonmarking-symbol)))
date-forms)
(cl-flet ((fun (date-form)
(push (cons (format fmt
(mapconcat (lambda (form) (eval form lex-env))
(if (eq (car date-form) 'backup)
(cdr date-form) date-form)
"\\)\\(?:"))
(eq (car date-form) 'backup))
date-forms)))
(mapc #'fun diary-date-forms)
;; The anniversary of February 29 is considered to be March 1
;; in non-leap years. So we search for February 29, too.
(when (and (= mm 3) (= dd 1)
(not (calendar-leap-year-p yy)))
(setq lex-env `((day . "0*29") (month . "0*2") (year . ,year)
(dayname . ,dayname)
(monthname . ,(format "%s\\|%s" (calendar-month-name 2)
(calendar-month-name 2 'abbrev)))))
(mapc #'fun diary-date-forms)))
(dolist (record (bbdb-records))
(dolist (rule bbdb-anniv-alist)
(dolist (anniv (bbdb-record-xfield-split record (car rule)))
(let ((date-forms date-forms)
(anniv-string (concat anniv " X")) ; for backup forms
(case-fold-search t)
form yr text)
(while (setq form (pop date-forms))
(when (string-match (car form) anniv-string)
(setq date-forms nil
yr (match-string 1 anniv-string)
yr (if (and yr (string-match-p "[0-9]+" yr))
(- yy (string-to-number yr))
100) ; as in `diary-anniversary'
;; For backup forms we should search backward in
;; anniv-string from (match-end 0) for "\\<".
;; That gets too complicated here!
;; Yet for the default value of `diary-date-forms'
;; this would matter only if anniv-string started
;; with a time. That is rather rare for anniversaries.
;; Then we may simply step backward by one character.
text (substring anniv-string (if (cdr form) ; backup
(1- (match-end 0))
(match-end 0))
-1)
text (replace-regexp-in-string "\\`[ \t]+" "" text)
text (replace-regexp-in-string "[ \t]+\\'" "" text))
(if (cdr rule)
(setq text (replace-regexp-in-string "%t" text (cdr rule))))
;; Add the anniversaries to `diary-entries-list'.
(if (and (numberp yr) (< 0 (length text)))
(diary-add-to-list
date
;; `diary-add-to-list' expects an arg SPECIFIER for being
;; able to jump to the location of the entry in the diary
;; file. Here we only have BBDB records. So we use
;; an empty string for SPECIFIER, but instead we `propertize'
;; the STRING passed to `diary-add-to-list'.
(propertize
(format
;; Text substitution similar to `diary-anniversary'.
(replace-regexp-in-string "%n" (bbdb-record-name record) text)
yr (diary-ordinal-suffix yr))
'diary-goto-entry (list 'bbdb-display-records (list record)))
""))))))))))))
;; based on `diary-goto-entry'
(defun bbdb-anniv-goto-entry (button)
"Jump to the diary entry for the BUTTON at point.
The character at point may have a text property `diary-goto-entry'
which should be a list (FUNCTION ARG1 ARG2 ...). Then call FUNCTION
with args ARG1, ARG2, ... to locate the entry. Otherwise follow
the rules used by `diary-goto-entry'."
(let* ((fun-call (get-text-property (overlay-start button)
'diary-goto-entry))
(locator (button-get button 'locator))
(marker (car locator))
markbuf file)
(cond (fun-call
(apply (car fun-call) (cdr fun-call)))
;; If marker pointing to diary location is valid, use that.
((and marker (setq markbuf (marker-buffer marker)))
(pop-to-buffer markbuf)
(goto-char (marker-position marker)))
;; Marker is invalid (eg buffer has been killed).
((and (setq file (cadr locator))
(file-exists-p file)
(find-file-other-window file))
(when (eq major-mode (default-value 'major-mode)) (diary-mode))
(goto-char (point-min))
(if (re-search-forward (format "%s.*\\(%s\\)"
(regexp-quote (nth 2 locator))
(regexp-quote (nth 3 locator)))
nil t)
(goto-char (match-beginning 1))))
(t
(message "Unable to locate this diary entry")))))
;; `diary-goto-entry-function' is rather inflexible if multiple packages
;; want to use it for its purposes: this variable can be hijacked
;; only once. Here our function `bbdb-anniv-goto-entry' should work
;; for other packages, too.
(setq diary-goto-entry-function 'bbdb-anniv-goto-entry)
(provide 'bbdb-anniv)
;;; bbdb-anniv.el ends here

2825
lisp/bbdb/bbdb-com.el Normal file
View file

File diff suppressed because it is too large Load diff

127
lisp/bbdb/bbdb-ispell.el Normal file
View file

@ -0,0 +1,127 @@
;;; bbdb-ispell.el --- export names from BBDB to personal ispell dictionaries -*- lexical-binding: t -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
;; Author: Ivan Kanis <ivan.kanis@googlemail.com>
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Names are often not recognized by the standard ispell dictionaries.
;; `bbdb-ispell-export' exports the names from your BBDB records to your
;; personal ispell dictionaries.
;; The personal dictionaries are in `bbdb-ispell-dictionary-list'
;; The BBDB fields for this are in `bbdb-ispell-field-list'.
;; Exclude words via `bbdb-ispell-min-word-length' and `bbdb-ispell-ignore-re'.
;;
;; Bugs:
;; Save your personal directories before running this code. I had my
;; dictionary truncated while debugging. It shouldn't happen
;; but better be safe than sorry...
;;
;; See the BBDB info manual for documentation.
;;; Code:
(require 'ispell)
(require 'bbdb)
(defcustom bbdb-ispell-dictionary-list '("default")
"List of ispell personal dictionaries.
Allowed elements are as in the return value of `ispell-valid-dictionary-list'."
:group 'bbdb-utilities-ispell
:type (cons 'set (mapcar (lambda (dict) `(string ,dict))
(ispell-valid-dictionary-list))))
(defcustom bbdb-ispell-field-list '(name organization aka)
"List of fields of each BBDB record considered for the personal dictionary."
:group 'bbdb-utilities-ispell
:type (list 'repeat
(append '(choice) (mapcar (lambda (field) `(const ,field))
'(name organization affix aka address))
'((symbol :tag "xfield")))))
(defcustom bbdb-ispell-min-word-length 3
"Words with fewer characters are ignored."
:group 'bbdb-utilities-ispell
:type 'number)
(defcustom bbdb-ispell-ignore-re "[^[:alpha:]]"
"Words matching this regexp are ignored."
:group 'bbdb-utilities-ispell
:type 'regexp)
;; Internal variable
(defvar bbdb-ispell-word-list nil
"List of words extracted from the BBDB records.")
;;;###autoload
(defun bbdb-ispell-export ()
"Export BBDB records to ispell personal dictionaries."
(interactive)
(message "Exporting to personal dictionary...")
(let (bbdb-ispell-word-list)
;; Collect words from BBDB records.
(dolist (record (bbdb-records))
(dolist (field bbdb-ispell-field-list)
(bbdb-ispell-collect-words (bbdb-record-field record field))))
;; Update personal dictionaries
(dolist (dict (or bbdb-ispell-dictionary-list '("default")))
(ispell-change-dictionary dict)
;; Initialize variables and dicts alists
(ispell-set-spellchecker-params)
(ispell-init-process)
;; put in verbose mode
(ispell-send-string "%\n")
(let (new)
(dolist (word (delete-dups bbdb-ispell-word-list))
(ispell-send-string (concat "^" word "\n"))
(while (progn
(ispell-accept-output)
(not (string= "" (car ispell-filter)))))
;; remove extra \n
(setq ispell-filter (cdr ispell-filter))
(when (and ispell-filter
(listp ispell-filter)
(not (eq (ispell-parse-output (car ispell-filter)) t)))
;; ok the word doesn't exist, add it
(ispell-send-string (concat "*" word "\n"))
(setq new t)))
(when new
;; Save dictionary:
;; aspell doesn't tell us when it completed the saving.
;; So we send it another word for spellchecking.
(ispell-send-string "#\n^hello\n")
(while (progn
(ispell-accept-output)
(not (string= "" (car ispell-filter)))))))))
(message "Exporting to personal dictionary...done"))
(defun bbdb-ispell-collect-words (field)
"Parse BBDB FIELD and collect words in `bbdb-ispell-word-list'."
;; Ignore everything in FIELD that is not a string or a sequence.
(cond ((stringp field)
(dolist (word (split-string field))
(if (and (>= (length word) bbdb-ispell-min-word-length)
(not (string-match bbdb-ispell-ignore-re word)))
(push word bbdb-ispell-word-list))))
((sequencep field) (mapc 'bbdb-ispell-collect-words field))))
(provide 'bbdb-ispell)
;;; bbdb-ispell.el ends here

56
lisp/bbdb/bbdb-message.el Normal file
View file

@ -0,0 +1,56 @@
;;; bbdb-message.el --- BBDB interface to Mail Composition Packages. -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This file contains the BBDB interface to Mail Composition Packages.
;;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(require 'message)
(require 'sendmail)
;;;###autoload
(defun bbdb-insinuate-message ()
"Hook BBDB into Message Mode.
Do not call this in your init file. Use `bbdb-initialize'."
;; Suggestions welcome: What are good keybindings for the following
;; commands that do not collide with existing bindings?
;; (define-key message-mode-map "'" 'bbdb-mua-display-recipients)
;; (define-key message-mode-map ";" 'bbdb-mua-edit-field-recipients)
;; (define-key message-mode-map "/" 'bbdb)
(if bbdb-complete-mail
(define-key message-mode-map "\M-\t" 'bbdb-complete-mail)))
;;;###autoload
(defun bbdb-insinuate-mail ()
"Hook BBDB into Mail Mode.
Do not call this in your init file. Use `bbdb-initialize'."
;; Suggestions welcome: What are good keybindings for the following
;; commands that do not collide with existing bindings?
;; (define-key mail-mode-map "'" 'bbdb-mua-display-recipients)
;; (define-key mail-mode-map ";" 'bbdb-mua-edit-field-recipients)
;; (define-key mail-mode-map "/" 'bbdb)
(if bbdb-complete-mail
(define-key mail-mode-map "\M-\t" 'bbdb-complete-mail)))
(provide 'bbdb-message)
;;; bbdb-message.el ends here

99
lisp/bbdb/bbdb-mhe.el Normal file
View file

@ -0,0 +1,99 @@
;;; bbdb-mhe.el --- BBDB interface to mh-e -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This file contains the BBDB interface to mh-e.
;;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(require 'bbdb-com)
(require 'bbdb-mua)
(require 'mh-e)
(if (fboundp 'mh-version)
(require 'mh-comp)) ; For mh-e 4.x
(require 'advice)
;; A simplified `mail-fetch-field'. We could use instead (like rmail):
;; (mail-header (intern-soft (downcase header)) (mail-header-extract))
(defun bbdb/mh-header (header)
"Find and return the value of HEADER in the current buffer.
Returns the empty string if HEADER is not in the message."
(let ((case-fold-search t))
(goto-char (point-min))
;; This will be fooled if HEADER appears in the body of the message.
;; Also, it fails if HEADER appears more than once.
(cond ((not (re-search-forward header nil t)) "")
((looking-at "[\t ]*$") "")
(t (re-search-forward "[ \t]*\\([^ \t\n].*\\)$" nil t)
(let ((start (match-beginning 1)))
(while (progn (forward-line 1)
(looking-at "[ \t]")))
(backward-char 1)
(buffer-substring-no-properties start (point)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Use BBDB for interactive spec of MH-E commands
(defadvice mh-send (before mh-bbdb-send act)
(interactive
(list (bbdb-completing-read-mails "To: ")
(bbdb-completing-read-mails "Cc: ")
(read-string "Subject: "))))
(defadvice mh-send-other-window (before mh-bbdb-send-other act)
(interactive
(list (bbdb-completing-read-mails "To: ")
(bbdb-completing-read-mails "Cc: ")
(read-string "Subject: "))))
(defadvice mh-forward (before mh-bbdb-forward act)
(interactive
(list (bbdb-completing-read-mails "To: ")
(bbdb-completing-read-mails "Cc: ")
(if current-prefix-arg
(mh-read-seq-default "Forward" t)
(mh-get-msg-num t)))))
(defadvice mh-redistribute (before mh-bbdb-redist act)
(interactive
(list (bbdb-completing-read-mails "Redist-To: ")
(bbdb-completing-read-mails "Redist-Cc: ")
(mh-get-msg-num t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun bbdb-insinuate-mh ()
"Call this function to hook BBDB into MH-E.
Do not call this in your init file. Use `bbdb-initialize'."
(define-key mh-folder-mode-map ":" 'bbdb-mua-display-sender)
(define-key mh-folder-mode-map ";" 'bbdb-mua-edit-field-sender)
;; Do we need keybindings for more commands? Suggestions welcome.
;; (define-key mh-folder-mode-map ":" 'bbdb-mua-display-records)
;; (define-key mh-folder-mode-map "'" 'bbdb-mua-display-recipients)
;; (define-key mh-folder-mode-map ";" 'bbdb-mua-edit-field-recipients)
(when bbdb-complete-mail
(define-key mh-letter-mode-map "\M-;" 'bbdb-complete-mail)
(define-key mh-letter-mode-map "\e\t" 'bbdb-complete-mail)))
(provide 'bbdb-mhe)
;;; bbdb-mhe.el ends here

282
lisp/bbdb/bbdb-migrate.el Normal file
View file

@ -0,0 +1,282 @@
;;; bbdb-migrate.el --- migration functions for BBDB -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This file contains the migration functions for BBDB.
;;; See the BBDB info manual for documentation.
;; Changes in `bbdb-file-format':
;; 3 Date format for `creation-date' and `timestamp' changed
;; from "dd mmm yy" (ex: 25 Sep 97) to "yyyy-mm-dd" (ex: 1997-09-25).
;; 4 Country field added.
;; 5 Streets are lists.
;; 6 Postcodes are plain strings.
;; 7 New field `affix'. Organizations are a list.
;; Xfields is always a list.
;; (8 Skipped format in "official BBDB": Some BBDB users introduced
;; an xfield uuid in their format 8. To bring them back, we jump
;; straight from 7 to 9.)
;; 9 New field uuid. Make `creation-date' and `timestamp' immutable fields.
;;; Code:
(require 'bbdb)
;;; Migrating the BBDB
(defvar bbdb-migrate-uuid-xfield 'uuid
"Xfield holding a uuid in file format 8.")
;;;###autoload
(defun bbdb-migrate (records old)
"Migrate RECORDS from format OLD to `bbdb-file-format'."
;; Some BBDB files were corrupted by random outer layers of
;; parentheses surrounding the actual correct data. We attempt to
;; compensate for this.
(while (and (consp records)
(listp (car records))
(null (cdr records)))
(setq records (car records)))
;; `bbdb-migrate-lambda' uses the usual functions to access and set
;; the fields of a record. So if a new record format changes
;; the set of fields, we need to make these changes first.
;; Format 7: Add new field `affix'.
(if (< old 7)
(let (new-records)
(dolist (record records)
(push (vector (elt record 0) (elt record 1) nil
(elt record 2) (elt record 3) (elt record 4)
(elt record 5) (elt record 6) (elt record 7)
(elt record 8))
new-records))
(setq records (nreverse new-records))))
;; Format 9: New field `uuid'.
;; Make `creation-date' and `timestamp' immutable fields.
(if (< old 9)
(let (new-records)
(dolist (record records)
(let ((uuid (or (cdr (assq bbdb-migrate-uuid-xfield (elt record 8)))
(bbdb-uuid)))
(creation-date (or (cdr (assq 'creation-date (elt record 8)))
(format-time-string bbdb-time-stamp-format nil t)))
(timestamp (or (cdr (assq 'timestamp (elt record 8)))
(format-time-string bbdb-time-stamp-format nil t))))
(push (vector (elt record 0) (elt record 1) (elt record 2)
(elt record 3) (elt record 4) (elt record 5)
(elt record 6) (elt record 7)
(let ((xfields (elt record 8)))
(dolist (elt '(uuid creation-date timestamp))
(setq xfields (assq-delete-all elt xfields)))
xfields)
uuid creation-date timestamp
(elt record 9))
new-records)))
(setq records (nreverse new-records))))
(mapc (bbdb-migrate-lambda old) records)
records)
(defconst bbdb-migrate-alist
'((3 (bbdb-record-xfields bbdb-record-set-xfields
bbdb-migrate-dates))
(4 (bbdb-record-address bbdb-record-set-address
bbdb-migrate-add-country))
(5 (bbdb-record-address bbdb-record-set-address
bbdb-migrate-streets-to-list))
(6 (bbdb-record-address bbdb-record-set-address
bbdb-migrate-postcode-to-string))
(7 (bbdb-record-xfields bbdb-record-set-xfields
bbdb-migrate-xfields-to-list)
(bbdb-record-organization bbdb-record-set-organization
bbdb-migrate-organization-to-list)))
;; Formats 8 and 9: do nothing
"Alist (VERSION . CHANGES).
CHANGES is a list with elements (GET SET FUNCTION) that expands
to action (SET record (FUNCTION (GET record))).")
(defun bbdb-migrate-lambda (old)
"Return the function to migrate from OLD to `bbdb-file-format'.
The manipulations are defined by `bbdb-migrate-alist'."
(let (spec)
(while (<= old bbdb-file-format)
(setq spec (append spec (cdr (assoc old bbdb-migrate-alist)))
old (1+ old)))
`(lambda (record)
,@(mapcar (lambda (change)
;; (SET record (FUNCTION (GET record)))
`(,(nth 1 change) record ; SET
(,(nth 2 change) ; FUNCTION
(,(nth 0 change) record)))) ; GET
spec)
record)))
(defun bbdb-migrate-postcode-to-string (addresses)
"Make all postcodes plain strings.
This uses the code that used to be in `bbdb-address-postcode'."
;; apply the function to all addresses in the list and return a
;; modified list of addresses
(mapcar (lambda (address)
(let ((postcode (bbdb-address-postcode address)))
(bbdb-address-set-postcode
address
(cond ((stringp postcode)
postcode)
;; nil or zero
((or (zerop postcode)
(null postcode))
"")
;; a number
((numberp postcode)
(format "%d" postcode))
;; list with two strings
((and (stringp (nth 0 postcode))
(stringp (nth 1 postcode)))
;; the second string starts with 4 digits
(if (string-match "^[0-9][0-9][0-9][0-9]"
(nth 1 postcode))
(format "%s-%s" (nth 0 postcode) (nth 1 postcode))
;; ("abc" "efg")
(format "%s %s" (nth 0 postcode) (nth 1 postcode))))
;; list with two numbers
((and (integerp (nth 0 postcode))
(integerp (nth 1 postcode)))
(format "%05d-%04d" (nth 0 postcode) (nth 1 postcode)))
;; list with a string and a number
((and (stringp (nth 0 postcode))
(integerp (nth 1 postcode)))
(format "%s-%d" (nth 0 postcode) (nth 1 postcode)))
;; ("SE" (123 45))
((and (stringp (nth 0 postcode))
(integerp (nth 0 (nth 1 postcode)))
(integerp (nth 1 (nth 1 postcode))))
(format "%s-%d %d" (nth 0 postcode) (nth 0 (nth 1 postcode))
(nth 1 (nth 1 postcode))))
;; last possibility
(t (format "%s" postcode)))))
address)
addresses))
(defun bbdb-migrate-dates (xfields)
"Change date formats.
Formats are changed in timestamp and creation-date fields from
\"dd mmm yy\" to \"yyyy-mm-dd\"."
(unless (stringp xfields)
(mapc (lambda (xfield)
(when (memq (car xfield) '(creation-date timestamp))
(bbdb-migrate-date xfield)))
xfields)
xfields))
(defun bbdb-migrate-date (field)
"Convert date field FIELD from \"dd mmm yy\" to \"yyyy-mm-dd\"."
(let* ((date (cdr field))
(parsed (timezone-parse-date (concat date " 00:00:00"))))
;; If `timezone-parse-date' cannot make sense of its arg DATE
;; it returns ["0" "0" "0" "0" nil].
(if (equal parsed ["0" "0" "0" "0" nil])
(setq parsed (timezone-parse-date date)))
(when (equal parsed ["0" "0" "0" "0" nil])
(cond ((string-match
"^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
(setq parsed (vector (match-string 1 date) (match-string 2 date)
(match-string 3 date))))
((string-match
"^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
(setq parsed (vector (match-string 3 date) (match-string 1 date)
(match-string 2 date))))))
;; We need numbers for the following sanity check
(dotimes (i 3)
(if (stringp (aref parsed i))
(aset parsed i (string-to-number (aref parsed i)))))
;; Sanity check
(if (and (< 0 (aref parsed 0))
(< 0 (aref parsed 1)) (< (aref parsed 1) 13)
(< 0 (aref parsed 2))
(<= (aref parsed 2)
(timezone-last-day-of-month (aref parsed 1) (aref parsed 0))))
(setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
(aref parsed 1) (aref parsed 2)))
(error "BBDB cannot parse %s header value %S for upgrade"
field date))))
(defun bbdb-migrate-add-country (addrl)
"Add a country field to each address in the address list."
(mapcar (lambda (address) (vconcat address [bbdb-default-country])) addrl))
(defun bbdb-migrate-streets-to-list (addrl)
"Convert the streets to a list."
(mapcar (lambda (address)
(vector (aref address 0) ; key
(delq nil (delete "" ; nuke empties
(list (aref address 1) ; street1
(aref address 2) ; street2
(aref address 3))));street3
(aref address 4) ; city
(aref address 5) ; state
(aref address 6) ; postcode
(aref address 7))) ; country
addrl))
(defun bbdb-migrate-xfields-to-list (xfields)
"Migrate XFIELDS to list."
(if (stringp xfields)
`((notes . ,xfields))
xfields))
(defun bbdb-migrate-organization-to-list (organization)
"Migrate ORGANIZATION to list."
(if (stringp organization)
(bbdb-split 'organization organization)
organization))
;;;###autoload
(defun bbdb-undocumented-variables (&optional name-space message)
"Return list of undocumented variables in NAME-SPACE.
NAME-SPACE defaults to \"bbdb-\". Use a prefix arg to specify NAME-SPACE
interactively. If MESSAGE is non-nil (as in interactive calls) display
the list in the message area.
This command may come handy to identify BBDB variables in your init file
that are not used anymore by the current version of BBDB. Yet this fails
for outdated BBDB variables that are set via your personal `custom-file'."
(interactive (list (if current-prefix-arg
(read-string "Name space: ")) t))
(let ((re (concat "\\`" (or name-space "bbdb-"))) list)
(mapatoms (lambda (vv)
(if (and (boundp vv)
(string-match re (symbol-name vv))
(not (get vv 'variable-documentation))
(not (get vv 'byte-obsolete-variable)))
(push vv list))))
(if message
(if list
(apply 'message (concat "Undocumented variables: "
(mapconcat (lambda (_m) "%s") list " ")) list)
(message "No undocumented variables `%s...'" name-space)))
list))
(provide 'bbdb-migrate)
;;; bbdb-migrate.el ends here

44
lisp/bbdb/bbdb-mu4e.el Normal file
View file

@ -0,0 +1,44 @@
;;; bbdb-mu4e.el --- BBDB interface to mu4e -*- lexical-binding: t -*-
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file contains the BBDB interface to mu4e.
;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(if t (require 'mu4e-view))
(defvar mu4e-view-mode-map)
;;;###autoload
(defun bbdb-insinuate-mu4e ()
"Hook BBDB into mu4e.
Do not call this in your init file. Use `bbdb-initialize'."
;; Tackle headers later
;; (define-key mu4e-headers-mode-map ":" 'bbdb-mua-display-sender)
;; (define-key mu4e-headers-mode-map ";" 'bbdb-mua-edit-field-sender)
;; Do we need keybindings for more commands? Suggestions welcome.
(define-key mu4e-view-mode-map ":" 'bbdb-mua-display-sender)
(define-key mu4e-view-mode-map ";" 'bbdb-mua-edit-field-sender))
(provide 'bbdb-mu4e)
;;; bbdb-mu4e.el ends here

1062
lisp/bbdb/bbdb-mua.el Normal file
View file

File diff suppressed because it is too large Load diff

238
lisp/bbdb/bbdb-pgp.el Normal file
View file

@ -0,0 +1,238 @@
;;; bbdb-pgp.el --- use BBDB to handle PGP preferences -*- lexical-binding: t -*-
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; It is believed that encrypted mail works best if all mail between
;; individuals is encrypted - even concerning matters that are not
;; confidential. The reasoning is that confidential messages cannot
;; then be easily spotted and decryption efforts concentrated on them.
;; Some people therefore prefer to have all their email encrypted.
;; This package allows you to mark the BBDB entries for those
;; individuals so that messages will be (signed or) encrypted
;; when they are sent.
;;; Usage:
;; Add the xfield pgp-mail (see `bbdb-pgp-field') with the value
;; `sign' or `encrypt' to the BBDB records of the message recipients.
;; If the value is `sign-query' or `encrypt-query', this will query
;; whether to send signed or encrypted messages.
;;
;; Then call `bbdb-pgp' on outgoing message to add MML tags,
;; see info node `(message)security'. For all message recipients
;; in `bbdb-pgp-headers', this command grabs the action in `bbdb-pgp-field'
;; of their BBDB records. If this proposes multiple actions,
;; perform the action which appears first in `bbdb-pgp-ranked-actions'.
;; If this proposes no action at all, use `bbdb-pgp-default'.
;; The variable `bbdb-pgp-method' defines the method which is actually used
;; for signing and encrypting, see also `bbdb-pgp-method-alist'.
;;
;; `bbdb-pgp' works with both `mail-mode' and `message-mode' to send
;; signed or encrypted mail.
;;
;; To run `bbdb-pgp' automatically when sending a message,
;; use `bbdb-initialize' with arg `pgp' to add this function
;; to `message-send-hook' and `mail-send-hook'.
;; Yet see info node `(message)Signing and encryption' why you
;; might not want to rely for encryption on a hook function
;; which runs just before the message is sent, that is, you might want
;; to call the command `bbdb-pgp' manually, then call `mml-preview'.
;;
;; A thought: For these hooks we could define a wrapper that calls
;; first `bbdb-pgp', then `mml-preview' for preview. The wrapper should
;; abort the sending of the message if the preview is not getting
;; the user's approval. Yet this might require some recursive editing mode
;; so that the user can browse the preview before approving it.
;;
;;; Todo:
;; Spot incoming PGP-signed or encrypted messages and prompt for adding
;; `bbdb-pgp-field' to the senders' BBDB records; similar to how
;; bbdb-sc.el maintains attribution preferences.
;;; Code:
(require 'message)
(require 'bbdb-com)
(defcustom bbdb-pgp-field 'pgp-mail
"BBDB xfield holding the PGP action.
If the recipient of a message has this xfield in his/her BBDB record,
its value determines whether `bbdb-pgp' signs or encrypts the message.
The value of this xfield should be one of the following symbols:
sign Sign the message
sign-query Query whether to sign the message
encrypt Encrypt the message
encrypt-query Query whether to encrypt the message
If the xfield is absent use `bbdb-pgp-default'.
See also info node `(message)security'."
:type '(symbol :tag "BBDB xfield")
:group 'bbdb-utilities-pgp)
(defcustom bbdb-pgp-default nil
"Default action when sending a message and the recipients are not in BBDB.
This should be one of the following symbols:
nil Do nothing
sign Sign the message
sign-query Query whether to sign the message
encrypt Encrypt the message
encrypt-query Query whether to encrypt the message
See info node `(message)security'."
:type '(choice
(const :tag "Do Nothing" nil)
(const :tag "Encrypt" encrypt)
(const :tag "Query encryption" encrypt-query)
(const :tag "Sign" sign)
(const :tag "Query signing" sign-query))
:group 'bbdb-utilities-pgp)
(defcustom bbdb-pgp-ranked-actions
'(encrypt-query sign-query encrypt sign)
"Ranked list of actions when sending a message.
If a message has multiple recipients such that their BBDB records specify
different actions for this message, `bbdb-pgp' will perform the action
which appears first in `bbdb-pgp-ranked-actions'.
This list should include the following four symbols:
sign Sign the message
sign-query Query whether to sign the message
encrypt Encrypt the message
encrypt-query Query whether to encrypt the message."
:type '(repeat (symbol :tag "Action"))
:group 'bbdb-utilities-pgp)
(defcustom bbdb-pgp-headers '("To" "Cc")
"Message headers to look at."
:type '(repeat (string :tag "Message header"))
:group 'bbdb-utilities-pgp)
(defcustom bbdb-pgp-method 'pgpmime
"Method for signing and encrypting messages.
It should be one of the keys of `bbdb-pgp-method-alist'.
The default methods include
pgp Add MML tags for PGP format
pgpauto Add MML tags for PGP-auto format
pgpmime Add MML tags for PGP/MIME
smime Add MML tags for S/MIME
See info node `(message)security'."
:type '(choice
(const :tag "MML PGP" pgp)
(const :tag "MML PGP-auto" pgpauto)
(const :tag "MML PGP/MIME" pgpmime)
(const :tag "MML S/MIME" smime)
(symbol :tag "Custom"))
:group 'bbdb-utilities-pgp)
(defcustom bbdb-pgp-method-alist
'((pgp mml-secure-message-sign-pgp
mml-secure-message-encrypt-pgp)
(pgpmime mml-secure-message-sign-pgpmime
mml-secure-message-encrypt-pgpmime)
(smime mml-secure-message-sign-smime
mml-secure-message-encrypt-smime)
(pgpauto mml-secure-message-sign-pgpauto
mml-secure-message-encrypt-pgpauto))
"Alist of methods for signing and encrypting a message with `bbdb-pgp'.
Each method is a list (KEY SIGN ENCRYPT).
The symbol KEY identifies the method. The function SIGN signs the message;
the function ENCRYPT encrypts it. These functions take no arguments.
The default methods include
pgp Add MML tags for PGP format
pgpauto Add MML tags for PGP-auto format
pgpmime Add MML tags for PGP/MIME
smime Add MML tags for S/MIME
See info node `(message)security'."
:type '(repeat (list (symbol :tag "Key")
(symbol :tag "Sign method")
(symbol :tag "Encrypt method")))
:group 'bbdb-utilities-pgp)
;;;###autoload
(defun bbdb-read-xfield-pgp-mail (&optional init)
"Set `bbdb-pgp-field', requiring match with `bbdb-pgp-ranked-actions'."
(bbdb-read-string "PGP action: " init
(mapcar 'list bbdb-pgp-ranked-actions) t))
;;;###autoload
(defun bbdb-pgp ()
"Add PGP MML tags to a message according to the recipients' BBDB records.
For all message recipients in `bbdb-pgp-headers', this grabs the action
in `bbdb-pgp-field' of their BBDB records. If this proposes multiple actions,
perform the action which appears first in `bbdb-pgp-ranked-actions'.
If this proposes no action at all, use `bbdb-pgp-default'.
The variable `bbdb-pgp-method' defines the method which is actually used
for signing and encrypting.
This command works with both `mail-mode' and `message-mode' to send
signed or encrypted mail.
To run this command automatically when sending a message,
use `bbdb-initialize' with arg `pgp' to add this function
to `message-send-hook' and `mail-send-hook'.
Yet see info node `(message)Signing and encryption' why you
might not want to rely for encryption on a hook function
which runs just before the message is sent, that is, you might want
to call the command `bbdb-pgp' manually, then call `mml-preview'."
(interactive)
(save-excursion
(save-restriction
(widen)
(message-narrow-to-headers)
(when mail-aliases
;; (sendmail-sync-aliases) ; needed?
(expand-mail-aliases (point-min) (point-max)))
(let ((actions
(or (delq nil
(delete-dups
(mapcar
(lambda (record)
(bbdb-record-xfield-intern record bbdb-pgp-field))
(delete-dups
(apply 'nconc
(mapcar
(lambda (address)
(bbdb-message-search (car address)
(cadr address)))
(bbdb-extract-address-components
(mapconcat
(lambda (header)
(mail-fetch-field header nil t))
bbdb-pgp-headers ", ")
t)))))))
(and bbdb-pgp-default
(list bbdb-pgp-default)))))
(when actions
(widen) ; after analyzing the headers
(let ((ranked-actions bbdb-pgp-ranked-actions)
action)
(while ranked-actions
(if (memq (setq action (pop ranked-actions)) actions)
(cond ((or (eq action 'sign)
(and (eq action 'sign-query)
(y-or-n-p "Sign message? ")))
(funcall (nth 1 (assq bbdb-pgp-method
bbdb-pgp-method-alist)))
(setq ranked-actions nil))
((or (eq action 'encrypt)
(and (eq action 'encrypt-query)
(y-or-n-p "Encrypt message? ")))
(funcall (nth 2 (assq bbdb-pgp-method
bbdb-pgp-method-alist)))
(setq ranked-actions nil)))))))))))
(provide 'bbdb-pgp)
;;; bbdb-pgp.el ends here

62
lisp/bbdb/bbdb-rmail.el Normal file
View file

@ -0,0 +1,62 @@
;;; bbdb-rmail.el --- BBDB interface to Rmail -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This file contains the BBDB interface to Rmail.
;;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(require 'bbdb-com)
(require 'bbdb-mua)
(require 'rmail)
(require 'rmailsum)
(require 'mailheader)
(defun bbdb/rmail-new-flag ()
"Returns t if the current message in buffer BUF is new."
(rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),"))
(defun bbdb/rmail-header (header)
"Pull HEADER out of Rmail header."
(with-current-buffer rmail-buffer
(if (fboundp 'rmail-get-header) ; Emacs 23
(rmail-get-header header)
(save-restriction
(with-no-warnings (rmail-narrow-to-non-pruned-header))
(mail-header (intern-soft (downcase header))
(mail-header-extract))))))
;;;###autoload
(defun bbdb-insinuate-rmail ()
"Hook BBDB into RMAIL.
Do not call this in your init file. Use `bbdb-initialize'."
;; Do we need keybindings for more commands? Suggestions welcome.
;; (define-key rmail-mode-map ":" 'bbdb-mua-display-records)
;; (define-key rmail-mode-map "'" 'bbdb-mua-display-recipients)
(define-key rmail-mode-map ":" 'bbdb-mua-display-sender)
(define-key rmail-mode-map ";" 'bbdb-mua-edit-field-sender)
;; (define-key rmail-mode-map ";" 'bbdb-mua-edit-field-recipients)
(define-key rmail-summary-mode-map ":" 'bbdb-mua-display-sender)
(define-key rmail-summary-mode-map ";" 'bbdb-mua-edit-field-sender))
(provide 'bbdb-rmail)
;;; bbdb-rmail.el ends here

488
lisp/bbdb/bbdb-snarf.el Normal file
View file

@ -0,0 +1,488 @@
;;; bbdb-snarf.el --- convert free-form text to BBDB records -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; The commands `bbdb-snarf', `bbdb-snarf-yank' and `bbdb-snarf-paragraph'
;; create BBDB records by picking the name, addresses, phones, etc.
;; out of a (buffer) string. Things are recognized by context (e.g., URLs
;; start with http:// or www.). See `bbdb-snarf-rule-alist' for details.
;;
;; The rule `eu' should work out of the box for many continental
;; European countries. It can be further customized by defining
;; a suitable postcode regexp passed to `bbdb-snarf-address-eu'.
;; `mail' is a simple rule that can pick a single mail address from,
;; say, a long list of mail addresses in a message.
;;
;; RW: `bbdb-snarf' is an interesting proof of concept. Yet I find
;; its snarfing algorithms often too simplistic to be useful in real life.
;; How can this possibly be improved? Suggestions welcome.
;;; Code:
(require 'bbdb-com)
(defcustom bbdb-snarf-rule-alist
'((us bbdb-snarf-surrounding-space
bbdb-snarf-phone-nanp
bbdb-snarf-url
bbdb-snarf-mail
bbdb-snarf-empty-lines
bbdb-snarf-name
bbdb-snarf-address-us
bbdb-snarf-empty-lines
bbdb-snarf-notes
bbdb-snarf-name-mail) ; currently useless
(eu bbdb-snarf-surrounding-space
bbdb-snarf-phone-eu
bbdb-snarf-url
bbdb-snarf-mail
bbdb-snarf-empty-lines
bbdb-snarf-name
bbdb-snarf-address-eu
bbdb-snarf-empty-lines
bbdb-snarf-notes
bbdb-snarf-name-mail) ; currently useless
(mail bbdb-snarf-mail-address))
"Alist of rules for snarfing.
Each rule is of the form (KEY FUNCTION FUNCTION ...).
The symbol KEY identifies the rule, see also `bbdb-snarf-rule-default'.
Snarfing is a cumulative process. The text is copied to a temporary
snarf buffer that becomes current during snarfing.
Each FUNCTION is called with one arg, the RECORD we are snarfing,
and with point at the beginning of the snarf buffer. FUNCTION should populate
the fields of RECORD. It may delete the part of the snarf buffer
that it has processed so that the remaining FUNCTIONs operate only
on those parts that were not yet snarfed. The order of the FUNCTION calls
in a rule is then crucial.
Unlike other parts of BBDB, FUNCTIONs need not update the cache and
hash table for RECORD which is done at the end by `bbdb-snarf'."
:group 'bbdb-utilities-snarf
:type '(repeat (cons (symbol :tag "Key")
(repeat (function :tag "Snarf function")))))
(defcustom bbdb-snarf-rule-default 'us
"Default rule for snarfing."
:group 'bbdb-utilities-snarf
:type 'symbol)
(defcustom bbdb-snarf-name-regexp
"^[ \t'\"]*\\([- .,[:word:]]*[[:word:]]\\)"
"Regexp matching a name. Case is ignored.
The first subexpression becomes the name."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-mail-regexp
(concat "\\(?:\\(?:mailto:\\|e?mail:?\\)[ \t]*\\)?"
"<?\\([^ \t\n<]+@[^ \t\n>]+\\)>?")
"Regexp matching a mail address. Case is ignored.
The first subexpression becomes the mail address."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-phone-nanp-regexp
(concat "\\(?:phone:?[ \t]*\\)?"
"\\(\\(?:([2-9][0-9][0-9])[-. ]?\\|[2-9][0-9][0-9][-. ]\\)?"
"[0-9][0-9][0-9][-. ][0-9][0-9][0-9][0-9]"
"\\(?: *\\(?:x\\|ext\\.?\\) *[0-9]+\\)?\\)")
"Regexp matching a NANP phone number. Case is ignored.
NANP is the North American Numbering Plan used in North and Central America.
The first subexpression becomes the phone number."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-phone-eu-regexp
(concat "\\(?:phone?:?[ \t]*\\)?"
"\\(\\(?:\\+[1-9]\\|(\\)[-0-9()\s]+\\)")
"Regexp matching a European phone number.
The first subexpression becomes the phone number."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-postcode-us-regexp
;; US postcode appears at end of line
(concat "\\(\\<[0-9][0-9][0-9][0-9][0-9]"
"\\(-[0-9][0-9][0-9][0-9]\\)?"
"\\>\\)$")
"Regexp matching US postcodes.
The first subexpression becomes the postcode."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-address-us-country nil
"Country to use for US addresses. If nil leave country blank."
:group 'bbdb-utilities-snarf
:type '(choice (const :tag "Leave blank" nil)
(string :tag "Country")))
(defcustom bbdb-snarf-postcode-eu-regexp
"^\\([0-9][0-9][0-9][0-9][0-9]?\\)" ; four or five digits
"Regexp matching many European postcodes.
`bbdb-snarf-address-eu' assumes that the address appears at the beginning
of a line followed by the name of the city."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defcustom bbdb-snarf-address-eu-country nil
"Country to use for EU addresses. If nil leave country blank."
:group 'bbdb-utilities-snarf
:type '(choice (const :tag "Leave blank" nil)
(string :tag "Country")))
(defcustom bbdb-snarf-default-label-alist
'((phone . "work") (address . "work"))
"Default labels for snarfing.
This is an alist where each element is a cons pair (FIELD . LABEL).
The symbol FIELD denotes a record field like `phone' or `address'.
The string LABEL denotes the default label for FIELD."
:group 'bbdb-utilities-snarf
:type '(repeat (cons (symbol :tag "Field")
(string :tag "Label"))))
(defcustom bbdb-snarf-url 'url
"What xfield BBDB should use for URLs, or nil to not snarf URLs."
:group 'bbdb-utilities-snarf
:type 'symbol)
(defcustom bbdb-snarf-url-regexp "\\(\\(?:http://\\|www\\.\\)[^ \t\n]+\\)"
"Regexp matching a URL. Case is ignored.
The first subexpression becomes the URL."
:group 'bbdb-utilities-snarf
:type 'regexp)
(defun bbdb-snarf-surrounding-space (_record)
"Discard beginning and trailing space when snarfing RECORD."
(while (re-search-forward "^[ \t]+" nil t)
(replace-match ""))
(goto-char (point-min))
(while (re-search-forward "\\s-+$" nil t)
(replace-match "")))
(defun bbdb-snarf-empty-lines (_record)
"Discard empty lines when snarfing RECORD."
(while (re-search-forward "^[ \t]*\n" nil t)
(replace-match "")))
(defun bbdb-snarf-name (record)
"Snarf name for RECORD."
(if (and (not (bbdb-record-lastname record))
(let ((case-fold-search t))
(re-search-forward bbdb-snarf-name-regexp nil t)))
(let ((name (match-string 1)))
(replace-match "")
(setq name (bbdb-divide-name name))
(bbdb-record-set-firstname record (car name))
(bbdb-record-set-lastname record (cdr name)))))
(defun bbdb-snarf-name-mail (record)
"Snarf name from mail address for RECORD."
;; Fixme: This is currently useless because `bbdb-snarf-mail-regexp'
;; cannot handle names in RFC 5322-like addresses "John Smith <foo@bar.com>".
(let ((name (bbdb-record-lastname record)))
(when (and (not name)
(bbdb-record-mail record)
(setq name (car (bbdb-extract-address-components
(car (bbdb-record-mail record)))))
(setq name (bbdb-divide-name name)))
(bbdb-record-set-firstname record (car name))
(bbdb-record-set-lastname record (cadr name)))))
(defun bbdb-snarf-mail-address (record)
"Snarf name and mail address for RECORD."
;; The voodoo of `mail-extract-address-components' makes
;; the following quite powerful. If this function is used as part of
;; a more complex rule, the buffer should be narrowed appropriately.
(let* ((data (bbdb-extract-address-components (buffer-string)))
(name (and (car data) (bbdb-divide-name (car data)))))
(bbdb-record-set-firstname record (car name))
(bbdb-record-set-lastname record (cdr name))
(bbdb-record-set-mail record (list (cadr data)))
(delete-region (point-min) (point-max))))
(defun bbdb-snarf-mail (record)
"Snarf mail addresses for RECORD.
This uses the first subexpresion of `bbdb-snarf-mail-regexp'."
(let ((case-fold-search t) mails)
(while (re-search-forward bbdb-snarf-mail-regexp nil t)
(push (match-string 1) mails)
(replace-match ""))
(bbdb-record-set-mail record (nconc (bbdb-record-mail record) mails))))
(defun bbdb-snarf-label (field)
"Extract the label before point, or return default label for FIELD."
(save-match-data
(if (looking-back "\\(?:^\\|[,:]\\)\\([^\n,:]+\\):[ \t]*"
(line-beginning-position))
(prog1 (match-string 1)
(delete-region (match-beginning 1) (match-end 0)))
(cdr (assq field bbdb-snarf-default-label-alist)))))
(defun bbdb-snarf-phone-nanp (record)
"Snarf NANP phone numbers for RECORD.
NANP is the North American Numbering Plan used in North and Central America.
This uses the first subexpresion of `bbdb-snarf-phone-nanp-regexp'."
(let ((case-fold-search t) phones)
(while (re-search-forward bbdb-snarf-phone-nanp-regexp nil t)
(goto-char (match-beginning 0))
(if (save-match-data
(looking-back "[0-9A-Z]" nil)) ;; not really an NANP phone number
(goto-char (match-end 0))
(push (vconcat (list (bbdb-snarf-label 'phone))
(save-match-data
(bbdb-parse-phone (match-string 1))))
phones)
(replace-match "")))
(bbdb-record-set-phone record (nconc (bbdb-record-phone record)
(nreverse phones)))))
(defun bbdb-snarf-phone-eu (record &optional phone-regexp)
"Snarf European phone numbers for RECORD.
PHONE-REGEXP is the regexp to match a phone number.
It defaults to `bbdb-snarf-phone-eu-regexp'."
(let ((case-fold-search t) phones)
(while (re-search-forward (or phone-regexp
bbdb-snarf-phone-eu-regexp) nil t)
(goto-char (match-beginning 0))
(push (vector (bbdb-snarf-label 'phone)
(match-string 1))
phones)
(replace-match ""))
(bbdb-record-set-phone record (nconc (bbdb-record-phone record)
(nreverse phones)))))
(defun bbdb-snarf-streets (address)
"Snarf streets for ADDRESS. This assumes a narrowed region."
(bbdb-address-set-streets address (bbdb-split "\n" (buffer-string)))
(delete-region (point-min) (point-max)))
(defun bbdb-snarf-address-us (record)
"Snarf a US address for RECORD."
(let ((address (make-vector bbdb-address-length nil)))
(cond ((re-search-forward bbdb-snarf-postcode-us-regexp nil t)
;; Streets, City, State Postcode
(save-restriction
(narrow-to-region (point-min) (match-end 0))
;; Postcode
(goto-char (match-beginning 0))
(bbdb-address-set-postcode address
(bbdb-parse-postcode (match-string 1)))
;; State
(skip-chars-backward " \t")
(let ((pos (point)))
(skip-chars-backward "^ \t,")
(bbdb-address-set-state address (buffer-substring (point) pos)))
;; City
(skip-chars-backward " \t,")
(let ((pos (point)))
(beginning-of-line)
(bbdb-address-set-city address (buffer-substring (point) pos)))
;; Toss it
(forward-char -1)
(delete-region (point) (point-max))
;; Streets
(goto-char (point-min))
(bbdb-snarf-streets address)))
;; Try for just Streets, City, State
((let (case-fold-search)
(re-search-forward "^\\(.*\\), \\([A-Z][A-Za-z]\\)$" nil t))
(bbdb-address-set-city address (match-string 1))
(bbdb-address-set-state address (match-string 2))
(replace-match "")
(save-restriction
(narrow-to-region (point-min) (match-beginning 0))
(goto-char (point-min))
(bbdb-snarf-streets address))))
(when (bbdb-address-city address)
(if bbdb-snarf-address-us-country
(bbdb-address-set-country address bbdb-snarf-address-us-country))
;; Fixme: There are no labels anymore. `bbdb-snarf-streets' snarfed
;; everything that was left!
(bbdb-address-set-label address (bbdb-snarf-label 'address))
(bbdb-record-set-address record
(nconc (bbdb-record-address record)
(list address))))))
(defun bbdb-snarf-address-eu (record &optional postcode-regexp country)
"Snarf a European address for RECORD.
POSTCODE-REGEXP is a regexp matching the postcode assumed to appear
at the beginning of a line followed by the name of the city. This format
is used in many continental European countries.
POSTCODE-REGEXP defaults to `bbdb-snarf-postcode-eu-regexp'.
COUNTRY is the country to use. It defaults to `bbdb-snarf-address-eu-country'."
(when (re-search-forward (or postcode-regexp
bbdb-snarf-postcode-eu-regexp) nil t)
(let ((address (make-vector bbdb-address-length nil)))
(save-restriction
(goto-char (match-end 0))
(narrow-to-region (point-min) (line-end-position))
;; Postcode
(bbdb-address-set-postcode address (match-string 1))
;; City
(skip-chars-forward " \t")
(bbdb-address-set-city address (buffer-substring (point) (point-max)))
;; Toss it
(delete-region (match-beginning 0) (point-max))
;; Streets
(goto-char (point-min))
(bbdb-snarf-streets address))
(unless country (setq country bbdb-snarf-address-eu-country))
(if country (bbdb-address-set-country address country))
(bbdb-address-set-label address (bbdb-snarf-label 'address))
(bbdb-record-set-address record
(nconc (bbdb-record-address record)
(list address))))))
(defun bbdb-snarf-url (record)
"Snarf URL for RECORD.
This uses the first subexpresion of `bbdb-snarf-url-regexp'."
(when (and bbdb-snarf-url
(let ((case-fold-search t))
(re-search-forward bbdb-snarf-url-regexp nil t)))
(bbdb-record-set-xfields
record
(nconc (bbdb-record-xfields record)
(list (cons bbdb-snarf-url (match-string 1)))))
(replace-match "")))
(defun bbdb-snarf-notes (record)
"Snarf notes for RECORD."
(when (/= (point-min) (point-max))
(bbdb-record-set-xfields
record
(nconc (bbdb-record-xfields record)
(list (cons bbdb-default-xfield (buffer-string)))))
(erase-buffer)))
(defsubst bbdb-snarf-rule-interactive ()
"Read snarf rule interactively."
(intern
(completing-read
(format "Rule: (default `%s') " bbdb-snarf-rule-default)
bbdb-snarf-rule-alist nil t nil nil
(symbol-name bbdb-snarf-rule-default))))
;;;###autoload
(defun bbdb-snarf-paragraph (pos &optional rule)
"Snarf BBDB record from paragraph around position POS using RULE.
The paragraph is the one that contains POS or follows POS.
Interactively POS is the position of point.
RULE defaults to `bbdb-snarf-rule-default'.
See `bbdb-snarf-rule-alist' for details."
(interactive (list (point) (bbdb-snarf-rule-interactive)))
(bbdb-snarf (save-excursion
(goto-char pos)
;; similar to `mark-paragraph'
(let ((end (progn (forward-paragraph 1) (point))))
(buffer-substring-no-properties
(progn (backward-paragraph 1) (point))
end)))
rule))
;;;###autoload
(defun bbdb-snarf-yank (&optional rule)
"Snarf a BBDB record from latest kill using RULE.
The latest kill may also be a window system selection, see `current-kill'.
RULE defaults to `bbdb-snarf-rule-default'.
See `bbdb-snarf-rule-alist' for details."
(interactive (list (bbdb-snarf-rule-interactive)))
(bbdb-snarf (current-kill 0) rule))
;;;###autoload
(defun bbdb-snarf (string &optional rule)
"Snarf a BBDB record in STRING using RULE. Display and return this record.
Interactively, STRING is the current region.
RULE defaults to `bbdb-snarf-rule-default'.
See `bbdb-snarf-rule-alist' for details."
(interactive
(list (buffer-substring-no-properties (region-beginning) (region-end))
(bbdb-snarf-rule-interactive)))
(bbdb-editable)
(let ((record (bbdb-empty-record)))
(with-current-buffer (get-buffer-create " *BBDB Snarf*")
(erase-buffer)
(insert (substring-no-properties string))
(mapc (lambda (fun)
(goto-char (point-min))
(funcall fun record))
(cdr (assq (or rule bbdb-snarf-rule-default)
bbdb-snarf-rule-alist))))
(let ((old-record (car (bbdb-message-search
(bbdb-concat 'name-first-last
(bbdb-record-firstname record)
(bbdb-record-lastname record))
(car (bbdb-record-mail record))))))
;; Install RECORD after searching for OLD-RECORD
(bbdb-change-record record)
(if old-record (bbdb-merge-records old-record record)))
(bbdb-display-records (list record))
record))
;; Some test cases
;;
;; US:
;;
;; another test person
;; 1234 Gridley St.
;; Los Angeles, CA 91342
;; 555-1212
;; test@person.net
;; http://www.foo.bar/
;; other stuff about this person
;;
;; test person
;; 1234 Gridley St.
;; St. Los Angeles, CA 91342-1234
;; 555-1212
;; <test@person.net>
;;
;; x test person
;; 1234 Gridley St.
;; Los Angeles, California 91342-1234
;; work: 555-1212
;; home: 555-1213
;; test@person.net
;;
;; y test person
;; 1234 Gridley St.
;; Los Angeles, CA
;; 555-1212
;; test@person.net
;;
;; z test person
;; 555-1212
;; test@person.net
;;
;; EU:
;;
;; Maja Musterfrau
;; Strasse 15
;; 12345 Ort
;; +49 12345
;; phon: (110) 123 456
;; mobile: (123) 456 789
;; xxx.xxx@xxxx.xxx
;; http://www.xxx.xx
;; notes bla bla bla
(provide 'bbdb-snarf)
;;; bbdb-snarf.el ends here

570
lisp/bbdb/bbdb-tex.el Normal file
View file

@ -0,0 +1,570 @@
;;; bbdb-tex.el --- feed BBDB into LaTeX -*- lexical-binding: t -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; Authors: Boris Goldowsky <boris@cs.rochester.edu>
;; Dirk Grunwald <grunwald@cs.colorado.edu>
;; Luigi Semenzato <luigi@paris.cs.berkeley.edu>
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file lets you feed BBDB into LaTeX.
;; See the BBDB info manual for documentation.
;;
;; In the *BBDB* buffer, type M-x `bbdb-tex' to convert the listing
;; to LaTeX format.
;;
;; TeX macros appearing in the output:
;; \name{first}{last}
;; \organization{foo bar}
;; \affix{foo bar}
;; \aka{foo bar}
;; \phone{key}{123 456 7890}
;; \address{key}{foo bar}
;; \mail{foo@bar.com}{Smith <foo@bar.com>}
;; \xfield{key}{value}
;; Each macro may appear multiple times.
;;
;; The detailed grammar of the output is defined in `bbdb-tex-alist'.
;; The output starts with a prolog where you can specify LaTeX packages
;; and other customizations in the usual way. The above macros should get
;; defined, too. By default, this happens in the style file bbdb.sty that
;; is shipped with BBDB.
;;
;; The body of the output contains the BBDB records. Usually, the records
;; are placed inside some "bbdb" environment. You can customize which fields
;; of each record should appear in the listing and in which order.
;; Also, you can put separators between individual fields. A separator macro
;; can also separate records when the first character of the last name differs
;; from the first character of the last name of the previous record.
;; The listing ends with an epilog.
;; A few notes on "advanced usage" of `bbdb-tex':
;;
;; It should be possible to use `bbdb-tex' with all the bells and whistles
;; of LaTeX by loading the appropriate LaTeX style files and packages or
;; embedding the output of `bbdb-tex' into more complex LaTeX documents.
;; For this you can customize the rules in `bbdb-tex-alist' and use
;; customized style files for interpreting the TeX macros used by `bbdb-tex'.
;;
;; Generally, lisp customizations for `bbdb-tex' are intended to provide control
;; of *what* appears in the TeX listing. But there are no lisp customization
;; options to control the actual layout that should be handled by LaTeX.
;; BBDB is shipped with one basic LaTeX style file bbdb.sty to handle
;; the TeX macros listed above. You should customize this LaTeX style file
;; to match your taste and / or your needs. Note also that `bbdb-tex-alist'
;; allows you to specify an arbitrary number of rules that may use different
;; style files for the above TeX macros.
;; Generally, it will be advantageous to make all relevant style files
;; and packages known to LaTeX by putting them in the appropriate directories
;; of your TeX installation. Likely, the user variable `bbdb-tex-path'
;; should not be used in such advanced cases. The main purpose of the
;; inlining mechanism provided via `bbdb-tex-path' is that we can ship
;; and install BBDB without worrying about the tricky question where to
;; (auto-) install the basic style file bbdb.sty shipped with BBDB so that
;; TeX finds it. Most often, it will be best to manually install even bbdb.sty
;; in a directory where TeX finds it and bind `bbdb-tex-path' to t to fully
;; suppress the inlining.
;;
;; Before generating the TeX output, the field values of a record are massaged
;; by `bbdb-tex-field' that passes these values by default to `bbdb-tex-replace',
;; see also `bbdb-tex-replace-list'. Instead the user may also define functions
;; `bbdb-tex-output-...' that take precedence, see `bbdb-tex-field'.
;;
;; `bbdb-tex' understands one new BBDB xfield: tex-name, see also
;; `bbdb-tex-name'. If this xfield is defined for a record,
;; this will be used for the TeXed listing instead of the name field
;; of that record. The value of the xfield tex-name is used verbatim,
;; it does not see `bbdb-tex-field' and `bbdb-tex-replace-list'.
;;
;;
;; This program was adapted for BBDB by Boris Goldowsky
;; <boris@cs.rochester.edu> and Dirk Grunwald
;; <grunwald@cs.colorado.edu> using a TeX format designed by Luigi
;; Semenzato <luigi@paris.cs.berkeley.edu>.
;; We are also grateful to numerous people on the bbdb-info
;; mailing list for suggestions and bug reports.
;;; Code:
(require 'bbdb)
(require 'bbdb-com)
;;; Variables:
(defcustom bbdb-tex-name 'tex-name
"Xfield holding the name in TeX format.
The string in this field gets split into first and last name
using `bbdb-separator-alist'. The separator defaults to \"#\"."
:group 'bbdb-utilities-tex
:type '(symbol :tag "Xfield"))
(defcustom bbdb-tex-alist
`((multi-line
(demand (or address phone))
(prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
"\\usepackage{multicol}\n"
"\\begin{document}\n\\begin{multicols}{2}"))
(record "\\begin{bbdbrecord}" name organization ; affix aka
(address t) (phone t) (mail t)
(xfields t nil
(omit ,bbdb-tex-name mail-alias creation-date timestamp))
"\\end{bbdbrecord}\n")
(separator "\\bbdbseparator{%s}\n")
(epilog ,(concat "\\noindent\\hrulefill\\\\\nPrinted \\today\n"
"\\end{multicols}\n\\end{document}"))
(options (bbdb-tex-linebreak "\\\\\\\\\n")
(bbdb-tex-address-layout 2)))
(one-line
(demand phone)
(prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
"\\begin{document}\n\\begin{bbdb}{llllll}"))
(record name "&" (organization 1) "&" (phone 2 "&") "&" (mail 1)
"&" (address 1) "\\\\")
(separator "\\bbdbseparator{%s}")
(epilog "\\end{bbdb}\n\\end{document}")
(options (bbdb-tex-linebreak ", ")
(bbdb-tex-address-layout 3)))
(phone
(demand phone)
(prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
"\\begin{document}\n\\begin{bbdb}{ll}"))
(record name "&" (phone 2 "&") "\\\\")
(separator "\\bbdbseparator{%s}")
(epilog "\\end{bbdb}\n\\end{document}")
(options (bbdb-tex-linebreak ", ")
(bbdb-tex-address-layout 3)))
(example ; another rule with more examples
(demand (or address phone))
(prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
"\\usepackage{multicol}\n"
"\\begin{document}\n\\begin{multicols}{2}"))
(record "\\begin{bbdbrecord}" name organization
(address 1 nil (omit "work"))
(phone 2 nil (admit "home" "cell"))
(mail t)
(birthday t)
(xfields t nil
(omit ,bbdb-tex-name mail-alias creation-date timestamp))
"\\end{bbdbrecord}\n")
(separator "\\bbdbseparator{%s}\n")
(epilog ,(concat "\\noindent\\hrulefill\\\\\nPrinted \\today\n"
"\\end{multicols}\n\\end{document}"))
(options (bbdb-tex-linebreak "\\\\\\\\\n")
(bbdb-tex-address-layout 2))))
"Alist of rules for passing BBDB to LaTeX.
Each rule has the form (RULE LIST1 LIST2 ...).
The symbol RULE identifies the rule.
The remainder are lists LIST that should have one of these forms:
(demand FORM)
Here FORM is a lisp expression. A record will be TeXed only
if evaluating FORM yields a non-nil value for this record.
When FORM is evaluated, the symbols name, affix, organization, mail,
phone, address, and xfields are set to the corresponding values
of this record; these symbols are nil if the respective field
does not exist for this record.
(prolog STRING)
The string STRING is inserted at the beginning of the buffer.
If STRING contains the substring \"\\usepackage{foo}\" and
a file \"foo.sty\" exists within `bbdb-tex-path', replace
\"\\usepackage{foo}\" with the content of the file \"foo.sty\",
surrounded by \"\\makeatletter\" and \"\\makeatother\".
Note: This fails with more sophisticated LaTeX style files
using, e.g., optional arguments for the \"\\usepackage\" macro.
(record ELT1 ELT2 ...)
Here ELT may be one of the following:
IF ELT is name, this expands to \"\\name{first}{last}\"
If ELT is affix, organization, or aka, ELT expands to \"\\ELT{value}\".
Here the elements of ELT are concatenated to get one value.
If ELT is the key of an xfield, ELT expands to \"\\xfield{ELT}{value}\".
If ELT is a string, this is inserted \"as is\" in the TeX buffer.
ELT may also be a loop (FLD COUNT [SEPARATOR] [OPT...])
looping over the values of FLD.
If FLD is mail, this expands to \"\\mail{short}{long}\",
such as \"\\mail{foo@bar.com}{Smith <foo@bar.com>}\",
If FLD is phone, this expands to \"\\phone{key}{number}\"
If FLD is address, this expands to \"\\address{key}{value}\".
If FLD is xfields, this expands to \"\\xfield{key}{value}\".
If FLD is the key of an xfield, split the value of FLD
using `bbdb-separator-alist' to generate a list of values,
which then expand to \"\\xfield{FLD}{value}\".
If COUNT is a number, process at most COUNT values of FLD.
IF COUNT is t, process all values of FLD.
If SEPARATOR is non-nil, it is a string that is inserted between
the values of FLD. Insert COUNT - 1 instances of SEPARATOR,
even if there are fewer values of FLD.
If FLD is mail, phone, address, or xfields,
OPT may be a list (admit KEY ...) or (omit KEY ...).
Then a value is admitted or omitted if its key KEY is listed here.
(separator STRING)
When the first letter of the records' sortkey increases compared with
the previous record in the TeX listing, the new letter is formatted
using the format string STRING to generate a separator macro.
(epilog STRING)
The string STRING is inserted at the end of the buffer."
:group 'bbdb-utilities-tex)
(defcustom bbdb-tex-rule-default 'multi-line
"Default rule for BBDB tex.
This symbol should be a key in `bbdb-tex-alist'."
:group 'bbdb-utilities-tex
:type '(symbol :tag "rule"))
;; FIXME
;; (defcustom bbdb-tex-empty-fields nil
;; "If non-nil generate TeX output even for empty fields."
;; :group 'bbdb-utilities-tex)
(defcustom bbdb-tex-replace-list
'(("[#$%&_]" . "\\\\\\&")
("<" . "\\\\textless ")
(">" . "\\\\textgreater ")
("~" . "\\\\textasciitilde ")
("{" . "\\\\textbraceleft ")
("}" . "\\\\textbraceright "))
"Replacement list for TeX's special characters.
Each element is of the form (REGEXP . REPLACE)."
:group 'bbdb-utilities-tex
:type '(repeat (cons regexp string)))
(defcustom bbdb-tex-linebreak "\\\\\\\\\n"
"Replacement for linebreaks."
:group 'bbdb-utilities-tex
:type 'string)
(defcustom bbdb-tex-address-format-list bbdb-address-format-list
"List of address formatting rules for `bbdb-tex'.
Each element may take the same values as in `bbdb-address-format-list'.
The elements EDIT of `bbdb-address-format-list' are ignored."
:group 'bbdb-utilities-tex
:type '(repeat (list (choice (const :tag "Default" t)
(function :tag "Function")
(repeat (string)))
(choice (string)
(function :tag "Function"))
(choice (string)
(function :tag "Function"))
(choice (string)
(function :tag "Function")))))
(defcustom bbdb-tex-address-layout 2
"Address layout according to `bbdb-tex-address-format-list'.
2 is multi-line layout, 3 is one-line layout."
:group 'bbdb-utilities-tex)
(defcustom bbdb-tex-file "~/bbdb.tex"
"Default file name for TeXing BBDB."
:group 'bbdb-utilities-tex
:type 'file)
(defcustom bbdb-tex-path
(let ((d (if load-file-name
(expand-file-name "tex/" (file-name-directory load-file-name))
(let ((f (locate-file "tex/bbdb.sty" load-path)))
(if f (file-name-directory f))))))
(if d (list d)))
"List of directories with the BBDB TeX files.
If this is t assume that these files reside in directories
that are part of the regular TeX search path"
:group 'bbdb-utilities-tex
:type '(choice (const :tag "Files in TeX path" t)
(repeat (directory :tag "Directory"))))
;;; Internal variables
(defvar bbdb-tex-rule-last bbdb-tex-rule-default
"Last rule used for TeXing BBDB.")
(defvar bbdb-tex-file-last bbdb-tex-file
"Last used TeX file")
;;; Functions:
;; While we use `bbdb-tex-replace' only once in `bbdb-tex-field',
;; we keep it as a separate function so that it can also be used
;; inside user-defined functions `bbdb-tex-output-...'.
(defun bbdb-tex-replace (string)
"Apply replacement rules `bbdb-tex-replace-list' to STRING.
Also, replace linebreaks by `bbdb-tex-linebreak'."
(if (not string)
""
(dolist (elt bbdb-tex-replace-list)
(setq string (replace-regexp-in-string (car elt) (cdr elt) string)))
(replace-regexp-in-string "\n" bbdb-tex-linebreak string)))
(defun bbdb-tex-field (field str)
"Massage string STR for LaTeX.
By default, STR is passed to `bbdb-tex-replace'.
The user may also define a function `bbdb-tex-output-FIELD'
that takes precedence."
(let ((fun (intern-soft (format "bbdb-tex-output-%s" field))))
(if fun
(funcall fun str)
(bbdb-tex-replace str))))
(defun bbdb-tex-list (list rule fun)
"Use function FUN to generate output for LIST according to RULE.
LIST is a list of field values such as a list of addresses.
RULE is an element of a record list as in `bbdb-tex-alist'
used to select the elements of LIST that get processed by calling FUN."
(let ((admit (cdr (assq 'admit rule)))
(omit (cdr (assq 'omit rule)))
(num (if (numberp (nth 1 rule)) (nth 1 rule)))
(sep (if (nth 2 rule) (concat (nth 2 rule) "\n")))
(i -1)
new-list elt)
;; Select the relevant elements of LIST.
(cond (admit
(dolist (l list)
(if (member (elt l 0) admit)
(push l new-list)))
(setq new-list (nreverse new-list)))
(omit
(dolist (l list)
(unless (member (elt l 0) omit)
(push l new-list)))
(setq new-list (nreverse new-list)))
(t
(setq new-list list)))
(cond ((not num)
(insert (mapconcat fun new-list (or sep ""))))
((not sep)
(while (and (< (setq i (1+ i)) num)
(setq elt (pop new-list)))
(insert (funcall fun elt))))
(t
(while (< (setq i (1+ i)) num)
(if (setq elt (pop new-list))
(insert (funcall fun elt)))
(if (< (1+ i) num)
(insert sep)))))))
;;;###autoload
(defun bbdb-tex (records file rule)
"Generate FILE for TeXing RECORDS.
Interactively, use BBDB prefix \
\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
RULE should be an element of `bbdb-tex-alist'."
(interactive
(list (bbdb-do-records)
(read-file-name
(format "TeX file: (default %s) "
(abbreviate-file-name bbdb-tex-file-last))
(file-name-directory bbdb-tex-file-last)
bbdb-tex-file-last)
(intern (completing-read (format "Rule: (default %s) "
bbdb-tex-rule-last)
bbdb-tex-alist nil t
nil nil (symbol-name bbdb-tex-rule-last)))))
;; Remember our choice for `bbdb-tex-file-last'.
(setq bbdb-tex-file-last (expand-file-name file))
(find-file bbdb-tex-file-last)
(let* ((buffer-undo-list t)
(rule (assq rule bbdb-tex-alist))
(demand (nth 1 (assq 'demand rule)))
(separator (nth 1 (assq 'separator rule)))
current-letter p-symbols p-values)
(erase-buffer)
;; Options
(dolist (option (cdr (assq 'options rule)))
(push (car option) p-symbols)
(push (cadr option) p-values))
(cl-progv p-symbols p-values
;; Prolog
(let ((prolog (nth 1 (assq 'prolog rule))))
(when prolog
(insert prolog)
(when (consp bbdb-tex-path)
(goto-char (point-min))
(while (re-search-forward "\\\\usepackage[ \t\n]*{\\([^}]+\\)}" nil t)
(let ((sty (locate-file (match-string 1) bbdb-tex-path '(".sty"))))
(when sty
(replace-match (format "\n\\\\makeatletter\n%% begin %s\n%% end %s\n\\\\makeatother\n" sty sty))
(save-excursion
(forward-line -2)
(insert-file-contents sty))))))
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(insert "% end BBDB prolog\n")))
;; Process Records
(dolist (record (bbdb-record-list records))
(let* ((first-letter
(substring (bbdb-record-sortkey record) 0 1))
(firstname (bbdb-record-firstname record))
(lastname (bbdb-record-lastname record))
(name (bbdb-record-name record))
(name-lf (bbdb-record-name-lf record))
(organization (bbdb-record-organization record))
(affix (bbdb-record-affix record))
(aka (bbdb-record-aka record))
(mail (bbdb-record-mail record))
(phone (bbdb-record-phone record))
(address (bbdb-record-address record))
(xfields (bbdb-record-xfields record))
(lex-env `((firstname . ,firstname) (lastname . ,lastname)
(name . ,name) (name-lf . ,name-lf) (aka . ,aka)
(organization . ,organization) (affix . ,affix)
(mail . ,mail) (phone . ,phone)
(address . ,address) (xfields . ,xfields)))
(bbdb-address-format-list bbdb-tex-address-format-list))
;; A record is processed only if the form DEMAND
;; evaluates to a non-nil value.
(when (or (not demand)
(eval demand lex-env))
;; Separator
(if (and separator
(not (and current-letter
(equal first-letter current-letter))))
(insert (format separator (upcase first-letter)) "\n"))
(setq current-letter first-letter)
(dolist (elt (cdr (assq 'record rule)))
(cond ((stringp elt)
(insert elt "\n"))
((eq elt 'name) ; name of record
(let ((tex-name (and bbdb-tex-name
(bbdb-record-field record bbdb-tex-name)))
(fmt "\\name{%s}{%s}\n"))
(if tex-name
(let ((first-last (bbdb-split bbdb-tex-name tex-name)))
(cond ((eq 2 (length first-last))
(insert (format fmt (car first-last) (cadr first-last))))
((eq 1 (length first-last))
(insert (format fmt "" (car first-last))))
(t (error "TeX name %s cannot be split" tex-name))))
(insert (format fmt
(bbdb-tex-field 'firstname firstname)
(bbdb-tex-field 'lastname lastname))))))
;; organization, affix or aka as single string
((memq elt '(organization affix aka))
(let ((val (bbdb-record-field record elt)))
(if val
(insert (format "\\%s{%s}\n" elt
(bbdb-tex-field elt (bbdb-concat elt val)))))))
;; organization, affix or aka as list of strings
((memq (car elt) '(organization affix aka))
(bbdb-tex-list
(bbdb-record-field record (car elt))
elt
`(lambda (o)
(format "\\%s{%s}\n" ',(car elt)
(bbdb-tex-field ',(car elt) o)))))
((eq (car elt) 'mail) ; mail
(bbdb-tex-list
mail elt
(lambda (m)
(format "\\mail{%s}{%s}\n"
;; No processing of plain mail address
(nth 1 (bbdb-decompose-bbdb-address m))
(bbdb-tex-field 'mail m)))))
((eq (car elt) 'address) ; address
(bbdb-tex-list
address elt
(lambda (a)
(format "\\address{%s}{%s}\n"
(bbdb-tex-field 'address-label (bbdb-address-label a))
(bbdb-tex-field 'address (bbdb-format-address
a bbdb-tex-address-layout))))))
((eq (car elt) 'phone) ; phone
(bbdb-tex-list
phone elt
(lambda (p)
(format "\\phone{%s}{%s}\n"
(bbdb-tex-field 'phone-label (bbdb-phone-label p))
(bbdb-tex-field 'phone (bbdb-phone-string p))))))
((eq (car elt) 'xfields) ; list of xfields
(bbdb-tex-list
(bbdb-record-field record 'xfields)
elt
(lambda (x)
(format "\\xfield{%s}{%s}\n"
(bbdb-tex-field 'xfield-label (symbol-name (car x)))
(bbdb-tex-field 'xfield (cdr x))))))
((symbolp elt) ; xfield as single string
;; The value of an xfield may be a sexp instead of a string.
;; Ideally, a sexp should be formatted by `pp-to-string',
;; then printed verbatim.
(let ((val (format "%s" (bbdb-record-field record elt))))
(if val
(insert (format "\\xfield{%s}{%s}\n" elt
(bbdb-tex-field elt (bbdb-concat elt val)))))))
((consp elt) ; xfield as list of strings
(bbdb-tex-list
(bbdb-split (car elt)
(format "%s" (bbdb-record-field record (car elt))))
elt
`(lambda (x)
(format "\\xfield{%s}{%s}\n" ',(car elt)
(bbdb-tex-field ',(car elt) x)))))
(t (error "Rule `%s' undefined" elt)))))))
;; Epilog
(let ((epilog (nth 1 (assq 'epilog rule))))
(when epilog
(insert "% begin BBDB epilog\n" epilog)
(unless (bolp) (insert "\n"))))))
(setq buffer-undo-list nil)
(save-buffer))
(provide 'bbdb-tex)
;;; bbdb-tex.el ends here

53
lisp/bbdb/bbdb-wl.el Normal file
View file

@ -0,0 +1,53 @@
;;; bbdb-wl.el --- BBDB interface to Wanderlust -*- lexical-binding: t -*-
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; This file is part of the Insidious Big Brother Database (aka BBDB),
;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file contains the BBDB interface to Wl.
;; See the BBDB info manual for documentation.
;;; Code:
(require 'bbdb)
(require 'bbdb-mua)
(defvar wl-summary-mode-map)
(defvar wl-draft-mode-map)
(defvar wl-summary-buffer-elmo-folder)
(declare-function wl-summary-message-number "wl-summary")
(declare-function elmo-message-entity "elmo-msgdb")
(declare-function elmo-message-entity-field "elmo-msgdb")
(defun bbdb/wl-header (header)
(elmo-message-entity-field
(elmo-message-entity wl-summary-buffer-elmo-folder
(wl-summary-message-number))
(intern (downcase header)) 'string))
;;;###autoload
(defun bbdb-insinuate-wl ()
"Hook BBDB into Wanderlust."
(define-key wl-summary-mode-map (kbd ":") #'bbdb-mua-display-sender)
(define-key wl-summary-mode-map (kbd ";") #'bbdb-mua-edit-field-sender)
(when bbdb-complete-mail
(define-key wl-draft-mode-map (kbd "M-;") #'bbdb-complete-mail)
(define-key wl-draft-mode-map (kbd "M-<tab>") #'bbdb-complete-mail)))
(provide 'bbdb-wl)
;;; bbdb-wl.el ends here

4730
lisp/bbdb/bbdb.el Normal file
View file

File diff suppressed because it is too large Load diff

89
lisp/bbdb/tex/bbdb.sty Normal file
View file

@ -0,0 +1,89 @@
% bbdb.sty --- basic LaTeX style for TeXing BBDB
%
% Copyright (C) 2017 Roland Winkler <winkler@gnu.org>
%
% This file is part of the Insidious Big Brother Database (aka BBDB),
%
% BBDB is free software: you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation, either version 3 of the License, or
% (at your option) any later version.
%
% BBDB is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with BBDB. If not, see <http://www.gnu.org/licenses/>.
%% Commentary:
%
% This file defines a basic LaTeX style for TeXing BBDB.
\def\bbdb@name#1#2{\textbf{#2, #1}}
\def\bbdb@organization#1{#1}
\def\bbdb@affix#1{\emph{affix:} #1}
\def\bbdb@aka#1{\emph{aka:} #1}
\def\bbdb@phone#1#2{\emph{#1:} #2}
\def\bbdb@mail#1#2{\ifx\href\undefined
\texttt{#2}%
\else
\href{mailto:#1}{\texttt{#2}}%
\fi}
\def\bbdb@address#1#2{\emph{#1:} #2}
\def\bbdb@xfield#1#2{\emph{#1:} #2}
% \def\bbdb@separator#1{\hline}
\def\bbdb@separator#1{\\\hline
\multicolumn{\LT@cols}{@{}c@{}}{\hrulefill\ #1\rule{0pt}{2.2ex}\ \hrulefill}\\}
\RequirePackage{longtable}
\newenvironment{bbdb}[1]{%
\let\name\bbdb@name
\let\organization\bbdb@organization
\let\affix\bbdb@affix
\let\aka\bbdb@aka
\let\phone\bbdb@phone
\let\mail\bbdb@mail
\let\address\bbdb@address
\let\xfield\bbdb@xfield
\let\bbdbseparator\bbdb@separator
\begin{longtable}[l]{@{}#1@{}}}%
{\\ \hline \multicolumn{\LT@cols}{c}{Printed \today}\\ \hline\end{longtable}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\def\bbdbrecord@name#1#2{{\raggedright\textbf{#2, #1}\dotfill\par}}
\def\bbdbrecord@organization#1{#1\par}
\def\bbdbrecord@affix#1{\bbdbrecord@par{\emph{affix:} #1}}
\def\bbdbrecord@aka#1{\bbdbrecord@par{\emph{aka:} #1}}
\def\bbdbrecord@phone#1#2{\hspace*{\fill}\emph{#1:} #2\par}
\def\bbdbrecord@mail#1#2{\ifx\href\undefined
\texttt{#2}%
\else
\href{mailto:#1}{\texttt{#2}}%
\fi\par}
\def\bbdbrecord@par#1{{\leftskip 1em\parindent -\leftskip#1\par}}
\def\bbdbrecord@address#1#2{\bbdbrecord@par{\emph{#1:} #2}}
\def\bbdbrecord@xfield#1#2{\bbdbrecord@par{\emph{#1:} #2}}
\newenvironment{bbdbrecord}{%
\smallbreak
\parskip 0pt
\parindent 0pt
\let\name\bbdbrecord@name
\let\organization\bbdbrecord@organization
\let\affix\bbdbrecord@affix
\let\aka\bbdbrecord@aka
\let\phone\bbdbrecord@phone
\let\mail\bbdbrecord@mail
\let\address\bbdbrecord@address
\let\xfield\bbdbrecord@xfield}{\medbreak}
\newcommand*{\bbdbseparator}[1]{\vspace{3ex}\noindent
\fbox{\parbox{\dimexpr\linewidth-2\fboxrule-2\fboxsep}%
{\centering\textbf{#1}}}%
\vspace{1ex}}
% \endinput % Fails when inlining this file.