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, you can either send email to this
  25 ;; program's maintainer or write to: The Free Software Foundation,
  26 ;; Inc.; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Unformatted vcards are just plain ugly.  But if you live in the MIME
  31 ;; world, they are a better way of exchanging contact information than
  32 ;; freeform signatures since the former can be automatically parsed and
  33 ;; stored in a searchable index.
  34 ;;
  35 ;; This library of routines provides the back end necessary for parsing
  36 ;; vcards so that they can eventually go into an address book like BBDB
  37 ;; (although this library does not implement that itself).  Also included
  38 ;; is a sample pretty-printer which MUAs can use which do not provide their
  39 ;; own vcard formatters.
  40
  41 ;; This library does not interface directly with any mail user agents.  For
  42 ;; an example of bindings for the VM MUA, see vm-vcard.el available from
  43 ;;
  44 ;;    http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
  45 ;;
  46 ;; Updates to vcard.el should be available there too.
  47
  48 ;; The main entry point to this package is `vcard-pretty-print' although
  49 ;; any documented variable or function is considered part of the API for
  50 ;; operating on vcard data.
  51
  52 ;; The vcard 2.1 format is defined by the versit consortium.
  53 ;; See http://www.imc.org/pdi/vcard-21.ps
  54 ;;
  55 ;; RFC 2426 defines the vcard 3.0 format.
  56 ;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
  57
  58 ;; A parsed vcard is a list of attributes of the form
  59 ;;
  60 ;;     (proplist value1 value2 ...)
  61 ;;
  62 ;; Where proplist is a list of property names and parameters, e.g.
  63 ;;
  64 ;;     (property1 (property2 . parameter2) ...)
  65 ;;
  66 ;; Each property has an associated implicit or explicit parameter value
  67 ;; (not to be confused with attribute values; in general this API uses
  68 ;; `parameter' to refer to property values and `value' to refer to attribute
  69 ;; values to avoid confusion).  If a property has no explicit parameter value,
  70 ;; the parameter value is considered to be `t'.  Any property which does not
  71 ;; exist for an attribute is considered to have a nil parameter.
  72
  73 ;; TODO:
  74 ;;   * Finish supporting the 3.0 extensions.
  75 ;;     Currently, only the 2.1 standard is supported.
  76 ;;   * Handle nested vcards and grouped attributes?
  77 ;;     (I've never actually seen one of these in use.)
  78 ;;   * Handle multibyte charsets.
  79 ;;   * Inverse of vcard-parse-string: write .VCF files from alist
  80 ;;   * Implement a vcard address book?  Or is using BBDB preferable?
  81 ;;   * Improve the sample formatter.
  82
  83 ;;; Code:
  84
  85 (defgroup vcard nil
  86   "Support for the vCard electronic business card format."
  87   :group 'vcard
  88   :group 'mail
  89   :group 'news)
  90
  91 ;;;###autoload
  92 (defcustom vcard-pretty-print-function 'vcard-format-sample-box
  93   "*Formatting function used by `vcard-pretty-print'."
  94   :type 'function
  95   :group 'vcard)
  96
  97 ;;;###autoload
  98 (defcustom vcard-standard-filters
  99   '(vcard-filter-html
 100     vcard-filter-adr-newlines
 101     vcard-filter-tel-normalize
 102     vcard-filter-textprop-cr)
 103   "*Standard list of filters to apply to parsed vcard data.
 104 These filters are applied sequentially to vcard attributes when
 105 the function `vcard-standard-filter' is supplied as the second argument to
 106 `vcard-parse'."
 107   :type 'hook
 108   :group 'vcard)
 109
 110 \f
 111 ;;; No user-settable options below.
 112
 113 ;; XEmacs 21 ints and chars are disjoint types.
 114 ;; For all else, treat them as the same.
 115 (defalias 'vcard-char-to-int
 116   (if (fboundp 'char-to-int) 'char-to-int 'identity))
 117
 118 ;; This is just the version number for this package; it does not refer to
 119 ;; the vcard format specification.  Currently, this package does not yet
 120 ;; support the full vcard 3.0 specification.
 121 ;;
 122 ;; Whenever any part of the API defined in this package change in a way
 123 ;; that is not backward-compatible, the major version number here should be
 124 ;; incremented.  Backward-compatible additions to the API should be
 125 ;; indicated by increasing the minor version number.
 126 (defconst vcard-api-version "2.0")
 127
 128 ;; The vcard standards allow specifying the encoding for an attribute using
 129 ;; these values as immediate property names, rather than parameters of the
 130 ;; `encoding' property.  If these are encountered while parsing, associate
 131 ;; them as parameters of the `encoding' property in the returned structure.
 132 (defvar vcard-encoding-tags
 133   '("quoted-printable" "base64" "8bit" "7bit"))
 134
 135 ;; The vcard parser will auto-decode these encodings when they are
 136 ;; encountered.  These methods are invoked via vcard-parse-region-value.
 137 (defvar vcard-region-decoder-methods
 138   '(("quoted-printable" . vcard-region-decode-quoted-printable)
 139     ("base64"           . vcard-region-decode-base64)))
 140
 141 ;; This is used by vcard-region-decode-base64
 142 (defvar vcard-region-decode-base64-table
 143   (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
 144          (len (length a))
 145          (tbl (make-vector 123 nil))
 146          (i 0))
 147     (while (< i len)
 148       (aset tbl (vcard-char-to-int (aref a i)) i)
 149       (setq i (1+ i)))
 150     tbl))
 151
 152 \f
 153 ;;; This function can be used generically by applications to obtain
 154 ;;; a printable representation of a vcard.
 155
 156 ;;;###autoload
 157 (defun vcard-pretty-print (vcard)
 158   "Format VCARD into a string suitable for display to user.
 159 VCARD can be an unparsed string containing raw VCF vcard data
 160 or a parsed vcard alist as returned by `vcard-parse-string'.
 161
 162 The result is a string with formatted vcard information suitable for
 163 insertion into a mime presentation buffer.
 164
 165 The function specified by the variable `vcard-pretty-print-function'
 166 actually performs the formatting.  That function will always receive a
 167 parsed vcard alist."
 168   (and (stringp vcard)
 169        (setq vcard (vcard-parse-string vcard)))
 170   (funcall vcard-pretty-print-function vcard))
 171
 172 \f
 173 ;;; Parsing routines
 174
 175 ;;;###autoload
 176 (defun vcard-parse-string (raw &optional filter)
 177   "Parse RAW vcard data as a string, and return an alist representing data.
 178
 179 If the optional function FILTER is specified, apply that filter to each
 180 attribute.  If no filter is specified, `vcard-standard-filter' is used.
 181
 182 Filters should accept two arguments: the property list and the value list.
 183 Modifying in place the property or value list will affect the resulting
 184 attribute in the vcard alist.
 185
 186 Vcard data is normally in the form
 187
 188     begin:                        vcard
 189     prop1a:                       value1a
 190     prop2a;prop2b;prop2c=param2c: value2a
 191     prop3a;prop3b:                value3a;value3b;value3c
 192     end:                          vcard
 193
 194 \(Whitespace around the `:' separating properties and values is optional.\)
 195 If supplied to this function an alist of the form
 196
 197     \(\(\(\"prop1a\"\) \"value1a\"\)
 198      \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
 199      \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
 200
 201 would be returned."
 202   (let ((vcard nil)
 203         (buf (generate-new-buffer " *vcard parser work*")))
 204     (unwind-protect
 205         (save-excursion
 206           (set-buffer buf)
 207           ;; Make sure last line is newline-terminated.
 208           ;; An extra trailing newline is harmless.
 209           (insert raw "\n")
 210           (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
 211       (kill-buffer buf))
 212     vcard))
 213
 214 ;;;###autoload
 215 (defun vcard-parse-region (beg end &optional filter)
 216   "Parse the raw vcard data in region, and return an alist representing data.
 217 This function is just like `vcard-parse-string' except that it operates on
 218 a region of the current buffer rather than taking a string as an argument.
 219
 220 Note: this function modifies the buffer!"
 221   (or filter
 222       (setq filter 'vcard-standard-filter))
 223   (let ((case-fold-search t)
 224         (vcard-data nil)
 225         (pos (make-marker))
 226         (newpos (make-marker))
 227         properties value)
 228     (save-restriction
 229       (narrow-to-region beg end)
 230       (save-match-data
 231         ;; Unfold folded lines and delete naked carriage returns
 232         (goto-char (point-min))
 233         (while (re-search-forward "\r$\\|\n[ \t]" nil t)
 234           (goto-char (match-beginning 0))
 235           (delete-char 1))
 236
 237         (goto-char (point-min))
 238         (re-search-forward "^begin:[ \t]*vcard[ \t]*\n")
 239         (set-marker pos (point))
 240         (while (and (not (looking-at "^end[ \t]*:[ \t]*vcard[ \t]*$"))
 241                     (re-search-forward ":[ \t]*" nil t))
 242           (set-marker newpos (match-end 0))
 243           (setq properties
 244                 (vcard-parse-region-properties pos (match-beginning 0)))
 245           (set-marker pos (marker-position newpos))
 246           (re-search-forward "[ \t]*\n")
 247           (set-marker newpos (match-end 0))
 248           (setq value
 249                 (vcard-parse-region-value properties pos (match-beginning 0)))
 250           (set-marker pos (marker-position newpos))
 251           (goto-char pos)
 252           (funcall filter properties value)
 253           (setq vcard-data (cons (cons properties value) vcard-data)))))
 254     (nreverse vcard-data)))
 255
 256 (defun vcard-parse-region-properties (beg end)
 257   (downcase-region beg end)
 258   (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
 259          (props proplist)
 260          split)
 261     (save-match-data
 262       (while props
 263         (cond ((string-match "=" (car props))
 264                (setq split (vcard-split-string (car props) "=" 2))
 265                (setcar props (cons (car split) (car (cdr split)))))
 266               ((member (car props) vcard-encoding-tags)
 267                (setcar props (cons "encoding" (car props)))))
 268         (setq props (cdr props))))
 269     proplist))
 270
 271 (defun vcard-parse-region-value (proplist beg end)
 272   (let* ((encoding (vcard-get-property proplist "encoding"))
 273          (decoder (cdr (assoc encoding vcard-region-decoder-methods)))
 274          result pos match-beg match-end)
 275     (save-restriction
 276       (narrow-to-region beg end)
 277       (cond (decoder
 278              ;; Each `;'-separated field needs to be decoded and saved
 279              ;; separately; if the entire region were decoded at once, we
 280              ;; would not be able to distinguish between the original `;'
 281              ;; chars and those which were encoded in order to quote them
 282              ;; against being treated as field separators.
 283              (goto-char beg)
 284              (setq pos (set-marker (make-marker) (point)))
 285              (setq match-beg (make-marker))
 286              (setq match-end (make-marker))
 287              (save-match-data
 288                (while (< pos (point-max))
 289                  (cond ((search-forward ";" nil t)
 290                         (set-marker match-beg (match-beginning 0))
 291                         (set-marker match-end (match-end 0)))
 292                        (t
 293                         (set-marker match-beg (point-max))
 294                         (set-marker match-end (point-max))))
 295                  (funcall decoder pos match-beg)
 296                  (setq result (cons (buffer-substring pos match-beg) result))
 297                  (set-marker pos (marker-position match-end))))
 298              (setq result (nreverse result))
 299              (vcard-set-property proplist "encoding" nil))
 300             (t
 301              (setq result (vcard-split-string (buffer-string) ";")))))
 302     (goto-char (point-max))
 303     result))
 304
 305 \f
 306 ;;; Functions for retrieving property or value information from parsed
 307 ;;; vcard attributes.
 308
 309 (defun vcard-values (vcard have-props &optional non-props limit)
 310   "Return the values in VCARD.
 311 This function is like `vcard-ref' and takes the same arguments, but return
 312 only the values, not the associated property lists."
 313   (mapcar 'cdr (vcard-ref vcard have-props non-props limit)))
 314
 315 (defun vcard-ref (vcard have-props &optional non-props limit)
 316   "Return the attributes in VCARD with HAVE-PROPS properties.
 317 Optional arg NON-PROPS is a list of properties which candidate attributes
 318 must not have.
 319 Optional arg LIMIT means return no more than that many attributes.
 320
 321 The attributes in VCARD which have all properties specified by HAVE-PROPS
 322 but not having any specified by NON-PROPS are returned.  The first element
 323 of each attribute is the actual property list; the remaining elements are
 324 the values.
 325
 326 If a specific property has an associated parameter \(e.g. an encoding\),
 327 use the syntax \(\"property\" . \"parameter\"\) to specify it.  If property
 328 parameter is not important or it has no specific parameter, just specify
 329 the property name as a string."
 330   (let ((attrs vcard)
 331         (result nil)
 332         (count 0))
 333     (while (and attrs (or (null limit) (< count limit)))
 334       (and (vcard-proplist-all-properties (car (car attrs)) have-props)
 335            (not (vcard-proplist-any-properties (car (car attrs)) non-props))
 336            (setq result (cons (car attrs) result)
 337                  count (1+ count)))
 338       (setq attrs (cdr attrs)))
 339     (nreverse result)))
 340
 341 (defun vcard-proplist-all-properties (proplist props)
 342   "Returns nil unless PROPLIST contains all properties specified in PROPS."
 343   (let ((result t))
 344     (while (and result props)
 345       (or (vcard-get-property proplist (car props))
 346           (setq result nil))
 347       (setq props (cdr props)))
 348     result))
 349
 350 (defun vcard-proplist-any-properties (proplist props)
 351   "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
 352   (let ((result nil))
 353     (while (and (not result) props)
 354       (and (vcard-get-property proplist (car props))
 355            (setq result t))
 356       (setq props (cdr props)))
 357     result))
 358
 359 (defun vcard-get-property (proplist property)
 360   "Return the value from PROPLIST of PROPERTY.
 361 PROPLIST is a vcard attribute property list, which is normally the first
 362 element of each attribute entry in a vcard."
 363   (or (and (member property proplist) t)
 364       (cdr (assoc property proplist))))
 365
 366 (defun vcard-set-property (proplist property value)
 367   "In PROPLIST, set PROPERTY to VALUE.
 368 PROPLIST is a vcard attribute property list.
 369 If VALUE is nil, PROPERTY is deleted."
 370   (let (elt)
 371     (cond ((null value)
 372            (vcard-delete-property proplist property))
 373           ((setq elt (member property proplist))
 374            (and value (not (eq value t))
 375                 (setcar elt (cons property value))))
 376           ((setq elt (assoc property proplist))
 377            (cond ((eq value t)
 378                   (setq elt (memq elt proplist))
 379                   (setcar elt property))
 380                  (t
 381                   (setcdr elt value))))
 382           ((eq value t)
 383            (nconc proplist (cons property nil)))
 384           (t
 385            (nconc proplist (cons (cons property value) nil))))))
 386
 387 (defun vcard-delete-property (proplist property)
 388   "Delete from PROPLIST the specified property PROPERTY.
 389 This will not succeed in deleting the first member of the proplist, but
 390 that element should never be deleted since it is the primary key."
 391   (let (elt)
 392     (cond ((setq elt (member property proplist))
 393            (delq (car elt) proplist))
 394           ((setq elt (assoc property proplist))
 395            (delq (car (memq elt proplist)) proplist)))))
 396
 397 \f
 398 ;;; Vcard data filters.
 399 ;;;
 400 ;;; Filters receive both the property list and value list and may modify
 401 ;;; either in-place.  The return value from the filters are ignored.
 402 ;;;
 403 ;;; These filters can be used for purposes such as removing HTML tags or
 404 ;;; normalizing phone numbers into a standard form.
 405
 406 (defun vcard-standard-filter (proplist values)
 407   "Apply filters in `vcard-standard-filters' to attributes."
 408   (vcard-filter-apply-filter-list vcard-standard-filters proplist values))
 409
 410 ;; This function could be used to dispatch other filter lists.
 411 (defun vcard-filter-apply-filter-list (filter-list proplist values)
 412   (while filter-list
 413     (funcall (car filter-list) proplist values)
 414     (setq filter-list (cdr filter-list))))
 415
 416 ;; Some lusers put HTML (or even javascript!) in their vcards under the
 417 ;; misguided notion that it's a standard feature of vcards just because
 418 ;; Netscape supports this feature.  That is wrong; the vcard specification
 419 ;; does not define any html content semantics and most MUAs cannot do
 420 ;; anything with html text except display them unparsed, which is ugly.
 421 ;;
 422 ;; Thank Netscape for abusing the standard and damned near rendering it
 423 ;; useless for interoperability between MUAs.
 424 ;;
 425 ;; This filter does a very rudimentary job.
 426 (defun vcard-filter-html (proplist values)
 427   "Remove HTML tags from attribute values."
 428   (save-match-data
 429     (while values
 430       (while (string-match "<[^<>\n]+>" (car values))
 431         (setcar values (replace-match "" t t (car values))))
 432       (setq values (cdr values)))))
 433
 434 (defun vcard-filter-adr-newlines (proplist values)
 435   "Replace newlines with \"; \" in `adr' values."
 436   (and (vcard-get-property proplist "adr")
 437        (save-match-data
 438          (while values
 439            (while (string-match "[\r\n]+" (car values))
 440              (setcar values (replace-match "; " t t (car values))))
 441            (setq values (cdr values))))))
 442
 443 (defun vcard-filter-tel-normalize (proplist values)
 444   "Normalize telephone numbers in `tel' values.
 445 Spaces and hyphens are replaced with `.'.
 446 US domestic telephone numbers are replaced with international format."
 447   (and (vcard-get-property proplist "tel")
 448        (save-match-data
 449          (while values
 450            (while (string-match "[\t._-]+" (car values))
 451              (setcar values (replace-match " " t t (car values))))
 452            (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\
 453 \\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)"
 454                               (car values))
 455                 (setcar values
 456                         (replace-match "+1 \\1 \\2" t nil (car values))))
 457            (setq values (cdr values))))))
 458
 459 (defun vcard-filter-textprop-cr (proplist values)
 460   "Strip carriage returns from text values."
 461   (and (vcard-proplist-any-properties
 462         proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url"))
 463        (save-match-data
 464          (while values
 465            (while (string-match "\r+" (car values))
 466              (setcar values (replace-match "" t t (car values))))
 467            (setq values (cdr values))))))
 468
 469 \f
 470 ;;; Decoding methods.
 471
 472 (defmacro vcard-hexstring-to-ascii (s)
 473   (if (string-lessp emacs-version "20")
 474       `(format "%c" (car (read-from-string (format "?\\x%s" ,s))))
 475     `(format "%c" (string-to-number ,s 16))))
 476
 477 (defun vcard-region-decode-quoted-printable (&optional beg end)
 478   (save-excursion
 479     (save-restriction
 480       (save-match-data
 481         (narrow-to-region (or beg (point-min)) (or end (point-max)))
 482         (goto-char (point-min))
 483         (while (re-search-forward "=\n" nil t)
 484           (delete-region (match-beginning 0) (match-end 0)))
 485         (goto-char (point-min))
 486         (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t)
 487           (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0))))
 488             (replace-match (vcard-hexstring-to-ascii s) t t)))))))
 489
 490 (defun vcard-region-decode-base64 (&optional beg end)
 491   (save-restriction
 492     (narrow-to-region (or beg (point-min)) (or end (point-max)))
 493     (save-match-data
 494       (goto-char (point-min))
 495       (while (re-search-forward "[ \t\r\n]+" nil t)
 496         (delete-region (match-beginning 0) (match-end 0))))
 497     (goto-char (point-min))
 498     (let ((count 0)
 499           (n 0)
 500           (c nil))
 501       (while (not (eobp))
 502         (setq c (char-after (point)))
 503         (delete-char 1)
 504         (cond ((char-equal c ?=)
 505                (if (= count 2)
 506                    (insert (lsh n -10))
 507                  ;; count must be 3
 508                  (insert (lsh n -16) (logand 255 (lsh n -8))))
 509                (delete-region (point) (point-max)))
 510               (t
 511                (setq n (+ n (aref vcard-region-decode-base64-table
 512                                   (vcard-char-to-int c))))
 513                (setq count (1+ count))
 514                (cond ((= count 4)
 515                       (insert (logand 255 (lsh n -16))
 516                               (logand 255 (lsh n -8))
 517                               (logand 255 n))
 518                       (setq n 0 count 0))
 519                      (t
 520                       (setq n (lsh n 6))))))))))
 521
 522 \f
 523 (defun vcard-split-string (string &optional separator limit)
 524   "Split STRING at occurences of SEPARATOR.  Return a list of substrings.
 525 Optional argument SEPARATOR can be any regexp, but anything matching the
 526  separator will never appear in any of the returned substrings.
 527  If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\".
 528 If optional arg LIMIT is specified, split into no more than that many
 529  fields \(though it may split into fewer\)."
 530   (or separator (setq separator "[ \f\t\n\r\v]+"))
 531   (let ((string-list nil)
 532         (len (length string))
 533         (pos 0)
 534         (splits 0)
 535         str)
 536     (save-match-data
 537       (while (<= pos len)
 538         (setq splits (1+ splits))
 539         (cond ((and limit
 540                     (>= splits limit))
 541                (setq str (substring string pos))
 542                (setq pos (1+ len)))
 543               ((string-match separator string pos)
 544                (setq str (substring string pos (match-beginning 0)))
 545                (setq pos (match-end 0)))
 546               (t
 547                (setq str (substring string pos))
 548                (setq pos (1+ len))))
 549         (setq string-list (cons str string-list))))
 550     (nreverse string-list)))
 551
 552 (defun vcard-copy-tree (tree)
 553   "Make a deep copy of nested conses."
 554   (cond
 555    ((consp tree)
 556     (cons (vcard-copy-tree (car tree))
 557           (vcard-copy-tree (cdr tree))))
 558    (t tree)))
 559
 560 (defun vcard-flatten (l)
 561   (if (consp l)
 562       (apply 'nconc (mapcar 'vcard-flatten l))
 563     (list l)))
 564
 565 \f
 566 ;;; Sample formatting routines.
 567
 568 (defun vcard-format-sample-box (vcard)
 569   "Like `vcard-format-sample-string', but put an ascii box around text."
 570   (let* ((lines (vcard-format-sample-lines vcard))
 571          (len (vcard-format-sample-max-length lines))
 572          (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
 573          (line-fmt (format "| %%-%ds |" len))
 574          (formatted-lines
 575           (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
 576     (if (string= formatted-lines "")
 577         formatted-lines
 578       (concat edge formatted-lines edge))))
 579
 580 (defun vcard-format-sample-string (vcard)
 581   "Format VCARD into a string suitable for display to user.
 582 VCARD should be a parsed vcard alist.  The result is a string
 583 with formatted vcard information which can be inserted into a mime
 584 presentation buffer."
 585   (mapconcat 'identity (vcard-format-sample-lines vcard) "\n"))
 586
 587 (defun vcard-format-sample-lines (vcard)
 588   (let* ((name  (vcard-format-sample-get-name vcard))
 589          (title (vcard-format-sample-values-concat vcard '("title") 1 "; "))
 590          (org   (vcard-format-sample-values-concat vcard '("org")   1 "; "))
 591          (addr  (vcard-format-sample-get-address vcard))
 592          (tel   (vcard-format-sample-get-telephone vcard))
 593          (lines (delete nil (vcard-flatten (list name title org addr))))
 594          (col-template (format "%%-%ds%%s"
 595                                (vcard-format-sample-offset lines tel)))
 596          (l lines))
 597     (while tel
 598       (setcar l (format col-template (car l) (car tel)))
 599       ;; If we stripped away too many nil slots from l, add empty strings
 600       ;; back in so setcar above will work on next iteration.
 601       (and (cdr tel)
 602            (null (cdr l))
 603            (setcdr l (cons "" nil)))
 604       (setq l (cdr l))
 605       (setq tel (cdr tel)))
 606     lines))
 607
 608 (defun vcard-format-sample-get-name (vcard)
 609   (let ((name (car (car (vcard-values vcard '("fn") nil 1))))
 610         (email (car (vcard-format-sample-values
 611                      vcard '((("email" "pref"))
 612                              (("email" "internet"))
 613                              (("email"))) 1))))
 614     (cond ((and name email)
 615            (format "%s <%s>" name email))
 616           (email)
 617           (name)
 618           (""))))
 619
 620 (defun vcard-format-sample-get-telephone (vcard)
 621   (let ((fields '(("Work: "
 622                    (("tel" "work" "pref")  . ("fax" "pager" "cell"))
 623                    (("tel" "work" "voice") . ("fax" "pager" "cell"))
 624                    (("tel" "work")         . ("fax" "pager" "cell")))
 625                   ("Home: "
 626                    (("tel" "home" "pref")  . ("fax" "pager" "cell"))
 627                    (("tel" "home" "voice") . ("fax" "pager" "cell"))
 628                    (("tel" "home")         . ("fax" "pager" "cell"))
 629                    (("tel")                . ("fax" "pager" "cell" "work")))
 630                   ("Cell: "
 631                    (("tel" "cell" "pref"))
 632                    (("tel" "cell")))
 633                   ("Fax:  "
 634                    (("tel" "pref" "fax"))
 635                    (("tel" "work" "fax"))
 636                    (("tel" "home" "fax"))
 637                    (("tel" "fax")))))
 638         (phones nil)
 639         result)
 640     (while fields
 641       (setq result (vcard-format-sample-values vcard (cdr (car fields))))
 642       (while result
 643         (setq phones
 644               (cons (concat (car (car fields)) (car (car result))) phones))
 645         (setq result (cdr result)))
 646       (setq fields (cdr fields)))
 647     (nreverse phones)))
 648
 649 (defun vcard-format-sample-get-address (vcard)
 650   (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work"))
 651                                                    (("adr" "pref"))
 652                                                    (("adr" "work"))
 653                                                    (("adr"))) 1))
 654          (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
 655          (city-list (delete "" (nthcdr 3 addr)))
 656          (city (cond ((null (car city-list)) nil)
 657                      ((cdr city-list)
 658                       (format "%s, %s"
 659                               (car city-list)
 660                               (mapconcat 'identity (cdr city-list) " ")))
 661                      (t (car city-list)))))
 662     (delete nil (if city
 663                     (append street (list city))
 664                   street))))
 665
 666 (defun vcard-format-sample-values-concat (vcard have-props limit sep)
 667   (let ((l (car (vcard-values vcard have-props nil limit))))
 668     (and l (mapconcat 'identity (delete "" (vcard-copy-tree l)) sep))))
 669
 670 (defun vcard-format-sample-values (vcard proplists &optional limit)
 671   (let ((result (vcard-format-sample-ref vcard proplists limit)))
 672     (if (equal limit 1)
 673         (cdr result)
 674       (mapcar 'cdr result))))
 675
 676 (defun vcard-format-sample-ref (vcard proplists &optional limit)
 677   (let ((result nil))
 678     (while (and (null result) proplists)
 679       (setq result (vcard-ref vcard
 680                               (car (car proplists))
 681                               (cdr (car proplists))
 682                               limit))
 683       (setq proplists (cdr proplists)))
 684     (if (equal limit 1)
 685         (vcard-copy-tree (car result))
 686       (vcard-copy-tree result))))
 687
 688 (defun vcard-format-sample-offset (row1 row2 &optional maxwidth)
 689   (or maxwidth (setq maxwidth (frame-width)))
 690   (let ((max1 (vcard-format-sample-max-length row1))
 691         (max2 (vcard-format-sample-max-length row2)))
 692     (if (zerop max1)
 693         0
 694       (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2))))))))
 695
 696 (defun vcard-format-sample-max-length (strings)
 697   (let ((maxlen 0))
 698     (while strings
 699       (setq maxlen (max maxlen (length (car strings))))
 700       (setq strings (cdr strings)))
 701     maxlen))
 702
 703 (provide 'vcard)
 704
 705 ;;; vcard.el ends here