cgit.sxemacs.org Git - gnus/blob - contrib/vcard.el

   1 ;;; vcard.el --- vcard parsing and display routines
   2
   3 ;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman
   4
   5 ;; Author: Noah Friedman <friedman@splode.com>
   6 ;; Maintainer: friedman@splode.com
   7 ;; Keywords: vcard, mail, news
   8 ;; Created: 1997-09-27
   9
  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
  12
  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)
  16 ;; any later version.
  17 ;;
  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.
  22 ;;
  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/>.
  25
  26 ;;; Commentary:
  27
  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.
  32 ;;
  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.
  38
  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
  41 ;;
  42 ;;    http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
  43 ;;
  44 ;; Updates to vcard.el should be available there too.
  45
  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.
  49
  50 ;; The vcard 2.1 format is defined by the versit consortium.
  51 ;; See http://www.imc.org/pdi/vcard-21.ps
  52 ;;
  53 ;; RFC 2426 defines the vcard 3.0 format.
  54 ;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
  55
  56 ;; A parsed vcard is a list of attributes of the form
  57 ;;
  58 ;;     (proplist value1 value2 ...)
  59 ;;
  60 ;; Where proplist is a list of property names and parameters, e.g.
  61 ;;
  62 ;;     (property1 (property2 . parameter2) ...)
  63 ;;
  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.
  70
  71 ;; TODO:
  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.
  80
  81 ;;; Code:
  82
  83 (defgroup vcard nil
  84   "Support for the vCard electronic business card format."
  85   :group 'vcard
  86   :group 'mail
  87   :group 'news)
  88
  89 ;;;###autoload
  90 (defcustom vcard-pretty-print-function 'vcard-format-sample-box
  91   "*Formatting function used by `vcard-pretty-print'."
  92   :type 'function
  93   :group 'vcard)
  94
  95 ;;;###autoload
  96 (defcustom vcard-standard-filters
  97   '(vcard-filter-html
  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
 104 `vcard-parse'."
 105   :type 'hook
 106   :group 'vcard)
 107
 108 \f
 109 ;;; No user-settable options below.
 110
 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))
 115
 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.
 119 ;;
 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")
 125
 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"))
 132
 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)))
 138
 139 ;; This is used by vcard-region-decode-base64
 140 (defvar vcard-region-decode-base64-table
 141   (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
 142          (len (length a))
 143          (tbl (make-vector 123 nil))
 144          (i 0))
 145     (while (< i len)
 146       (aset tbl (vcard-char-to-int (aref a i)) i)
 147       (setq i (1+ i)))
 148     tbl))
 149
 150 \f
 151 ;;; This function can be used generically by applications to obtain
 152 ;;; a printable representation of a vcard.
 153
 154 ;;;###autoload
 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'.
 159
 160 The result is a string with formatted vcard information suitable for
 161 insertion into a mime presentation buffer.
 162
 163 The function specified by the variable `vcard-pretty-print-function'
 164 actually performs the formatting.  That function will always receive a
 165 parsed vcard alist."
 166   (and (stringp vcard)
 167        (setq vcard (vcard-parse-string vcard)))
 168   (funcall vcard-pretty-print-function vcard))
 169
 170 \f
 171 ;;; Parsing routines
 172
 173 ;;;###autoload
 174 (defun vcard-parse-string (raw &optional filter)
 175   "Parse RAW vcard data as a string, and return an alist representing data.
 176
 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.
 179
 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.
 183
 184 Vcard data is normally in the form
 185
 186     begin:                        vcard
 187     prop1a:                       value1a
 188     prop2a;prop2b;prop2c=param2c: value2a
 189     prop3a;prop3b:                value3a;value3b;value3c
 190     end:                          vcard
 191
 192 \(Whitespace around the `:' separating properties and values is optional.\)
 193 If supplied to this function an alist of the form
 194
 195     \(\(\(\"prop1a\"\) \"value1a\"\)
 196      \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
 197      \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
 198
 199 would be returned."
 200   (let ((vcard nil)
 201         (buf (generate-new-buffer " *vcard parser work*")))
 202     (unwind-protect
 203         (save-excursion
 204           (set-buffer buf)
 205           ;; Make sure last line is newline-terminated.
 206           ;; An extra trailing newline is harmless.
 207           (insert raw "\n")
 208           (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
 209       (kill-buffer buf))
 210     vcard))
 211
 212 ;;;###autoload
 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.
 217
 218 Note: this function modifies the buffer!"
 219   (or filter
 220       (setq filter 'vcard-standard-filter))
 221   (let ((case-fold-search t)
 222         (vcard-data nil)
 223         (pos (make-marker))
 224         (newpos (make-marker))
 225         properties value)
 226     (save-restriction
 227       (narrow-to-region beg end)
 228       (save-match-data
 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))
 233           (delete-char 1))
 234
 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))
 241           (setq properties
 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))
 246           (setq value
 247                 (vcard-parse-region-value properties pos (match-beginning 0)))
 248           (set-marker pos (marker-position newpos))
 249           (goto-char pos)
 250           (funcall filter properties value)
 251           (setq vcard-data (cons (cons properties value) vcard-data)))))
 252     (nreverse vcard-data)))
 253
 254 (defun vcard-parse-region-properties (beg end)
 255   (downcase-region beg end)
 256   (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
 257          (props proplist)
 258          split)
 259     (save-match-data
 260       (while props
 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))))
 267     proplist))
 268
 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)
 273     (save-restriction
 274       (narrow-to-region beg end)
 275       (cond (decoder
 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.
 281              (goto-char beg)
 282              (setq pos (set-marker (make-marker) (point)))
 283              (setq match-beg (make-marker))
 284              (setq match-end (make-marker))
 285              (save-match-data
 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)))
 290                        (t
 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))
 298             (t
 299              (setq result (vcard-split-string (buffer-string) ";")))))
 300     (goto-char (point-max))
 301     result))
 302
 303 \f
 304 ;;; Functions for retrieving property or value information from parsed
 305 ;;; vcard attributes.
 306
 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)))
 312
 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
 316 must not have.
 317 Optional arg LIMIT means return no more than that many attributes.
 318
 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
 322 the values.
 323
 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."
 328   (let ((attrs vcard)
 329         (result nil)
 330         (count 0))
 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)
 335                  count (1+ count)))
 336       (setq attrs (cdr attrs)))
 337     (nreverse result)))
 338
 339 (defun vcard-proplist-all-properties (proplist props)
 340   "Returns nil unless PROPLIST contains all properties specified in PROPS."
 341   (let ((result t))
 342     (while (and result props)
 343       (or (vcard-get-property proplist (car props))
 344           (setq result nil))
 345       (setq props (cdr props)))
 346     result))
 347
 348 (defun vcard-proplist-any-properties (proplist props)
 349   "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
 350   (let ((result nil))
 351     (while (and (not result) props)
 352       (and (vcard-get-property proplist (car props))
 353            (setq result t))
 354       (setq props (cdr props)))
 355     result))
 356
 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))))
 363
 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."
 368   (let (elt)
 369     (cond ((null value)
 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))
 375            (cond ((eq value t)
 376                   (setq elt (memq elt proplist))
 377                   (setcar elt property))
 378                  (t
 379                   (setcdr elt value))))
 380           ((eq value t)
 381            (nconc proplist (cons property nil)))
 382           (t
 383            (nconc proplist (cons (cons property value) nil))))))
 384
 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."
 389   (let (elt)
 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)))))
 394
 395 \f
 396 ;;; Vcard data filters.
 397 ;;;
 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.
 400 ;;;
 401 ;;; These filters can be used for purposes such as removing HTML tags or
 402 ;;; normalizing phone numbers into a standard form.
 403
 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))
 407
 408 ;; This function could be used to dispatch other filter lists.
 409 (defun vcard-filter-apply-filter-list (filter-list proplist values)
 410   (while filter-list
 411     (funcall (car filter-list) proplist values)
 412     (setq filter-list (cdr filter-list))))
 413
 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.
 419 ;;
 420 ;; Thank Netscape for abusing the standard and damned near rendering it
 421 ;; useless for interoperability between MUAs.
 422 ;;
 423 ;; This filter does a very rudimentary job.
 424 (defun vcard-filter-html (proplist values)
 425   "Remove HTML tags from attribute values."
 426   (save-match-data
 427     (while values
 428       (while (string-match "<[^<>\n]+>" (car values))
 429         (setcar values (replace-match "" t t (car values))))
 430       (setq values (cdr values)))))
 431
 432 (defun vcard-filter-adr-newlines (proplist values)
 433   "Replace newlines with \"; \" in `adr' values."
 434   (and (vcard-get-property proplist "adr")
 435        (save-match-data
 436          (while values
 437            (while (string-match "[\r\n]+" (car values))
 438              (setcar values (replace-match "; " t t (car values))))
 439            (setq values (cdr values))))))
 440
 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")
 446        (save-match-data
 447          (while values
 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-\\)"
 452                               (car values))
 453                 (setcar values
 454                         (replace-match "+1 \\1 \\2" t nil (car values))))
 455            (setq values (cdr values))))))
 456
 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"))
 461        (save-match-data
 462          (while values
 463            (while (string-match "\r+" (car values))
 464              (setcar values (replace-match "" t t (car values))))
 465            (setq values (cdr values))))))
 466
 467 \f
 468 ;;; Decoding methods.
 469
 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))))
 474
 475 (defun vcard-region-decode-quoted-printable (&optional beg end)
 476   (save-excursion
 477     (save-restriction
 478       (save-match-data
 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)))))))
 487
 488 (defun vcard-region-decode-base64 (&optional beg end)
 489   (save-restriction
 490     (narrow-to-region (or beg (point-min)) (or end (point-max)))
 491     (save-match-data
 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))
 496     (let ((count 0)
 497           (n 0)
 498           (c nil))
 499       (while (not (eobp))
 500         (setq c (char-after (point)))
 501         (delete-char 1)
 502         (cond ((char-equal c ?=)
 503                (if (= count 2)
 504                    (insert (lsh n -10))
 505                  ;; count must be 3
 506                  (insert (lsh n -16) (logand 255 (lsh n -8))))
 507                (delete-region (point) (point-max)))
 508               (t
 509                (setq n (+ n (aref vcard-region-decode-base64-table
 510                                   (vcard-char-to-int c))))
 511                (setq count (1+ count))
 512                (cond ((= count 4)
 513                       (insert (logand 255 (lsh n -16))
 514                               (logand 255 (lsh n -8))
 515                               (logand 255 n))
 516                       (setq n 0 count 0))
 517                      (t
 518                       (setq n (lsh n 6))))))))))
 519
 520 \f
 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))
 531         (pos 0)
 532         (splits 0)
 533         str)
 534     (save-match-data
 535       (while (<= pos len)
 536         (setq splits (1+ splits))
 537         (cond ((and limit
 538                     (>= splits limit))
 539                (setq str (substring string pos))
 540                (setq pos (1+ len)))
 541               ((string-match separator string pos)
 542                (setq str (substring string pos (match-beginning 0)))
 543                (setq pos (match-end 0)))
 544               (t
 545                (setq str (substring string pos))
 546                (setq pos (1+ len))))
 547         (setq string-list (cons str string-list))))
 548     (nreverse string-list)))
 549
 550 (defun vcard-copy-tree (tree)
 551   "Make a deep copy of nested conses."
 552   (cond
 553    ((consp tree)
 554     (cons (vcard-copy-tree (car tree))
 555           (vcard-copy-tree (cdr tree))))
 556    (t tree)))
 557
 558 (defun vcard-flatten (l)
 559   (if (consp l)
 560       (apply 'nconc (mapcar 'vcard-flatten l))
 561     (list l)))
 562
 563 \f
 564 ;;; Sample formatting routines.
 565
 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))
 572          (formatted-lines
 573           (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
 574     (if (string= formatted-lines "")
 575         formatted-lines
 576       (concat edge formatted-lines edge))))
 577
 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"))
 584
 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)))
 594          (l lines))
 595     (while 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.
 599       (and (cdr tel)
 600            (null (cdr l))
 601            (setcdr l (cons "" nil)))
 602       (setq l (cdr l))
 603       (setq tel (cdr tel)))
 604     lines))
 605
 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"))
 611                              (("email"))) 1))))
 612     (cond ((and name email)
 613            (format "%s <%s>" name email))
 614           (email)
 615           (name)
 616           (""))))
 617
 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")))
 623                   ("Home: "
 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")))
 628                   ("Cell: "
 629                    (("tel" "cell" "pref"))
 630                    (("tel" "cell")))
 631                   ("Fax:  "
 632                    (("tel" "pref" "fax"))
 633                    (("tel" "work" "fax"))
 634                    (("tel" "home" "fax"))
 635                    (("tel" "fax")))))
 636         (phones nil)
 637         result)
 638     (while fields
 639       (setq result (vcard-format-sample-values vcard (cdr (car fields))))
 640       (while result
 641         (setq phones
 642               (cons (concat (car (car fields)) (car (car result))) phones))
 643         (setq result (cdr result)))
 644       (setq fields (cdr fields)))
 645     (nreverse phones)))
 646
 647 (defun vcard-format-sample-get-address (vcard)
 648   (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work"))
 649                                                    (("adr" "pref"))
 650                                                    (("adr" "work"))
 651                                                    (("adr"))) 1))
 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)
 655                      ((cdr city-list)
 656                       (format "%s, %s"
 657                               (car city-list)
 658                               (mapconcat 'identity (cdr city-list) " ")))
 659                      (t (car city-list)))))
 660     (delete nil (if city
 661                     (append street (list city))
 662                   street))))
 663
 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))))
 667
 668 (defun vcard-format-sample-values (vcard proplists &optional limit)
 669   (let ((result (vcard-format-sample-ref vcard proplists limit)))
 670     (if (equal limit 1)
 671         (cdr result)
 672       (mapcar 'cdr result))))
 673
 674 (defun vcard-format-sample-ref (vcard proplists &optional limit)
 675   (let ((result nil))
 676     (while (and (null result) proplists)
 677       (setq result (vcard-ref vcard
 678                               (car (car proplists))
 679                               (cdr (car proplists))
 680                               limit))
 681       (setq proplists (cdr proplists)))
 682     (if (equal limit 1)
 683         (vcard-copy-tree (car result))
 684       (vcard-copy-tree result))))
 685
 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)))
 690     (if (zerop max1)
 691         0
 692       (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2))))))))
 693
 694 (defun vcard-format-sample-max-length (strings)
 695   (let ((maxlen 0))
 696     (while strings
 697       (setq maxlen (max maxlen (length (car strings))))
 698       (setq strings (cdr strings)))
 699     maxlen))
 700
 701 (provide 'vcard)
 702
 703 ;;; vcard.el ends here