bbdb-vcard-export.el

   1 ;;; bbdb-vcard-export.el -- export BBDB as vCard files
   2 ;;
   3 ;; Copyright (c) 2002 Jim Hourihan
   4 ;; Copyright (c) 2005 Alex Schroeder
   5 ;;
   6 ;; bbdb-vcard-export.el is free software you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation; either version 2, or (at
   9 ;; your option) any later version.
  10 ;;
  11 ;; This software is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19 ;;
  20 ;; Author: Jim Hourihan <jimh@panix.com>
  21 ;; Created: 2002-08-08
  22 ;; Version: $Id: bbdb-vcard-export.el,v 1.3 2006/03/14 00:00:00 malcolmp Exp $
  23 ;; Keywords: vcard ipod
  24
  25 ;;; Commentary
  26
  27 ;; I use this code to sync my ipod with bbdb under OS X. To do so:
  28 ;;
  29 ;;      M-x bbdb-vcard-export-update-all
  30 ;;
  31 ;; and enter `/Volumes/IPOD_NAME/Contacts/' at the prompt
  32 ;;
  33 ;; vCard documentated in RFC 2426 <http://www.faqs.org/rfcs/rfc2426.html>
  34 ;; Value types documented in RFC 2425 <http://www.faqs.org/rfcs/rfc2425.html>
  35
  36 ;; The coding system used for writing the files is UTF-16 by default.
  37 ;; To use anything else, use a prefix argument: C-u M-x
  38 ;; bbdb-vcard-export-update-all.  You will be prompted for another
  39 ;; coding system to use.  Latin-1 is probably a good choice.
  40 ;; bbdb-file-coding-system's default value is iso-2022-7bit, which is
  41 ;; probably useless for vCard exports.
  42
  43 ;;; Code:
  44
  45 (require 'bbdb)
  46
  47 ; XEmacs prior to 21.5 is not dumped with replace-regexp-in-string.  In those
  48 ; cases it can be found in the xemacs-base package.
  49 (eval-and-compile
  50   (if (and (not (fboundp 'replace-regexp-in-string)) (featurep 'xemacs))
  51       (require 'easy-mmode)))
  52
  53 (defvar bbdb-translation-table
  54   '(("Mobile" . "Cell"))
  55   "Translations of text items, typically for labels.")
  56
  57 (defun bbdb-translate (str)
  58   "Translate STR into some other string based on `bbdb-translation-table'."
  59   (let ((translation (assoc str bbdb-translation-table)))
  60     (if translation
  61         (cdr translation)
  62       str)))
  63
  64 ;; 2.3 Predefined VALUE Type Usage
  65
  66 ;;    The predefined data type values specified in [MIME-DIR] MUST NOT be
  67 ;;    repeated in COMMA separated value lists except within the N,
  68 ;;    NICKNAME, ADR and CATEGORIES value types.
  69
  70 ;;    The text value type defined in [MIME-DIR] is further restricted such
  71 ;;    that any SEMI-COLON character (ASCII decimal 59) in the value MUST be
  72 ;;    escaped with the BACKSLASH character (ASCII decimal 92).
  73
  74 (defun bbdb-vcard-export-escape (str)
  75   "Return a copy of STR with ; , and newlines escaped."
  76   (setq str (bbdb-translate str)
  77         str (or str ""); get rid of nil values
  78         str (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str)
  79         str (replace-regexp-in-string "\n" "\\\\n" str)))
  80
  81 ;; (insert (bbdb-vcard-export-escape "this is, not \\ or \n true"))
  82
  83 (defun bbdb-vcard-export-several (list)
  84   "Return a comma-separated list of escaped unique elements in LIST."
  85   (let ((hash (make-hash-table :test 'equal))
  86         result)
  87     (dolist (item list)
  88       (puthash (bbdb-vcard-export-escape item) t hash))
  89     (maphash (lambda (key val)
  90                (setq result (cons key result)))
  91              hash)
  92     (bbdb-join result ",")))
  93
  94 ;; The component values MUST be specified in
  95 ;; their corresponding position. The structured type value corresponds,
  96 ;; in sequence, to the post office box; the extended address; the street
  97 ;; address; the locality (e.g., city); the region (e.g., state or
  98 ;; province); the postal code; the country name. When a component value
  99 ;; is missing, the associated component separator MUST still be
 100 ;; specified.
 101
 102 ;; The text components are separated by the SEMI-COLON character (ASCII
 103 ;; decimal 59). Where it makes semantic sense, individual text
 104 ;; components can include multiple text values (e.g., a "street"
 105 ;; component with multiple lines) separated by the COMMA character
 106 ;; (ASCII decimal 44).
 107 (defun bbdb-vcard-export-address-string (address)
 108   "Return the address string"
 109   (let ((streets (bbdb-address-streets address))
 110         (city (bbdb-address-city address))
 111         (state (bbdb-address-state address))
 112         (country (bbdb-address-country address))
 113         (zip (bbdb-address-zip address)))
 114     (concat
 115      "adr;type=" (bbdb-vcard-export-escape (bbdb-address-location address)) ":"
 116      ";;" ;; no post office box, no extended address
 117      (bbdb-vcard-export-several streets) ";"
 118      (bbdb-vcard-export-escape city) ";"
 119      (bbdb-vcard-export-escape state) ";"
 120      (bbdb-vcard-export-escape zip) ";"
 121      (bbdb-vcard-export-escape country))))
 122
 123 (defun xwl-bbdb-record-phones (record)
 124   (let ((cell-phone (bbdb-get-field record 'cell-phone))
 125         (home-phone (bbdb-get-field record 'home-phone))
 126         (ret '()))
 127     (unless (string= cell-phone "")
 128       (setq ret (list (list 'cell cell-phone))))
 129     (unless (string= home-phone "")
 130       (setq ret (cons (list 'home home-phone) ret)))
 131     ret))
 132
 133 (defun xwl-bbdb-phone-location (phone)
 134   (symbol-name (car phone)))
 135
 136 (defun xwl-bbdb-phone-string (phone)
 137   (cadr phone))
 138
 139 (defun bbdb-vcard-export-record-insert-vcard (record)
 140   "Insert a vcard formatted version of RECORD into the current buffer"
 141   (let ((name (bbdb-record-name record))
 142         (first-name (bbdb-record-firstname record))
 143         (last-name (bbdb-record-lastname record))
 144         (aka (bbdb-record-aka record))
 145         (company (bbdb-record-company record))
 146         (notes (bbdb-record-notes record))
 147         ;; (phones (bbdb-record-phones record))
 148         (phones (xwl-bbdb-record-phones record))
 149         (addresses (bbdb-record-addresses record))
 150         (net (bbdb-record-net record))
 151         (categories (bbdb-record-getprop
 152                      record
 153                      bbdb-define-all-aliases-field)))
 154     (insert "begin:vcard\n"
 155             "version:3.0\n")
 156     ;; Specify the formatted text corresponding to the name of the
 157     ;; object the vCard represents.  The property MUST be present in
 158     ;; the vCard object.
 159     (insert "fn:" (bbdb-vcard-export-escape name) "\n")
 160     ;; Family Name, Given Name, Additional Names, Honorific
 161     ;; Prefixes, and Honorific Suffixes
 162     (when (or last-name first-name)
 163       (insert "n:"
 164               (bbdb-vcard-export-escape last-name) ";"
 165               (bbdb-vcard-export-escape first-name) ";;;\n"))
 166     ;; Nickname of the object the vCard represents.  One or more text
 167     ;; values separated by a COMMA character (ASCII decimal 44).
 168     (when aka
 169       (insert "nickname:" (bbdb-vcard-export-several aka) "\n"))
 170     ;; FIXME: use face attribute for this one.
 171     ;; PHOTO;ENCODING=b;TYPE=JPEG:MIICajCCAdOgAwIBAgICBEUwDQYJKoZIhvcN
 172     ;; AQEEBQAwdzELMAkGA1UEBhMCVVMxLDAqBgNVBAoTI05ldHNjYXBlIENvbW11bm
 173     ;; ljYXRpb25zIENvcnBvcmF0aW9uMRwwGgYDVQQLExNJbmZvcm1hdGlvbiBTeXN0
 174
 175     ;; FIXME: use birthday attribute if there is one.
 176     ;; BDAY:1996-04-15
 177     ;; BDAY:1953-10-15T23:10:00Z
 178     ;; BDAY:1987-09-27T08:30:00-06:00
 179
 180     ;; A single structured text value consisting of components
 181     ;; separated the SEMI-COLON character (ASCII decimal 59).  But
 182     ;; BBDB doesn't use this.  So there's just one level:
 183     (when company
 184       (insert "org:" (bbdb-vcard-export-escape company) "\n"))
 185     (when notes
 186       (insert "note:" (bbdb-vcard-export-escape notes) "\n"))
 187     ;; (dolist (phone phones)
 188     ;;   (insert "tel;type=" (bbdb-vcard-export-escape (bbdb-phone-location phone)) ":"
 189     ;;           (bbdb-vcard-export-escape (bbdb-phone-string phone)) "\n"))
 190
 191     (dolist (phone phones)
 192       (insert "tel;type=" (xwl-bbdb-phone-location phone) ":"
 193               (xwl-bbdb-phone-string phone) "\n"))
 194
 195     (dolist (address addresses)
 196       (insert (bbdb-vcard-export-address-string address) "\n"))
 197     (dolist (mail net)
 198       (insert "email;type=internet:" (bbdb-vcard-export-escape mail) "\n"))
 199     ;; Use CATEGORIES based on mail-alias.  One or more text values
 200     ;; separated by a COMMA character (ASCII decimal 44).
 201     (when categories
 202       (insert "categories:"
 203               (bbdb-join (mapcar 'bbdb-vcard-export-escape
 204                                  (bbdb-split categories ",")) ",") "\n"))
 205     (insert "end:vcard\n")))
 206
 207 (defun bbdb-vcard-export-vcard-name-from-record (record)
 208   "Come up with a vcard name given a record"
 209   (let ((name (bbdb-record-name record))
 210         (first-name (elt record 0))
 211         (last-name (elt record 1)))
 212     (concat first-name "_" last-name ".vcf")))
 213
 214 (defun bbdb-vcard-export-make-vcard (record vcard-name)
 215   "Make a record buffer and write it"
 216   (let ((buffer (get-buffer-create "*bbdb-vcard-export*")))
 217     (save-excursion
 218       (set-buffer buffer)
 219       (kill-region (point-min) (point-max))
 220       (bbdb-vcard-export-record-insert-vcard record)
 221       (write-region (point-min) (point-max) vcard-name))
 222     (kill-buffer buffer)))
 223
 224 (defun bbdb-vcard-do-record (record output-dir coding-system)
 225   "Update the vcard of one bbdb record"
 226   (setq coding-system (or coding-system 'utf-16))
 227   (let ((coding-system-for-write coding-system))
 228     (message "Updating %s" (bbdb-record-name record))
 229     (bbdb-vcard-export-make-vcard
 230      record
 231      (concat output-dir
 232              (bbdb-vcard-export-vcard-name-from-record record)))))
 233
 234 (defun bbdb-vcard-export-update-all (output-dir coding-system)
 235   "Update the vcard Contacts directory from the bbdb database"
 236   (interactive "DDirectory to update: \nZCoding system: ")
 237   (bbdb ".*" nil)
 238   (dolist (record (bbdb-records))
 239     (bbdb-vcard-do-record record output-dir coding-system)))
 240
 241 (defun bbdb-vcard-export (regexp output-dir coding-system)
 242   "Update the vcard Contacts directory from records matching REGEXP"
 243   (interactive "sExport records matching: \nDDirectory to update: \nZCoding system: ")
 244   (bbdb regexp nil)
 245   (let ((notes (cons '* regexp)))
 246     (dolist (record (bbdb-search (bbdb-records) regexp regexp regexp notes nil))
 247       (message "Updating %s" (bbdb-record-name record))
 248       (bbdb-vcard-do-record record output-dir coding-system))))
 249
 250 (defun bbdb-vcard-export-current (output-dir coding-system)
 251   "Update the vcard of the current record"
 252   (interactive "DDirectory to update: \nZCoding system: ")
 253   (let ((record (bbdb-current-record nil)))
 254     (bbdb-vcard-do-record record output-dir coding-system)))
 255
 256 (define-key bbdb-mode-map [(v)] 'bbdb-vcard-export-current)
 257
 258
 259 (provide 'bbdb-vcard-export)
 260
 261 ;;; bbdb-vcard-export.el ends here