1 ;;; vcard.el --- vcard parsing and display routines
3 ;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman
5 ;; Author: Noah Friedman <friedman@splode.com>
6 ;; Maintainer: friedman@splode.com
7 ;; Keywords: vcard, mail, news
10 ;; <http://www.splode.com/users/friedman/software/emacs-lisp/>
11 ;; Id: vcard.el,v 1.11 2000/06/29 17:07:55 friedman Exp
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 3, or (at your option)
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
28 ;; Unformatted vcards are just plain ugly. But if you live in the MIME
29 ;; world, they are a better way of exchanging contact information than
30 ;; freeform signatures since the former can be automatically parsed and
31 ;; stored in a searchable index.
33 ;; This library of routines provides the back end necessary for parsing
34 ;; vcards so that they can eventually go into an address book like BBDB
35 ;; (although this library does not implement that itself). Also included
36 ;; is a sample pretty-printer which MUAs can use which do not provide their
37 ;; own vcard formatters.
39 ;; This library does not interface directly with any mail user agents. For
40 ;; an example of bindings for the VM MUA, see vm-vcard.el available from
42 ;; http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
44 ;; Updates to vcard.el should be available there too.
46 ;; The main entry point to this package is `vcard-pretty-print' although
47 ;; any documented variable or function is considered part of the API for
48 ;; operating on vcard data.
50 ;; The vcard 2.1 format is defined by the versit consortium.
51 ;; See http://www.imc.org/pdi/vcard-21.ps
53 ;; RFC 2426 defines the vcard 3.0 format.
54 ;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
56 ;; A parsed vcard is a list of attributes of the form
58 ;; (proplist value1 value2 ...)
60 ;; Where proplist is a list of property names and parameters, e.g.
62 ;; (property1 (property2 . parameter2) ...)
64 ;; Each property has an associated implicit or explicit parameter value
65 ;; (not to be confused with attribute values; in general this API uses
66 ;; `parameter' to refer to property values and `value' to refer to attribute
67 ;; values to avoid confusion). If a property has no explicit parameter value,
68 ;; the parameter value is considered to be `t'. Any property which does not
69 ;; exist for an attribute is considered to have a nil parameter.
72 ;; * Finish supporting the 3.0 extensions.
73 ;; Currently, only the 2.1 standard is supported.
74 ;; * Handle nested vcards and grouped attributes?
75 ;; (I've never actually seen one of these in use.)
76 ;; * Handle multibyte charsets.
77 ;; * Inverse of vcard-parse-string: write .VCF files from alist
78 ;; * Implement a vcard address book? Or is using BBDB preferable?
79 ;; * Improve the sample formatter.
84 "Support for the vCard electronic business card format."
90 (defcustom vcard-pretty-print-function 'vcard-format-sample-box
91 "*Formatting function used by `vcard-pretty-print'."
96 (defcustom vcard-standard-filters
98 vcard-filter-adr-newlines
99 vcard-filter-tel-normalize
100 vcard-filter-textprop-cr)
101 "*Standard list of filters to apply to parsed vcard data.
102 These filters are applied sequentially to vcard attributes when
103 the function `vcard-standard-filter' is supplied as the second argument to
109 ;;; No user-settable options below.
111 ;; XEmacs 21 ints and chars are disjoint types.
112 ;; For all else, treat them as the same.
113 (defalias 'vcard-char-to-int
114 (if (fboundp 'char-to-int) 'char-to-int 'identity))
116 ;; This is just the version number for this package; it does not refer to
117 ;; the vcard format specification. Currently, this package does not yet
118 ;; support the full vcard 3.0 specification.
120 ;; Whenever any part of the API defined in this package change in a way
121 ;; that is not backward-compatible, the major version number here should be
122 ;; incremented. Backward-compatible additions to the API should be
123 ;; indicated by increasing the minor version number.
124 (defconst vcard-api-version "2.0")
126 ;; The vcard standards allow specifying the encoding for an attribute using
127 ;; these values as immediate property names, rather than parameters of the
128 ;; `encoding' property. If these are encountered while parsing, associate
129 ;; them as parameters of the `encoding' property in the returned structure.
130 (defvar vcard-encoding-tags
131 '("quoted-printable" "base64" "8bit" "7bit"))
133 ;; The vcard parser will auto-decode these encodings when they are
134 ;; encountered. These methods are invoked via vcard-parse-region-value.
135 (defvar vcard-region-decoder-methods
136 '(("quoted-printable" . vcard-region-decode-quoted-printable)
137 ("base64" . vcard-region-decode-base64)))
139 ;; This is used by vcard-region-decode-base64
140 (defvar vcard-region-decode-base64-table
141 (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
143 (tbl (make-vector 123 nil))
146 (aset tbl (vcard-char-to-int (aref a i)) i)
151 ;;; This function can be used generically by applications to obtain
152 ;;; a printable representation of a vcard.
155 (defun vcard-pretty-print (vcard)
156 "Format VCARD into a string suitable for display to user.
157 VCARD can be an unparsed string containing raw VCF vcard data
158 or a parsed vcard alist as returned by `vcard-parse-string'.
160 The result is a string with formatted vcard information suitable for
161 insertion into a mime presentation buffer.
163 The function specified by the variable `vcard-pretty-print-function'
164 actually performs the formatting. That function will always receive a
167 (setq vcard (vcard-parse-string vcard)))
168 (funcall vcard-pretty-print-function vcard))
174 (defun vcard-parse-string (raw &optional filter)
175 "Parse RAW vcard data as a string, and return an alist representing data.
177 If the optional function FILTER is specified, apply that filter to each
178 attribute. If no filter is specified, `vcard-standard-filter' is used.
180 Filters should accept two arguments: the property list and the value list.
181 Modifying in place the property or value list will affect the resulting
182 attribute in the vcard alist.
184 Vcard data is normally in the form
188 prop2a;prop2b;prop2c=param2c: value2a
189 prop3a;prop3b: value3a;value3b;value3c
192 \(Whitespace around the `:' separating properties and values is optional.\)
193 If supplied to this function an alist of the form
195 \(\(\(\"prop1a\"\) \"value1a\"\)
196 \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
197 \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
201 (buf (generate-new-buffer " *vcard parser work*")))
205 ;; Make sure last line is newline-terminated.
206 ;; An extra trailing newline is harmless.
208 (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
213 (defun vcard-parse-region (beg end &optional filter)
214 "Parse the raw vcard data in region, and return an alist representing data.
215 This function is just like `vcard-parse-string' except that it operates on
216 a region of the current buffer rather than taking a string as an argument.
218 Note: this function modifies the buffer!"
220 (setq filter 'vcard-standard-filter))
221 (let ((case-fold-search t)
224 (newpos (make-marker))
227 (narrow-to-region beg end)
229 ;; Unfold folded lines and delete naked carriage returns
230 (goto-char (point-min))
231 (while (re-search-forward "\r$\\|\n[ \t]" nil t)
232 (goto-char (match-beginning 0))
235 (goto-char (point-min))
236 (re-search-forward "^begin:[ \t]*vcard[ \t]*\n")
237 (set-marker pos (point))
238 (while (and (not (looking-at "^end[ \t]*:[ \t]*vcard[ \t]*$"))
239 (re-search-forward ":[ \t]*" nil t))
240 (set-marker newpos (match-end 0))
242 (vcard-parse-region-properties pos (match-beginning 0)))
243 (set-marker pos (marker-position newpos))
244 (re-search-forward "[ \t]*\n")
245 (set-marker newpos (match-end 0))
247 (vcard-parse-region-value properties pos (match-beginning 0)))
248 (set-marker pos (marker-position newpos))
250 (funcall filter properties value)
251 (setq vcard-data (cons (cons properties value) vcard-data)))))
252 (nreverse vcard-data)))
254 (defun vcard-parse-region-properties (beg end)
255 (downcase-region beg end)
256 (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
261 (cond ((string-match "=" (car props))
262 (setq split (vcard-split-string (car props) "=" 2))
263 (setcar props (cons (car split) (car (cdr split)))))
264 ((member (car props) vcard-encoding-tags)
265 (setcar props (cons "encoding" (car props)))))
266 (setq props (cdr props))))
269 (defun vcard-parse-region-value (proplist beg end)
270 (let* ((encoding (vcard-get-property proplist "encoding"))
271 (decoder (cdr (assoc encoding vcard-region-decoder-methods)))
272 result pos match-beg match-end)
274 (narrow-to-region beg end)
276 ;; Each `;'-separated field needs to be decoded and saved
277 ;; separately; if the entire region were decoded at once, we
278 ;; would not be able to distinguish between the original `;'
279 ;; chars and those which were encoded in order to quote them
280 ;; against being treated as field separators.
282 (setq pos (set-marker (make-marker) (point)))
283 (setq match-beg (make-marker))
284 (setq match-end (make-marker))
286 (while (< pos (point-max))
287 (cond ((search-forward ";" nil t)
288 (set-marker match-beg (match-beginning 0))
289 (set-marker match-end (match-end 0)))
291 (set-marker match-beg (point-max))
292 (set-marker match-end (point-max))))
293 (funcall decoder pos match-beg)
294 (setq result (cons (buffer-substring pos match-beg) result))
295 (set-marker pos (marker-position match-end))))
296 (setq result (nreverse result))
297 (vcard-set-property proplist "encoding" nil))
299 (setq result (vcard-split-string (buffer-string) ";")))))
300 (goto-char (point-max))
304 ;;; Functions for retrieving property or value information from parsed
305 ;;; vcard attributes.
307 (defun vcard-values (vcard have-props &optional non-props limit)
308 "Return the values in VCARD.
309 This function is like `vcard-ref' and takes the same arguments, but return
310 only the values, not the associated property lists."
311 (mapcar 'cdr (vcard-ref vcard have-props non-props limit)))
313 (defun vcard-ref (vcard have-props &optional non-props limit)
314 "Return the attributes in VCARD with HAVE-PROPS properties.
315 Optional arg NON-PROPS is a list of properties which candidate attributes
317 Optional arg LIMIT means return no more than that many attributes.
319 The attributes in VCARD which have all properties specified by HAVE-PROPS
320 but not having any specified by NON-PROPS are returned. The first element
321 of each attribute is the actual property list; the remaining elements are
324 If a specific property has an associated parameter \(e.g. an encoding\),
325 use the syntax \(\"property\" . \"parameter\"\) to specify it. If property
326 parameter is not important or it has no specific parameter, just specify
327 the property name as a string."
331 (while (and attrs (or (null limit) (< count limit)))
332 (and (vcard-proplist-all-properties (car (car attrs)) have-props)
333 (not (vcard-proplist-any-properties (car (car attrs)) non-props))
334 (setq result (cons (car attrs) result)
336 (setq attrs (cdr attrs)))
339 (defun vcard-proplist-all-properties (proplist props)
340 "Returns nil unless PROPLIST contains all properties specified in PROPS."
342 (while (and result props)
343 (or (vcard-get-property proplist (car props))
345 (setq props (cdr props)))
348 (defun vcard-proplist-any-properties (proplist props)
349 "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
351 (while (and (not result) props)
352 (and (vcard-get-property proplist (car props))
354 (setq props (cdr props)))
357 (defun vcard-get-property (proplist property)
358 "Return the value from PROPLIST of PROPERTY.
359 PROPLIST is a vcard attribute property list, which is normally the first
360 element of each attribute entry in a vcard."
361 (or (and (member property proplist) t)
362 (cdr (assoc property proplist))))
364 (defun vcard-set-property (proplist property value)
365 "In PROPLIST, set PROPERTY to VALUE.
366 PROPLIST is a vcard attribute property list.
367 If VALUE is nil, PROPERTY is deleted."
370 (vcard-delete-property proplist property))
371 ((setq elt (member property proplist))
372 (and value (not (eq value t))
373 (setcar elt (cons property value))))
374 ((setq elt (assoc property proplist))
376 (setq elt (memq elt proplist))
377 (setcar elt property))
379 (setcdr elt value))))
381 (nconc proplist (cons property nil)))
383 (nconc proplist (cons (cons property value) nil))))))
385 (defun vcard-delete-property (proplist property)
386 "Delete from PROPLIST the specified property PROPERTY.
387 This will not succeed in deleting the first member of the proplist, but
388 that element should never be deleted since it is the primary key."
390 (cond ((setq elt (member property proplist))
391 (delq (car elt) proplist))
392 ((setq elt (assoc property proplist))
393 (delq (car (memq elt proplist)) proplist)))))
396 ;;; Vcard data filters.
398 ;;; Filters receive both the property list and value list and may modify
399 ;;; either in-place. The return value from the filters are ignored.
401 ;;; These filters can be used for purposes such as removing HTML tags or
402 ;;; normalizing phone numbers into a standard form.
404 (defun vcard-standard-filter (proplist values)
405 "Apply filters in `vcard-standard-filters' to attributes."
406 (vcard-filter-apply-filter-list vcard-standard-filters proplist values))
408 ;; This function could be used to dispatch other filter lists.
409 (defun vcard-filter-apply-filter-list (filter-list proplist values)
411 (funcall (car filter-list) proplist values)
412 (setq filter-list (cdr filter-list))))
414 ;; Some lusers put HTML (or even javascript!) in their vcards under the
415 ;; misguided notion that it's a standard feature of vcards just because
416 ;; Netscape supports this feature. That is wrong; the vcard specification
417 ;; does not define any html content semantics and most MUAs cannot do
418 ;; anything with html text except display them unparsed, which is ugly.
420 ;; Thank Netscape for abusing the standard and damned near rendering it
421 ;; useless for interoperability between MUAs.
423 ;; This filter does a very rudimentary job.
424 (defun vcard-filter-html (proplist values)
425 "Remove HTML tags from attribute values."
428 (while (string-match "<[^<>\n]+>" (car values))
429 (setcar values (replace-match "" t t (car values))))
430 (setq values (cdr values)))))
432 (defun vcard-filter-adr-newlines (proplist values)
433 "Replace newlines with \"; \" in `adr' values."
434 (and (vcard-get-property proplist "adr")
437 (while (string-match "[\r\n]+" (car values))
438 (setcar values (replace-match "; " t t (car values))))
439 (setq values (cdr values))))))
441 (defun vcard-filter-tel-normalize (proplist values)
442 "Normalize telephone numbers in `tel' values.
443 Spaces and hyphens are replaced with `.'.
444 US domestic telephone numbers are replaced with international format."
445 (and (vcard-get-property proplist "tel")
448 (while (string-match "[\t._-]+" (car values))
449 (setcar values (replace-match " " t t (car values))))
450 (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\
451 \\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)"
454 (replace-match "+1 \\1 \\2" t nil (car values))))
455 (setq values (cdr values))))))
457 (defun vcard-filter-textprop-cr (proplist values)
458 "Strip carriage returns from text values."
459 (and (vcard-proplist-any-properties
460 proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url"))
463 (while (string-match "\r+" (car values))
464 (setcar values (replace-match "" t t (car values))))
465 (setq values (cdr values))))))
468 ;;; Decoding methods.
470 (defmacro vcard-hexstring-to-ascii (s)
471 (if (string-lessp emacs-version "20")
472 `(format "%c" (car (read-from-string (format "?\\x%s" ,s))))
473 `(format "%c" (string-to-number ,s 16))))
475 (defun vcard-region-decode-quoted-printable (&optional beg end)
479 (narrow-to-region (or beg (point-min)) (or end (point-max)))
480 (goto-char (point-min))
481 (while (re-search-forward "=\n" nil t)
482 (delete-region (match-beginning 0) (match-end 0)))
483 (goto-char (point-min))
484 (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t)
485 (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0))))
486 (replace-match (vcard-hexstring-to-ascii s) t t)))))))
488 (defun vcard-region-decode-base64 (&optional beg end)
490 (narrow-to-region (or beg (point-min)) (or end (point-max)))
492 (goto-char (point-min))
493 (while (re-search-forward "[ \t\r\n]+" nil t)
494 (delete-region (match-beginning 0) (match-end 0))))
495 (goto-char (point-min))
500 (setq c (char-after (point)))
502 (cond ((char-equal c ?=)
506 (insert (lsh n -16) (logand 255 (lsh n -8))))
507 (delete-region (point) (point-max)))
509 (setq n (+ n (aref vcard-region-decode-base64-table
510 (vcard-char-to-int c))))
511 (setq count (1+ count))
513 (insert (logand 255 (lsh n -16))
514 (logand 255 (lsh n -8))
518 (setq n (lsh n 6))))))))))
521 (defun vcard-split-string (string &optional separator limit)
522 "Split STRING at occurences of SEPARATOR. Return a list of substrings.
523 Optional argument SEPARATOR can be any regexp, but anything matching the
524 separator will never appear in any of the returned substrings.
525 If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\".
526 If optional arg LIMIT is specified, split into no more than that many
527 fields \(though it may split into fewer\)."
528 (or separator (setq separator "[ \f\t\n\r\v]+"))
529 (let ((string-list nil)
530 (len (length string))
536 (setq splits (1+ splits))
539 (setq str (substring string pos))
541 ((string-match separator string pos)
542 (setq str (substring string pos (match-beginning 0)))
543 (setq pos (match-end 0)))
545 (setq str (substring string pos))
546 (setq pos (1+ len))))
547 (setq string-list (cons str string-list))))
548 (nreverse string-list)))
550 (defun vcard-copy-tree (tree)
551 "Make a deep copy of nested conses."
554 (cons (vcard-copy-tree (car tree))
555 (vcard-copy-tree (cdr tree))))
558 (defun vcard-flatten (l)
560 (apply 'nconc (mapcar 'vcard-flatten l))
564 ;;; Sample formatting routines.
566 (defun vcard-format-sample-box (vcard)
567 "Like `vcard-format-sample-string', but put an ascii box around text."
568 (let* ((lines (vcard-format-sample-lines vcard))
569 (len (vcard-format-sample-max-length lines))
570 (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
571 (line-fmt (format "| %%-%ds |" len))
573 (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
574 (if (string= formatted-lines "")
576 (concat edge formatted-lines edge))))
578 (defun vcard-format-sample-string (vcard)
579 "Format VCARD into a string suitable for display to user.
580 VCARD should be a parsed vcard alist. The result is a string
581 with formatted vcard information which can be inserted into a mime
582 presentation buffer."
583 (mapconcat 'identity (vcard-format-sample-lines vcard) "\n"))
585 (defun vcard-format-sample-lines (vcard)
586 (let* ((name (vcard-format-sample-get-name vcard))
587 (title (vcard-format-sample-values-concat vcard '("title") 1 "; "))
588 (org (vcard-format-sample-values-concat vcard '("org") 1 "; "))
589 (addr (vcard-format-sample-get-address vcard))
590 (tel (vcard-format-sample-get-telephone vcard))
591 (lines (delete nil (vcard-flatten (list name title org addr))))
592 (col-template (format "%%-%ds%%s"
593 (vcard-format-sample-offset lines tel)))
596 (setcar l (format col-template (car l) (car tel)))
597 ;; If we stripped away too many nil slots from l, add empty strings
598 ;; back in so setcar above will work on next iteration.
601 (setcdr l (cons "" nil)))
603 (setq tel (cdr tel)))
606 (defun vcard-format-sample-get-name (vcard)
607 (let ((name (car (car (vcard-values vcard '("fn") nil 1))))
608 (email (car (vcard-format-sample-values
609 vcard '((("email" "pref"))
610 (("email" "internet"))
612 (cond ((and name email)
613 (format "%s <%s>" name email))
618 (defun vcard-format-sample-get-telephone (vcard)
619 (let ((fields '(("Work: "
620 (("tel" "work" "pref") . ("fax" "pager" "cell"))
621 (("tel" "work" "voice") . ("fax" "pager" "cell"))
622 (("tel" "work") . ("fax" "pager" "cell")))
624 (("tel" "home" "pref") . ("fax" "pager" "cell"))
625 (("tel" "home" "voice") . ("fax" "pager" "cell"))
626 (("tel" "home") . ("fax" "pager" "cell"))
627 (("tel") . ("fax" "pager" "cell" "work")))
629 (("tel" "cell" "pref"))
632 (("tel" "pref" "fax"))
633 (("tel" "work" "fax"))
634 (("tel" "home" "fax"))
639 (setq result (vcard-format-sample-values vcard (cdr (car fields))))
642 (cons (concat (car (car fields)) (car (car result))) phones))
643 (setq result (cdr result)))
644 (setq fields (cdr fields)))
647 (defun vcard-format-sample-get-address (vcard)
648 (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work"))
652 (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
653 (city-list (delete "" (nthcdr 3 addr)))
654 (city (cond ((null (car city-list)) nil)
658 (mapconcat 'identity (cdr city-list) " ")))
659 (t (car city-list)))))
661 (append street (list city))
664 (defun vcard-format-sample-values-concat (vcard have-props limit sep)
665 (let ((l (car (vcard-values vcard have-props nil limit))))
666 (and l (mapconcat 'identity (delete "" (vcard-copy-tree l)) sep))))
668 (defun vcard-format-sample-values (vcard proplists &optional limit)
669 (let ((result (vcard-format-sample-ref vcard proplists limit)))
672 (mapcar 'cdr result))))
674 (defun vcard-format-sample-ref (vcard proplists &optional limit)
676 (while (and (null result) proplists)
677 (setq result (vcard-ref vcard
678 (car (car proplists))
679 (cdr (car proplists))
681 (setq proplists (cdr proplists)))
683 (vcard-copy-tree (car result))
684 (vcard-copy-tree result))))
686 (defun vcard-format-sample-offset (row1 row2 &optional maxwidth)
687 (or maxwidth (setq maxwidth (frame-width)))
688 (let ((max1 (vcard-format-sample-max-length row1))
689 (max2 (vcard-format-sample-max-length row2)))
692 (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2))))))))
694 (defun vcard-format-sample-max-length (strings)
697 (setq maxlen (max maxlen (length (car strings))))
698 (setq strings (cdr strings)))
703 ;;; vcard.el ends here