Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
1137 lines (1058 sloc) 49.1 KB
;;; bbdb-vcard.el --- vCard import/export for BBDB
;; Copyright (c) 2010 Bert Burgemeister
;; Author: Bert Burgemeister <>
;; Keywords: data calendar mail news
;; URL:
;; Version: 0.3
;; This program 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 2, or (at
;; your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; The exporter functionality is based on code from
;; bbdb-vcard-export.el by Jim Hourihan and Alex Schroeder.
;;; Commentary:
;; Purpose
;; =======
;; Import and export of vCards as defined in RFC 2425 and RFC 2426
;; to/from The Insidious Big Brother Database (BBDB).
;; Usage
;; =====
;; vCard Import
;; ------------
;; On a file, a buffer or a region containing one or more vCards, use
;; `bbdb-vcard-import-file', `bbdb-vcard-import-buffer', or
;; `bbdb-vcard-import-region' respectively to import them into BBDB.
;; Preferred input format is vCard version 3.0. Version 2.1 vCards
;; are converted to version 3.0 on import.
;; vCard Export
;; ------------
;; In buffer *BBDB*, press v to export the record under point. Press
;; * v to export all records in buffer into one vCard file. Press *
;; C-u v to export them into one file each.
;; To put one or all vCard(s) into the kill ring, press V or * V
;; respectively.
;; Exported vCards are always version 3.0. They can be re-imported
;; without data loss with one exception: North American phone numbers
;; lose their structure and are stored as flat strings.
;; There are a few customization variables grouped under `bbdb-vcard'.
;; Installation
;; ============
;; Put this file and file vcard.el into your `load-path' and add the
;; following line to your Emacs initialization file:
;; (require 'bbdb-vcard)
;; Implementation
;; ==============
;; vCard Import
;; ------------
;; For conversion of v2.1 vCards into v3.0 on import, Noah Friedman's
;; vcard.el is needed.
;; An existing BBDB record is extended by new information from a vCard
;; (a) if name and company and an email address match
;; (b) or if name and company match
;; (c) or if name and an email address match
;; (d) or if name and birthday match
;; (e) or if name and a phone number match.
;; Otherwise, a fresh BBDB record is created.
;; When `bbdb-vcard-try-merge' is set to nil, there is always a fresh
;; record created.
;; In cases (c), (d), and (e), if the vCard has ORG defined, this ORG
;; would overwrite an existing Company in BBDB.
;; Phone numbers are always imported as strings.
;; For vCard types that have more or less direct counterparts in BBDB,
;; labels and parameters are translated and structured values
;; (lastname; firstname; additional names; prefixes etc.) are
;; converted appropriately with the risk of some (hopefully
;; unessential) information loss. For labels of the vCard types ADR
;; and TEL, parameter translation is defined in
;; `bbdb-vcard-import-translation-table'.
;; If there is a REV element, it is stored in BBDB's creation-date in
;; newly created BBDB records, or discarded for existing ones. Time
;; and time zone information from REV are stored there as well if
;; there are any, but are ignored by BBDB (v2.36).
;; VCard type prefixes (A.ADR:..., B.ADR:... etc.) are stripped off
;; and discarded from the following types: N, FN, NICKNAME, ORG (first
;; occurrence), ADR, TEL, EMAIL, URL, BDAY (first occurrence), NOTE.
;; VCard types that are prefixed `X-BBDB-' are stored in BBDB without
;; the prefix.
;; VCard type X-BBDB-ANNIVERSARY may contain (previously exported)
;; newline-separated non-birthday anniversaries that are meant to be
;; read by org-mode.
;; All remaining vCard types that don't match the regexp in
;; `bbdb-vcard-skip-on-import' and that have a non-empty value are
;; stored unaltered in the BBDB Notes alist where, for instance,
;; `TZ;VALUE=text:-05:00' is stored as `(tz\;value=text . "-05:00")'.
;; From the BBDB data fields AKA, Phones, Addresses, Net Addresses,
;; and Notes, duplicates are removed, respectively.
;; VCards found inside other vCards (as values of type AGENT) are
;; imported as well.
;; Handling of the individual types defined in RFC2426 during import
;; (assuming default label translation and no vCard type exclusion):
;; "
;; |----------------------+----------------------------------------|
;; |----------------------+----------------------------------------|
;; | VERSION | - |
;; |----------------------+----------------------------------------|
;; | N | First occurrence: |
;; | | Firstname |
;; | | Lastname |
;; | | |
;; | | Rest: |
;; | | AKAs (append) |
;; |----------------------+----------------------------------------|
;; | FN | AKAs (append) |
;; | NICKNAME | AKAs (append) |
;; |----------------------+----------------------------------------|
;; | ORG | First occurrence: |
;; | | Company |
;; | | |
;; | | Rest: |
;; | | Notes<org |
;; | | (repeatedly) |
;; |----------------------+----------------------------------------|
;; | ADR;TYPE=x,HOME,y | Addresses<Home |
;; | ADR;TYPE=x;TYPE=HOME | Addresses<Home |
;; | ADR;TYPE=x,WORK,y | Addresses<Office |
;; | ADR;TYPE=x;TYPE=WORK | Addresses<Office |
;; | ADR;TYPE=x,y,z | Addresses<x,y,z |
;; | ADR;TYPE=x;TYPE=y | Addresses<x,y |
;; | ADR | Addresses<Office |
;; |----------------------+----------------------------------------|
;; | TEL;TYPE=x,HOME,y | Phones<Home (append) |
;; | TEL;TYPE=x;TYPE=HOME | Phones<Home (append) |
;; | TEL;TYPE=x,WORK,y | Phones<Office (append) |
;; | TEL;TYPE=x;TYPE=WORK | Phones<Office (append) |
;; | TEL;TYPE=x,CELL,y | Phones<Mobile (append) |
;; | TEL;TYPE=x;TYPE=CELL | Phones<Mobile (append) |
;; | TEL;TYPE=x,y,z | Phones<x,y,z (append) |
;; | TEL;TYPE=x;TYPE=y | Phones<x,y (append) |
;; | TEL | Phones<Office (append) |
;; |----------------------+----------------------------------------|
;; | EMAIL;TYPE=x,y,z | Net-Addresses (append) |
;; | URL | Notes<www |
;; |----------------------+----------------------------------------|
;; | BDAY | Notes<anniversary (append as birthday) |
;; | X-BBDB-ANNIVERSARY | Notes<anniversary (append) |
;; |----------------------+----------------------------------------|
;; | NOTE | Notes<notes (append) |
;; | REV | Notes<creation-date |
;; | CATEGORIES | Notes<mail-alias (append) |
;; | SORT-STRING | Notes<sort-string |
;; | KEY | Notes<key |
;; | GEO | Notes<geo |
;; | TZ | Notes<tz |
;; | PHOTO | Notes<photo |
;; | LABEL | Notes<label |
;; | LOGO | Notes<logo |
;; | SOUND | Notes<sound |
;; | TITLE | Notes<title |
;; | ROLE | Notes<role |
;; | AGENT | Notes<agent |
;; | MAILER | Notes<mailer |
;; | UID | Notes<uid |
;; | PRODID | Notes<prodid |
;; | CLASS | Notes<class |
;; | X-foo | Notes<x-foo |
;; | X-BBDB-bar | Notes<bar |
;; |----------------------+----------------------------------------|
;; | anyJunK;a=x;b=y | Notes<anyjunk;a=x;b=y |
;; |----------------------+----------------------------------------|
;; "
;; vCard Export
;; ------------
;; VCard types N (only fields lastname, firstname) and FN both come
;; from BBDB's Name.
;; Members of BBDB field AKA are stored comma-separated under the
;; vCard type NICKNAME.
;; Labels of Addresses and Phones are translated as defined in
;; `bbdb-vcard-export-translation-table' into type parameters of
;; vCard types ADR and TEL, respectively.
;; In vCard type ADR, fields postbox and extended address are always
;; empty. Newlines which subdivide BBDB Address fields are converted
;; into commas subdividing vCard ADR fields.
;; The value of 'anniversary in Notes is supposed to be subdivided by
;; newlines. The birthday part (either just a date or a date followed
;; by \"birthday\") is stored under vCard type BDAY. The rest is
;; stored newline-separated in the non-standard vCard type
;; Field names listed in `bbdb-vcard-x-bbdb-candidates' are in the
;; exported vCard prepended by `X-BBDB-'.
;; The creation-date of the BBDB record is stored as vCard type REV.
;; Remaining members of BBDB Notes are exported to the vCard without
;; change.
;;; History:
;;; Code:
(require 'cl)
(require 'bbdb)
(require 'vcard)
(require 'bbdb-com)
(defconst bbdb-vcard-version "0.3"
"Version of the vCard importer/exporter.
The major part increases on user-visible changes.")
;;;; User Variables
(defgroup bbdb-vcard nil
"Customizations for vCards"
:group 'bbdb)
(defcustom bbdb-vcard-skip-on-import "X-GSM-"
"Regexp describing vCard elements that are to be discarded during import.
Example: `X-GSM-\\|X-MS-'."
:group 'bbdb-vcard
:type 'regexp)
(defcustom bbdb-vcard-skip-valueless t
"Skip vCard element types with an empty value.
Nil means insert empty types into BBDB."
:group 'bbdb-vcard
:type 'boolean)
(defcustom bbdb-vcard-import-translation-table
'(("CELL\\|CAR" . "Mobile")
("WORK" . "Office")
("HOME" . "Home") ; translates e.g. "dom,home,postal,parcel" to "Home"
("^$" . "Office")) ; acts as a default for parameterless ADR or TEL
"Label translation on vCard import.
Alist with translations of location labels for addresses and phone
numbers. Cells are (VCARD-LABEL-REGEXP . BBDB-LABEL). One entry
should map a default BBDB label to the empty string (`\"^$\"') which
corresponds to unlabelled vCard elements."
:group 'bbdb-vcard
:type '(alist :key-type
(choice regexp (const :tag "Empty (as default)" "^$"))
:value-type string))
(defcustom bbdb-vcard-try-merge t
"Try to merge vCards into existing BBDB records.
Nil means create a fresh bbdb record each time a vCard is read."
:group 'bbdb-vcard
:type 'boolean)
(defcustom bbdb-vcard-type-canonicalizer 'upcase
"Function to apply to vCard type names on export.
Most reasonable choices are `upcase' and `downcase'."
:group 'bbdb-vcard
:type 'function)
(defcustom bbdb-vcard-x-bbdb-candidates
aka) ; not sure what this is for
"List of translatable BBDB user field names.
On export to a vCard, they are transformed into vCard-compliant
extended types by prepending `X-BBDB-'. On (re-)import, this prefix
is removed again."
:group 'bbdb-vcard
:type '(repeat symbol))
(defcustom bbdb-vcard-export-translation-table
'(("Mobile" . "CELL")
("Office" . "WORK"))
"Label translation on vCard export.
Alist with translations of location labels for addresses and phone
numbers. Cells are (BBDB-LABEL-REGEXP . VCARD-LABEL)."
:group 'bbdb-vcard
:type '(alist :key-type
(choice regexp (const :tag "Empty (as default)" "^$"))
:value-type string))
(defcustom bbdb-vcard-export-coding-system
'utf-8-dos ; dos line endings mandatory according to RFC 2426
"Coding system to use when writing vCard files."
:group 'bbdb-vcard
:type 'symbol)
(defcustom bbdb-vcard-default-dir "~/exported-vcards/"
"Default storage directory for exported vCards.
Nil means current directory."
:group 'bbdb-vcard
:type '(choice directory (const :tag "Current directory" nil)))
;;;; User Functions
(defun bbdb-vcard-import-region (begin end)
"Import the vCards between BEGIN and END into BBDB.
Existing BBDB records may be altered."
(interactive "r")
(bbdb-vcard-iterate-vcards 'bbdb-vcard-import-vcard
(buffer-substring-no-properties begin end)))
(defun bbdb-vcard-import-buffer (vcard-buffer)
"Import vCards from VCARD-BUFFER into BBDB.
Existing BBDB records may be altered."
(interactive (list (current-buffer)))
(set-buffer vcard-buffer)
(bbdb-vcard-import-region (point-min) (point-max)))
(defun bbdb-vcard-import-file (vcard-file)
"Import vCards from VCARD-FILE into BBDB.
If VCARD-FILE is a wildcard, import each matching file. Existing BBDB
records may be altered."
(interactive "FvCard file (or wildcard): ")
(dolist (vcard-file (file-expand-wildcards vcard-file))
(insert-file-contents vcard-file)
(bbdb-vcard-import-region (point-min) (point-max)))))
(defun bbdb-vcard-export
(filename-or-directory all-records-p one-file-per-record-p)
"From Buffer *BBDB*, write one or more record(s) as vCard(s) to file(s).
If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-vcard-export]\"\
is used instead of simply \"\\[bbdb-vcard-export]\", then export all \
records currently
in the *BBDB* buffer. If used with prefix argument, store records
in individual files."
(let ((default-filename ; argument filename-or-directory
(bbdb-vcard-make-file-name (bbdb-current-record nil)))
(all-records-p (bbdb-do-all-records-p)))
(if all-records-p
(if current-prefix-arg
(read-directory-name "Write vCard files to directory: "
bbdb-vcard-default-dir nil 42)
"Write vCards to file: "
nil nil
(format-time-string "%Y-%m-%dT%H:%M.vcf" (current-time))))
(read-file-name "Write current record to vCard file: "
bbdb-vcard-default-dir nil nil default-filename))
all-records-p ; argument all-records-p
current-prefix-arg))) ; argument one-file-per-record-p
(if all-records-p
(let ((records (progn (set-buffer bbdb-buffer-name)
(mapcar 'car bbdb-records)))
used-up-basenames) ; keep them unique
(if one-file-per-record-p
(dolist (record records)
(let ((basename
(bbdb-vcard-make-file-name record
(insert (bbdb-vcard-from record))
(concat filename-or-directory basename))
(push basename used-up-basenames))))
(message "Wrote %d vCards to %s"
(length used-up-basenames) filename-or-directory))
(with-temp-buffer ; all visible BBDB records in one file
(dolist (record records)
(insert (bbdb-vcard-from record)))
(bbdb-vcard-write-buffer filename-or-directory))))
(let ((vcard (bbdb-vcard-from (bbdb-current-record nil)))) ; current record
(insert vcard)
(bbdb-vcard-write-buffer filename-or-directory)))))
(defun bbdb-vcard-export-to-kill-ring (all-records-p)
"From Buffer *BBDB*, copy one or more record(s) as vCard(s) to the kill ring.
If \"\\[bbdb-apply-next-command-to-all-records]\
is used instead of simply \"\\[bbdb-vcard-export-to-kill-ring]\", \
then export all records currently in
the *BBDB* buffer."
(interactive (let ((all-records-p (bbdb-do-all-records-p)))
(list all-records-p)))
(if all-records-p
(let ((records (progn (set-buffer bbdb-buffer-name)
(mapcar 'car bbdb-records))))
(kill-new "")
(dolist (record records)
(kill-append (bbdb-vcard-from record) nil))
(message "Saved %d records as vCards" (length records)))
(kill-new (bbdb-vcard-from (bbdb-current-record nil)))
(message "Saved record as vCard")))
;;;###autoload (define-key bbdb-mode-map [(v)] 'bbdb-vcard-export)
(define-key bbdb-mode-map [(v)] 'bbdb-vcard-export)
;;;###autoload (define-key bbdb-mode-map [(V)] 'bbdb-vcard-export-to-kill-ring)
(define-key bbdb-mode-map [(V)] 'bbdb-vcard-export-to-kill-ring)
(defun bbdb-vcard-iterate-vcards (vcard-processor vcards)
"Apply VCARD-PROCESSOR successively to each vCard in string VCARDS.
When VCARDS is nil, return nil. Otherwise, return t."
(insert vcards)
(goto-char (point-min))
;; Change CRLF into CR if necessary, dealing with inconsistent line
;; endings.
(while (re-search-forward "\r\n" nil t)
(replace-match "\n" nil nil nil 1))
(setf (buffer-string) (bbdb-vcard-unfold-lines (buffer-string)))
(goto-char (point-min))
(while (re-search-forward
nil t)
(let ((vcard (match-string 0)))
(if (string= "3.0" (bbdb-vcard-version-of vcard))
(funcall vcard-processor vcard)
(funcall vcard-processor ; probably a v2.1 vCard
(bbdb-vcard-convert-to-3.0 vcard))))))))
(defun bbdb-vcard-version-of (vcard)
"Return version number string of VCARD."
(insert vcard)
(car (bbdb-vcard-values-of-type "version" "value"))))
(defun bbdb-vcard-import-vcard (vcard)
"Store VCARD (version 3.0) in BBDB.
Extend existing BBDB records where possible."
(insert vcard)
(let* ((raw-name (car (bbdb-vcard-values-of-type "N" "value" t t)))
;; Name suitable for storing in BBDB:
(name (bbdb-vcard-unescape-strings
(bbdb-vcard-unvcardize-name raw-name)))
;; Name to search for in BBDB now:
(when raw-name (if (stringp raw-name)
(concat (nth 1 raw-name) ;given name
" .*"
(nth 0 raw-name))))) ; family name
;; Additional names from prefixed types like A.N, B.N, etc.:
(lambda (n)
(bbdb-join (bbdb-vcard-unvcardize-name (cdr (assoc "value" n)))
" "))
(bbdb-vcard-elements-of-type "N" nil t)))
(vcard-formatted-names (bbdb-vcard-unescape-strings
(bbdb-vcard-values-of-type "FN" "value")))
(car (bbdb-vcard-values-of-type "NICKNAME" "value"))
"," t)))
;; Company suitable for storing in BBDB:
(car (bbdb-vcard-values-of-type "ORG" "value" t t)))))
;; Company to search for in BBDB now:
(org-to-search-for vcard-org) ; sorry
;; Email suitable for storing in BBDB:
(vcard-email (bbdb-vcard-values-of-type "EMAIL" "value"))
;; Email to search for in BBDB now:
(when vcard-email
(concat "\\(" (bbdb-join vcard-email "\\)\\|\\(") "\\)")))
;; Phone numbers suitable for storing in BBDB:
(mapcar (lambda (tel)
(vector (bbdb-vcard-translate
(or (cdr (assoc "type" tel)) ""))
(cdr (assoc "value" tel))))
(bbdb-vcard-elements-of-type "TEL")))
;; Phone numbers to search for in BBDB now:
(when vcard-tels
(concat "\\("
(mapconcat (lambda (x) (elt x 1))
vcard-tels "\\)\\|\\(")
;; Addresses
(mapcar 'bbdb-vcard-unvcardize-adr
(bbdb-vcard-elements-of-type "ADR" nil t)))
(vcard-url (car (bbdb-vcard-values-of-type "URL" "value" t)))
(vcard-notes (bbdb-vcard-values-of-type "NOTE" "value"))
(raw-bday (bbdb-vcard-unvcardize-date-time
(car (bbdb-vcard-values-of-type "BDAY" "value" t))))
;; Birthday suitable for storing in BBDB (usable by org-mode):
(vcard-bday (when raw-bday (concat raw-bday " birthday")))
;; Birthday to search for in BBDB now:
(bday-to-search-for vcard-bday)
;; Non-birthday anniversaries, probably exported by ourselves:
(car (bbdb-vcard-values-of-type "X-BBDB-ANNIVERSARY" "value"))
"\\\\n" t))
(vcard-rev (bbdb-vcard-unvcardize-date-time
(car (bbdb-vcard-values-of-type "REV" "value"))))
(vcard-categories (bbdb-vcard-values-of-type "CATEGORIES" "value"))
;; The BBDB record to change:
(record-freshness-info "BBDB record changed:") ; default user info
;; Try to find an existing one ...
;; (a) try company and net and name:
(car (and bbdb-vcard-try-merge
org-to-search-for email-to-search-for)))
;; (b) try company and name:
(car (and bbdb-vcard-try-merge
(bbdb-records) name-to-search-for org-to-search-for)))
;; (c) try net and name; we may change company here:
(car (and bbdb-vcard-try-merge
name-to-search-for nil email-to-search-for)))
;; (d) try birthday and name; we may change company here:
(car (and bbdb-vcard-try-merge
name-to-search-for nil nil bday-to-search-for)))
;; (e) try phone and name; we may change company here:
(car (and bbdb-vcard-try-merge
name-to-search-for nil nil nil tel-to-search-for)))
;; No existing record found; make a fresh one:
(let ((fresh-record (make-vector bbdb-record-length nil)))
(bbdb-record-set-cache fresh-record
(make-vector bbdb-cache-length nil))
(if vcard-rev ; For fresh records,
(bbdb-record-putprop ; set creation-date from vcard-rev
fresh-record 'creation-date vcard-rev)
(bbdb-invoke-hook 'bbdb-create-hook fresh-record))
(setq record-freshness-info "BBDB record added:") ; user info
(bbdb-akas (bbdb-record-aka bbdb-record))
(bbdb-addresses (bbdb-record-addresses bbdb-record))
(bbdb-phones (bbdb-record-phones bbdb-record))
(bbdb-nets (bbdb-record-net bbdb-record))
(bbdb-raw-notes (bbdb-record-raw-notes bbdb-record))
(bbdb-vcard-elements-of-type "BEGIN") ; get rid of delimiter
(bbdb-vcard-elements-of-type "END") ; get rid of delimiter
(bbdb-vcard-elements-of-type "VERSION") ; get rid of this too
(when name ; which should be the case as N is mandatory in vCard
(bbdb-record-set-firstname bbdb-record (car name))
(bbdb-record-set-lastname bbdb-record (cadr name)))
(remove (concat (bbdb-record-firstname bbdb-record)
" " (bbdb-record-lastname bbdb-record))
(reduce (lambda (x y) (union x y :test 'string=))
(list vcard-nicknames
(when vcard-org (bbdb-record-set-company bbdb-record vcard-org))
bbdb-record (union vcard-email bbdb-nets :test 'string=))
bbdb-record (union vcard-adrs bbdb-addresses :test 'equal))
(bbdb-record-set-phones bbdb-record
(union vcard-tels bbdb-phones :test 'equal))
;; prepare bbdb's notes:
(when vcard-url (push (cons 'www vcard-url) bbdb-raw-notes))
(when vcard-notes
;; Put vCard NOTEs under key 'notes (append if necessary).
(unless (assq 'notes bbdb-raw-notes)
(push (cons 'notes "") bbdb-raw-notes))
(setf (cdr (assq 'notes bbdb-raw-notes))
(cdr (assq 'notes bbdb-raw-notes))
(bbdb-vcard-unescape-strings vcard-notes)
(when (or vcard-bday vcard-x-bbdb-anniversaries)
;; Put vCard BDAY and vCard X-BBDB-ANNIVERSARY's under key
;; 'anniversary (append if necessary) where org-mode can find
;; it. Org-mode doesn't currently (v6.35) bother with time
;; and time zone, though.
(when vcard-bday (push vcard-bday vcard-x-bbdb-anniversaries))
(unless (assq 'anniversary bbdb-raw-notes)
(push (cons 'anniversary "") bbdb-raw-notes))
(setf (cdr (assq 'anniversary bbdb-raw-notes))
(cdr (assq 'anniversary bbdb-raw-notes))
(bbdb-vcard-unescape-strings vcard-x-bbdb-anniversaries)
(when vcard-categories
;; Put vCard CATEGORIES under key 'mail-alias (append if necessary).
(unless (assq 'mail-alias bbdb-raw-notes)
(push (cons 'mail-alias "") bbdb-raw-notes))
(setf (cdr (assq 'mail-alias bbdb-raw-notes))
(cdr (assq 'mail-alias bbdb-raw-notes))
(while (setq other-vcard-type (bbdb-vcard-other-element))
(when (string-match "^\\([[:alnum:]-]*\\.\\)?AGENT"
(symbol-name (car other-vcard-type)))
;; Notice other vCards inside the current one.
'bbdb-vcard-import-vcard ; needed for inner v2.1 vCards:
(replace-regexp-in-string "\\\\" "" (cdr other-vcard-type))))
(unless (or (and bbdb-vcard-skip-on-import
(string-match bbdb-vcard-skip-on-import
(symbol-name (car other-vcard-type))))
(and bbdb-vcard-skip-valueless
(zerop (length (cdr other-vcard-type)))))
(push (bbdb-vcard-remove-x-bbdb other-vcard-type) bbdb-raw-notes)))
(remove-duplicates bbdb-raw-notes :test 'equal :from-end t))
(bbdb-change-record bbdb-record t)
;; Tell the user what we've done.
(message "%s %s %s -- %s"
(bbdb-record-firstname bbdb-record)
(bbdb-record-lastname bbdb-record)
"\n" "; " (or (bbdb-record-company bbdb-record) "-"))))))
(defun bbdb-vcard-from (record)
"Return BBDB RECORD as a vCard."
(let* ((name (bbdb-record-name record))
(first-name (bbdb-record-firstname record))
(last-name (bbdb-record-lastname record))
(aka (bbdb-record-aka record))
(company (bbdb-record-company record))
(net (bbdb-record-net record))
(phones (bbdb-record-phones record))
(addresses (bbdb-record-addresses record))
(www (bbdb-get-field record 'www))
(bbdb-vcard-split-structured-text (bbdb-record-notes record)
";\n" t))
(raw-anniversaries (bbdb-vcard-split-structured-text
(bbdb-get-field record 'anniversary) "\n" t))
(car (bbdb-vcard-split-structured-text
(find-if (lambda (x) (string-match birthday-regexp x))
" " t)))
(remove-if (lambda (x) (string-match birthday-regexp x))
raw-anniversaries :count 1))
(creation-date (bbdb-get-field record 'creation-date))
(mail-aliases (bbdb-record-getprop record
(raw-notes (copy-alist (bbdb-record-raw-notes record))))
(bbdb-vcard-insert-vcard-element "BEGIN" "VCARD")
(bbdb-vcard-insert-vcard-element "VERSION" "3.0")
(bbdb-vcard-insert-vcard-element "FN" (bbdb-vcard-escape-strings name))
"N" (bbdb-vcard-escape-strings last-name)
";" (bbdb-vcard-escape-strings first-name)
";;;") ; Additional Names, Honorific Prefixes, Honorific Suffixes
"NICKNAME" (bbdb-join (bbdb-vcard-escape-strings aka) ","))
"ORG" (bbdb-vcard-escape-strings company))
(dolist (mail net)
"EMAIL;TYPE=INTERNET" (bbdb-vcard-escape-strings mail)))
(dolist (phone phones)
(bbdb-vcard-translate (bbdb-phone-location phone) t)))
(bbdb-vcard-escape-strings (bbdb-phone-string phone))))
(dolist (address addresses)
(bbdb-vcard-translate (bbdb-address-location address) t)))
";;" ; no Postbox, no Extended
(bbdb-join (bbdb-vcard-escape-strings (bbdb-address-streets address))
";" (bbdb-vcard-vcardize-address-element
(bbdb-vcard-escape-strings (bbdb-address-city address)))
";" (bbdb-vcard-vcardize-address-element
(bbdb-vcard-escape-strings (bbdb-address-state address)))
";" (bbdb-vcard-vcardize-address-element
(bbdb-vcard-escape-strings (bbdb-address-zip address)))
";" (bbdb-vcard-vcardize-address-element
(bbdb-vcard-escape-strings (bbdb-address-country address)))))
(bbdb-vcard-insert-vcard-element "URL" www)
(dolist (note notes)
"NOTE" (bbdb-vcard-escape-strings note)))
(bbdb-vcard-insert-vcard-element "BDAY" birthday)
(bbdb-vcard-insert-vcard-element ; non-birthday anniversaries
"X-BBDB-ANNIVERSARY" (bbdb-join other-anniversaries "\\n"))
(bbdb-vcard-insert-vcard-element "REV" creation-date)
(bbdb-join (bbdb-vcard-escape-strings
(bbdb-vcard-split-structured-text mail-aliases "," t)) ","))
;; prune raw-notes...
(dolist (key '(www notes anniversary mail-alias creation-date timestamp))
(setq raw-notes (assq-delete-all key raw-notes)))
;; ... and output what's left
(dolist (raw-note raw-notes)
(symbol-name (bbdb-vcard-prepend-x-bbdb-maybe (car raw-note)))
(bbdb-vcard-escape-strings (cdr raw-note))))
(bbdb-vcard-insert-vcard-element "END" "VCARD")
(bbdb-vcard-insert-vcard-element nil)) ; newline
(defun bbdb-vcard-convert-to-3.0 (vcard)
"Convert VCARD from v2.1 to v3.0.
Return a version 3.0 vCard as a string. Don't bother about the vCard
v3.0 mandatory elements N and FN."
;; Prevent customization of vcard.el's from being changed behind our back:
(let ((vcard-standard-filters '(vcard-filter-html)))
(bbdb-vcard-insert-vcard-element "BEGIN" "VCARD")
(bbdb-vcard-insert-vcard-element "VERSION" "3.0")
(dolist (element (remove*
"VERSION" (vcard-parse-string vcard)
:key (lambda (x) (upcase (caar x))) :test 'string=))
(concat (caar element)
(mapconcat 'bbdb-vcard-parameter-pair (cdar element) ""))
(bbdb-join (bbdb-vcard-escape-strings (cdr element)) ";")))
(bbdb-vcard-insert-vcard-element "END" "VCARD")
(bbdb-vcard-insert-vcard-element nil)
(defun bbdb-vcard-parameter-pair (input)
"Return \"parameter=value\" made from INPUT.
INPUT is its representation in vcard.el. Return empty string if INPUT
is nil."
(cond ((consp input) (concat ";" (car input) "=" (cdr input)))
((stringp input) (concat ";TYPE=" input))
((null input) "")))
(defun bbdb-vcard-values-of-type
(type parameter &optional one-is-enough-p split-value-at-semi-colon-p)
"Return in a list the values of PARAMETER of vCard element of TYPE.
The VCard element is read and deleted from current buffer which is
supposed to contain a single vCard. If ONE-IS-ENOUGH-P is non-nil,
read and delete only the first element of TYPE. If PARAMETER is
\"value\" and SPLIT-VALUE-AT-SEMI-COLON-P is non-nil, split the value
at semi-colons into a list."
(mapcar (lambda (x) (cdr (assoc parameter x)))
type one-is-enough-p split-value-at-semi-colon-p)))
(defun bbdb-vcard-elements-of-type
(type &optional one-is-enough-p split-value-at-semi-colon-p)
"From current buffer read and delete the vCard elements of TYPE.
The current buffer is supposed to contain a single vCard. If
ONE-IS-ENOUGH-P is non-nil, read and delete only the first element of
TYPE. Return a list of alists, one per element. Each alist has a
cell with key \"value\" containing the element's value, and may have
other elements of the form \(parameter-name . parameter-value). If
SPLIT-VALUE-AT-SEMI-COLON-P is non-nil, split the value at key
\"value\" at semi-colons into a list."
(goto-char (point-min))
(let (values parameters read-enough)
(not read-enough)
"^\\([[:alnum:]-]*\\.\\)?\\(" type "\\)\\(;.*\\)?:\\(.*\\)$")
nil t))
(goto-char (match-end 2))
(setq parameters nil)
(push (cons "value" (if split-value-at-semi-colon-p
(match-string 4) ";")
(match-string 4)))
(while (re-search-forward "\\([^;:=]+\\)=\\([^;:]+\\)"
(line-end-position) t)
(let* ((parameter-key (downcase (match-string 1)))
(parameter-value (downcase (match-string 2)))
(parameter-sibling (assoc parameter-key parameters)))
(if parameter-sibling ; i.e., pair with equal key
;; collect vCard parameter list `;a=x;a=y;a=z'
;; into vCard value list `;a=x,y,z'; becoming ("a" . "x,y,z")
(setf (cdr parameter-sibling)
(concat (cdr parameter-sibling) "," parameter-value))
;; vCard parameter pair `;key=value;' with new key
(push (cons parameter-key parameter-value) parameters))))
(push parameters values)
(delete-region (line-end-position 0) (line-end-position))
(when one-is-enough-p (setq read-enough t)))
(nreverse values)))
(defun bbdb-vcard-other-element ()
"From current buffer read and delete the topmost vCard element.
Buffer is supposed to contain a single vCard. Return (TYPE . VALUE)."
(goto-char (point-min))
(when (re-search-forward "^\\([[:graph:]]*?\\):\\(.*\\)$" nil t)
(let ((type (match-string 1))
(value (match-string 2)))
(delete-region (match-beginning 0) (match-end 0))
(cons (intern (downcase type)) (bbdb-vcard-unescape-strings value)))))
(defun bbdb-vcard-insert-vcard-element (type &rest values)
"Insert a vCard element comprising TYPE, `:', VALUES into current buffer.
Take care of TYPE canonicalization, line folding, and closing newline.
Do nothing if TYPE is non-nil and VALUES are empty. Insert just a
newline if TYPE is nil."
(if type
(let ((value (bbdb-join values "")))
(unless (zerop (length value))
(insert (bbdb-vcard-fold-line
(concat (bbdb-vcard-canonicalize-vcard-type type)
":" value)))))
(insert (bbdb-vcard-fold-line ""))))
(defun bbdb-vcard-unfold-lines (vcards)
"Return folded vCard lines from VCARDS unfolded."
(replace-regexp-in-string "\n\\( \\|\t\\)" "" vcards))
(defun bbdb-vcard-fold-line (long-line)
"Insert after every 75th position in LONG-LINE a newline and a space."
(with-temp-buffer (insert long-line)
(goto-char (point-min))
(while (< (goto-char (+ (point) 75))
(insert "\n "))
(insert "\n")
(defun bbdb-vcard-unescape-strings (escaped-strings)
"Unescape escaped `;', `,', `\\', and newlines in ESCAPED-STRINGS.
ESCAPED-STRINGS may be a string or a sequence of strings."
(flet ((unescape (x) (replace-regexp-in-string
"\\([\\\\]\\)\\([,;\\]\\)" ""
(replace-regexp-in-string "\\\\n" "\n" x)
nil nil 1)))
(bbdb-vcard-process-strings 'unescape escaped-strings)))
(defun bbdb-vcard-escape-strings (unescaped-strings )
"Escape `;', `,', `\\', and newlines in UNESCAPED-STRINGS.
UNESCAPED-STRINGS may be a string or a sequence of strings."
(flet ((escape (x) (replace-regexp-in-string ; from 2.1 conversion:
"\r" "" (replace-regexp-in-string
"\n" "\\\\n" (replace-regexp-in-string
"\\(\\)[,;\\]" "\\\\" (or x "")
nil nil 1)))))
(bbdb-vcard-process-strings 'escape unescaped-strings)))
(defun bbdb-vcard-process-strings (string-processor strings)
STRINGS may be a string or a sequence of strings."
(if (stringp strings)
(funcall string-processor strings)
(mapcar string-processor strings)))
(defun bbdb-vcard-remove-x-bbdb (vcard-element)
"Remove the `X-BBDB-' prefix from the type part of VCARD-ELEMENT if any."
(cons (intern (replace-regexp-in-string
"^X-BBDB-" "" (symbol-name (car vcard-element))))
(cdr vcard-element)))
(defun bbdb-vcard-prepend-x-bbdb-maybe (bbdb-fieldname)
"If BBDB-FIELDNAME is in `bbdb-vcard-x-bbdb-candidates', prepend `X-BBDB'."
(if (member bbdb-fieldname bbdb-vcard-x-bbdb-candidates)
(intern (concat "x-bbdb-" (symbol-name bbdb-fieldname)))
bbdb-fieldname)) ; lowercase more consistent here
(defun bbdb-vcard-unvcardize-name (vcard-name)
"Convert VCARD-NAME (type N) into (FIRSTNAME LASTNAME)."
(if (stringp vcard-name) ; unstructured N
(bbdb-divide-name vcard-name)
(let ((vcard-name
(mapcar (lambda (x)
(bbdb-join (bbdb-vcard-split-structured-text x "," t)
" "))
vcard-name))) ; flatten comma-separated substructure
(list (concat (nth 3 vcard-name) ; honorific prefixes
(unless (zerop (length (nth 3 vcard-name))) " ")
(nth 1 vcard-name) ; given name
(unless (zerop (length (nth 2 vcard-name))) " ")
(nth 2 vcard-name)) ; additional names
(concat (nth 0 vcard-name) ; family name
(unless (zerop (length (nth 4 vcard-name))) " ")
(nth 4 vcard-name)))))) ; honorific suffixes
(defun bbdb-vcard-unvcardize-org (vcard-org)
"Convert VCARD-ORG (type ORG), which may be a list, into a string."
(if (or (null vcard-org)
(stringp vcard-org)) ; unstructured, probably non-standard ORG
vcard-org ; Company, unit 1, unit 2...
(bbdb-join vcard-org "\n")))
(defun bbdb-vcard-unvcardize-adr (vcard-adr)
"Convert VCARD-ADR into BBDB format.
Turn a vCard element of type ADR into (TYPE STREETS CITY STATE ZIP
(let ((adr-type (or (cdr (assoc "type" vcard-adr)) ""))
(streets ; all comma-separated sub-elements of
(remove ; Postbox, Extended, Streets go into one list
"" (reduce 'append
(mapcar (lambda (x)
(bbdb-vcard-split-structured-text x "," t))
(subseq (cdr (assoc "value" vcard-adr))
0 3)))))
(non-streets ; turn comma-separated substructure into
(mapcar ; newline-separated text
(lambda (x) (bbdb-join
(bbdb-vcard-split-structured-text x "," t)
(subseq (cdr (assoc "value" vcard-adr))
3 nil))))
(vector (bbdb-vcard-translate adr-type)
(or (elt non-streets 0) "") ; City
(or (elt non-streets 1) "") ; State
(or (elt non-streets 2) "") ; Zip
(or (elt non-streets 3) "")))) ; Country
(defun bbdb-vcard-unvcardize-date-time (date-time)
"If necessary, make DATE-TIME usable for storage in BBDB.
Convert yyyymmdd, yyyymmddThhmmss, or yyymmddThhmmssZhhmm into
yyyy-mm-dd, yyyy-mm-ddThh:mm:ss, or yyy-mm-ddThh:mm:ssZhh:mm
respectively. Discard fractions of a second. Return anything else
(if (and (stringp date-time)
(match-string 1 date-time) "-"
(match-string 2 date-time) "-" (match-string 3 date-time)
(when (match-string 6 date-time) ; seconds part of time
"T" (match-string 4 date-time) ":"
(match-string 5 date-time) ":" (match-string 6 date-time)
(when (match-string 7 date-time) ; time zone
(if (match-string 9 date-time) ; time zone minute
(concat (match-string 8 date-time) ; time zone hour
":" (match-string 9 date-time)) ; time zone minute
(defun bbdb-vcard-vcardize-address-element (address-element)
"Replace escaped newlines in ADDRESS-ELEMENT by commas."
(replace-regexp-in-string "\\\\n" "," address-element))
(defun bbdb-vcard-translate (label &optional exportp)
"Translate LABEL from vCard to BBDB or, if EXPORTP is non-nil, vice versa.
Translations are defined in `bbdb-vcard-import-translation-table' and
`bbdb-vcard-export-translation-table' respectively."
(when label
(or (assoc-default label
(if exportp
bbdb-vcard-import-translation-table) 'string-match)
(defun bbdb-vcard-merge-strings (old-string new-strings separator)
"Merge strings successively from list NEW-STRINGS into OLD-STRING.
If an element of NEW-STRINGS is already in OLD-STRING, leave
OLD-STRING unchanged. Otherwise append SEPARATOR and NEW-STRING."
(insert old-string)
(dolist (new-string new-strings)
(unless (prog1 (search-backward new-string nil t)
(goto-char (point-max)))
(unless (zerop (buffer-size)) (insert separator))
(insert new-string)))
(defun bbdb-vcard-split-structured-text
(text separator &optional return-always-list-p)
"Split TEXT at unescaped occurrences of SEPARATOR; return parts in a list.
Return text unchanged if there aren't any separators and RETURN-ALWAYS-LIST-P
is nil."
(when (stringp text)
(let ((string-elements
(concat "\\\\\r" separator) (concat "\\\\" separator)
(replace-regexp-in-string separator (concat "\r" separator) text))
(concat "\r" separator))))
(if (and (null return-always-list-p)
(= 1 (length string-elements)))
(car string-elements)
(defun bbdb-vcard-canonicalize-vcard-type (&rest strings)
"Concatenate STRINGS and apply `bbdb-vcard-type-canonicalizer' to them."
(funcall bbdb-vcard-type-canonicalizer (bbdb-join strings "")))
(defun bbdb-vcard-write-buffer (vcard-file-name)
"Write current buffer to VCARD-FILE-NAME.
Create directories where necessary."
(make-directory (file-name-directory vcard-file-name) t)
(let ((buffer-file-coding-system bbdb-vcard-export-coding-system))
(write-region nil nil vcard-file-name nil nil nil t)))
(defun bbdb-vcard-make-file-name (bbdb-record &optional used-up-basenames)
"Come up with a vCard filename given a BBDB-RECORD.
Make it unique against the list USED-UP-BASENAMES."
(let ((name (bbdb-record-name bbdb-record))
(aka (car (bbdb-record-aka bbdb-record)))
(unique-number 0)
(while (member
(setq filename
"[[:blank:]]+" "_"
(or (unless (zerop (length name)) name)
(unless (zerop (length aka)) aka)
(unless (zerop unique-number)
(concat "-" (number-to-string unique-number)))
(incf unique-number))
(defmacro bbdb-vcard-search-intersection
(records &optional name company net notes phone)
"Search RECORDS for records that match each non-nil argument."
(if phone `(when ,phone (bbdb-search ,records nil nil nil nil ,phone))
(if notes `(when ,notes (bbdb-search ,phone-search nil nil nil ,notes))
(if net `(when ,net (bbdb-search ,notes-search nil nil ,net))
(if company `(when ,company (bbdb-search ,net-search nil ,company))
(if name `(when ,name (bbdb-search ,company-search ,name))
(provide 'bbdb-vcard)
;;; bbdb-vcard.el ends here
; LocalWords: vcard firstname