[elpa] externals/vcard d0ec40a5c6 08/13: Complete rewrite.

[Stefan Monnier]

branch: externals/vcard
commit d0ec40a5c62980a6cfe183b27c517117264465e2
Author: Noah Friedman <friedman@splode.com>
Commit: Noah Friedman <friedman@splode.com>

    Complete rewrite.
---
 vcard.el | 803 ++++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 590 insertions(+), 213 deletions(-)

diff --git a/vcard.el b/vcard.el
index 74ff63497d..228d815c7d 100644
--- a/vcard.el
+++ b/vcard.el
@@ -1,13 +1,13 @@
 ;;; vcard.el --- vcard parsing and display routines
 
-;; Copyright (C) 1997, 1999 Noah S. Friedman
+;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman
 
 ;; Author: Noah Friedman <friedman@splode.com>
 ;; Maintainer: friedman@splode.com
-;; Keywords: extensions
+;; Keywords: vcard, mail, news
 ;; Created: 1997-09-27
 
-;; $Id: vcard.el,v 1.7 1999/10/25 05:49:12 friedman Exp $
+;; $Id: vcard.el,v 1.8 2000/02/03 17:54:50 friedman Exp $
 
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -26,179 +26,525 @@
 
 ;;; Commentary:
 
-;; The display routines here are just an example.  The primitives in the
-;; first section can be used to construct other vcard formatters.
+;; Unformatted vcards are just plain ugly.  But if you live in the MIME
+;; world, they are a better way of exchanging contact information than
+;; freeform signatures since the former can be automatically parsed and
+;; stored in a searchable index.
+;;
+;; This library of routines provides the back end necessary for parsing
+;; vcards so that they can eventually go into an address book like BBDB
+;; (although this library does not implement that itself).  Also included
+;; is a sample pretty-printer which MUAs can use which do not provide their
+;; own vcard formatters.
+
+;; This library does not interface directly with any mail user agents.  For
+;; an example of bindings for the VM MUA, see vm-vcard.el available from
+;;
+;;    http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
+;;
+;; Updates to vcard.el should be available there too.
+
+;; The main entry point to this package is `vcard-pretty-print' although
+;; any documented variable or function is considered part of the API for
+;; operating on vcard data.
 
 ;; The vcard 2.1 format is defined by the versit consortium.
 ;; See http://www.imc.org/pdi/vcard-21.ps
+;;
 ;; RFC 2426 defines the vcard 3.0 format.
 ;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
 
+;; A parsed vcard is a list of attributes of the form
+;;
+;;     (proplist value1 value2 ...)
+;;
+;; Where proplist is a list of property names and parameters, e.g.
+;;
+;;     (property1 (property2 . parameter2) ...)
+;;
+;; Each property has an associated implicit or explicit parameter value
+;; (not to be confused with attribute values; in general this API uses
+;; `parameter' to refer to property values and `value' to refer to attribute
+;; values to avoid confusion).  If a property has no explicit parameter value,
+;; the parameter value is considered to be `t'.  Any property which does not
+;; exist for an attribute is considered to have a nil parameter.
+
+;; TODO:
+;;   * Finish supporting the 3.0 extensions.
+;;     Currently, only the 2.1 standard is supported.
+;;   * Handle nested vcards and grouped attributes?
+;;     (I've never actually seen one of these in use.)
+;;   * Handle multibyte charsets.
+;;   * Inverse of vcard-parse-string: write .VCF files from alist
+;;   * Implement a vcard address book?  Or is using BBDB preferable?
+;;   * Improve the sample formatter.
+
 ;;; Code:
 
-(defvar vcard-standard-filters '(vcard-filter-html)
+(defgroup vcard nil
+  "Support for the vCard electronic business card format."
+  :group 'vcard
+  :group 'mail
+  :group 'news)
+
+;;;###autoload
+(defcustom vcard-pretty-print-function 'vcard-format-sample-box
+  "*Formatting function used by `vcard-pretty-print'."
+  :type 'function
+  :group 'vcard)
+
+;;;###autoload
+(defcustom vcard-standard-filters
+  '(vcard-filter-html
+    vcard-filter-adr-newlines
+    vcard-filter-tel-normalize
+    vcard-filter-textprop-cr)
   "*Standard list of filters to apply to parsed vcard data.
-These filters are applied sequentially to vcard data records when
+These filters are applied sequentially to vcard attributes when
 the function `vcard-standard-filter' is supplied as the second argument to
-`vcard-parse-string'.")
+`vcard-parse'."
+  :type 'hook
+  :group 'vcard)
 
+
+;;; No user-settable options below.
+
+;; This is just the version number for this package; it does not refer to
+;; the vcard format specification.  Currently, this package does not yet
+;; support the full vcard 3.0 specification.
+;;
+;; Whenever any part of the API defined in this package change in a way
+;; that is not backward-compatible, the major version number here should be
+;; incremented.  Backward-compatible additions to the API should be
+;; indicated by increasing the minor version number.
+(defconst vcard-api-version "2.0")
+
+;; The vcard standards allow specifying the encoding for an attribute using
+;; these values as immediate property names, rather than parameters of the
+;; `encoding' property.  If these are encountered while parsing, associate
+;; them as parameters of the `encoding' property in the returned structure.
+(defvar vcard-encoding-tags
+  '("quoted-printable" "base64" "8bit" "7bit"))
+
+;; The vcard parser will auto-decode these encodings when they are
+;; encountered.  These methods are invoked via vcard-parse-region-value.
+(defvar vcard-region-decoder-methods
+  '(("quoted-printable" . vcard-region-decode-quoted-printable)
+    ("base64"           . vcard-region-decode-base64)))
+
+;; This is used by vcard-region-decode-base64
+(defvar vcard-region-decode-base64-table
+  (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+         (len (length a))
+         (tbl (make-vector 123 nil))
+         (i 0))
+    (while (< i len)
+      (aset tbl (char-to-int (aref a i)) i)
+      (setq i (1+ i)))
+    tbl))
+
+
+;;; This function can be used generically by applications to obtain
+;;; a printable representation of a vcard.
+
+;;;###autoload
+(defun vcard-pretty-print (vcard)
+  "Format VCARD into a string suitable for display to user.
+VCARD can be an unparsed string containing raw VCF vcard data
+or a parsed vcard alist as returned by `vcard-parse-string'.
+
+The result is a string with formatted vcard information suitable for
+insertion into a mime presentation buffer.
+
+The function specified by the variable `vcard-pretty-print-function'
+actually performs the formatting.  That function will always receive a
+parsed vcard alist."
+  (and (stringp vcard)
+       (setq vcard (vcard-parse-string vcard)))
+  (funcall vcard-pretty-print-function vcard))
+
+
+;;; Parsing routines
+
+;;;###autoload
 (defun vcard-parse-string (raw &optional filter)
   "Parse RAW vcard data as a string, and return an alist representing data.
 
-If the optional function FILTER is specified, apply that filter to the
-data record of each key before splitting fields.  Filters should accept
-two arguments: the key and the data.  They are expected to operate on
-\(and return\) a modified data value.
+If the optional function FILTER is specified, apply that filter to each
+attribute.  If no filter is specified, `vcard-standard-filter' is used.
+
+Filters should accept two arguments: the property list and the value list.
+Modifying in place the property or value list will affect the resulting
+attribute in the vcard alist.
 
 Vcard data is normally in the form
 
-    begin:        vcard
-    key1:         field
-    key2;subkey1: field
-    key2;subkey2: field1;field2;field3
-    end:          vcard
+    begin:                        vcard
+    prop1a:                       value1a
+    prop2a;prop2b;prop2c=param2c: value2a
+    prop3a;prop3b:                value3a;value3b;value3c
+    end:                          vcard
 
-\(Whitespace after the colon separating the key and field is optional.\)
+\(Whitespace around the `:' separating properties and values is optional.\)
 If supplied to this function an alist of the form
 
-    ((\"key1\" \"field\")
-     (\"key2\"
-      (\"subkey2\" \"field1\" \"field2\" \"field3\")
-      (\"subkey1\" \"field\")))
+    \(\(\(\"prop1a\"\) \"value1a\"\)
+     \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
+     \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
 
 would be returned."
-  (save-match-data
-    (let ((case-fold-search t)
-          (raw-pos 0)
-          (vcard-data nil)
-          key data)
-      (string-match "^[ \t]*begin:[ \t]*vcard[ \t]*[\r\n]+" raw raw-pos)
-      (setq raw-pos (match-end 0))
-      (while (and (< raw-pos (length raw))
-                  (string-match
-                   "^[ \t]*\\([^:]+\\):[ \t]*\\(.*\\)[ \t]*[\n\r]+"
-                   raw raw-pos))
-        (setq key (downcase (vcard-matching-substring 1 raw)))
-        (setq data (vcard-matching-substring 2 raw))
-        (setq raw-pos (match-end 0))
-        (cond
-         ((string= key "end")
-          (setq raw-pos (length raw)))
-         (t
-          (and filter
-               (setq data (funcall filter key data)))
-          (setq vcard-data
-                (vcard-set-alist-slot vcard-data
-                                      (vcard-split-string key ";")
-                                      (vcard-split-string data ";"))))))
-      (nreverse vcard-data))))
-
-(defun vcard-ref (key vcard-data)
-  "Return the vcard data associated with KEY in VCARD-DATA.
-Key may be a list of nested keys or a single string of colon-separated
-keys."
-  (cond ((listp key)
-         (vcard-alist-assoc key vcard-data))
-        ((and (stringp key)
-              (save-match-data
-                (string-match ";" key)))
-         (vcard-alist-assoc (vcard-split-string key ";") vcard-data))
-        ((stringp key)
-         (cdr (assoc key vcard-data)))))
+  (let ((vcard nil)
+        (buf (generate-new-buffer " *vcard parser work*")))
+    (unwind-protect
+        (save-excursion
+          (set-buffer buf)
+          ;; Make sure last line is newline-terminated.
+          ;; An extra trailing newline is harmless.
+          (insert raw "\n")
+          (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
+      (kill-buffer buf))
+    vcard))
+
+;;;###autoload
+(defun vcard-parse-region (beg end &optional filter)
+  "Parse the raw vcard data in region, and return an alist representing data.
+This function is just like `vcard-parse-string' except that it operates on
+a region of the current buffer rather than taking a string as an argument.
+
+Note: this function modifies the buffer!"
+  (or filter
+      (setq filter 'vcard-standard-filter))
+  (let ((case-fold-search t)
+        (vcard-data nil)
+        (pos (make-marker))
+        (newpos (make-marker))
+        properties value)
+    (save-restriction
+      (narrow-to-region beg end)
+      (save-match-data
+        ;; Unfold folded lines and delete naked carriage returns
+        (goto-char (point-min))
+        (while (re-search-forward "\r$\\|\n[ \t]" nil t)
+          (goto-char (match-beginning 0))
+          (delete-char 1))
+
+        (goto-char (point-min))
+        (re-search-forward "^begin:[ \t]*vcard[ \t]*\n")
+        (set-marker pos (point))
+        (while (and (not (looking-at "^end[ \t]*:[ \t]*vcard[ \t]*$"))
+                    (re-search-forward ":[ \t]*" nil t))
+          (set-marker newpos (match-end 0))
+          (setq properties
+                (vcard-parse-region-properties pos (match-beginning 0)))
+          (set-marker pos (marker-position newpos))
+          (re-search-forward "[ \t]*\n")
+          (set-marker newpos (match-end 0))
+          (setq value
+                (vcard-parse-region-value properties pos (match-beginning 0)))
+          (set-marker pos (marker-position newpos))
+          (goto-char pos)
+          (funcall filter properties value)
+          (setq vcard-data (cons (cons properties value) vcard-data)))))
+    (nreverse vcard-data)))
+
+(defun vcard-parse-region-properties (beg end)
+  (downcase-region beg end)
+  (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
+         (props proplist)
+         split)
+    (save-match-data
+      (while props
+        (cond ((string-match "=" (car props))
+               (setq split (vcard-split-string (car props) "=" 2))
+               (setcar props (cons (car split) (car (cdr split)))))
+              ((member (car props) vcard-encoding-tags)
+               (setcar props (cons "encoding" (car props)))))
+        (setq props (cdr props))))
+    proplist))
+
+(defun vcard-parse-region-value (proplist beg end)
+  (let* ((encoding (vcard-get-property proplist "encoding"))
+         (decoder (cdr (assoc encoding vcard-region-decoder-methods)))
+         result pos match-beg match-end)
+    (save-restriction
+      (narrow-to-region beg end)
+      (cond (decoder
+             ;; Each `;'-separated field needs to be decoded and saved
+             ;; separately; if the entire region were decoded at once, we
+             ;; would not be able to distinguish between the original `;'
+             ;; chars and those which were encoded in order to quote them
+             ;; against being treated as field separators.
+             (goto-char beg)
+             (setq pos (new-marker (point)))
+             (setq match-beg (make-marker))
+             (setq match-end (make-marker))
+             (save-match-data
+               (while (< pos (point-max))
+                 (cond ((search-forward ";" nil t)
+                        (set-marker match-beg (match-beginning 0))
+                        (set-marker match-end (match-end 0)))
+                       (t
+                        (set-marker match-beg (point-max))
+                        (set-marker match-end (point-max))))
+                 (funcall decoder pos match-beg)
+                 (setq result (cons (buffer-substring pos match-beg) result))
+                 (set-marker pos (marker-position match-end))))
+             (setq result (nreverse result))
+             (vcard-set-property proplist "encoding" nil))
+            (t
+             (setq result (vcard-split-string (buffer-string) ";")))))
+    (goto-char (point-max))
+    result))
 
 
-;;; Vcard data filters.
+;;; Functions for retrieving property or value information from parsed
+;;; vcard attributes.
+
+(defun vcard-values (vcard have-props &optional non-props limit)
+  "Return the values in VCARD.
+This function is like `vcard-ref' and takes the same arguments, but return
+only the values, not the associated property lists."
+  (mapcar 'cdr (vcard-ref vcard have-props non-props limit)))
+
+(defun vcard-ref (vcard have-props &optional non-props limit)
+  "Return the attributes in VCARD with HAVE-PROPS properties.
+Optional arg NON-PROPS is a list of properties which candidate attributes
+must not have.
+Optional arg LIMIT means return no more than that many attributes.
+
+The attributes in VCARD which have all properties specified by HAVE-PROPS
+but not having any specified by NON-PROPS are returned.  The first element
+of each attribute is the actual property list; the remaining elements are
+the values.
+
+If a specific property has an associated parameter \(e.g. an encoding\),
+use the syntax \(\"property\" . \"parameter\"\) to specify it.  If property
+parameter is not important or it has no specific parameter, just specify
+the property name as a string."
+  (let ((attrs vcard)
+        (result nil)
+        (count 0))
+    (while (and attrs (or (null limit) (< count limit)))
+      (and (vcard-proplist-all-properties (car (car attrs)) have-props)
+           (not (vcard-proplist-any-properties (car (car attrs)) non-props))
+           (setq result (cons (car attrs) result)
+                 count (1+ count)))
+      (setq attrs (cdr attrs)))
+    (nreverse result)))
+
+(defun vcard-proplist-all-properties (proplist props)
+  "Returns nil unless PROPLIST contains all properties specified in PROPS."
+  (let ((result t))
+    (while (and result props)
+      (or (vcard-get-property proplist (car props))
+          (setq result nil))
+      (setq props (cdr props)))
+    result))
+
+(defun vcard-proplist-any-properties (proplist props)
+  "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
+  (let ((result nil))
+    (while (and (not result) props)
+      (and (vcard-get-property proplist (car props))
+           (setq result t))
+      (setq props (cdr props)))
+    result))
+
+(defun vcard-get-property (proplist property)
+  "Return the value from PROPLIST of PROPERTY.
+PROPLIST is a vcard attribute property list, which is normally the first
+element of each attribute entry in a vcard."
+  (or (and (member property proplist) t)
+      (cdr (assoc property proplist))))
+
+(defun vcard-set-property (proplist property value)
+  "In PROPLIST, set PROPERTY to VALUE.
+PROPLIST is a vcard attribute property list.
+If VALUE is nil, PROPERTY is deleted."
+  (let (elt)
+    (cond ((null value)
+           (vcard-delete-property proplist property))
+          ((setq elt (member property proplist))
+           (and value (not (eq value t))
+                (setcar elt (cons property value))))
+          ((setq elt (assoc property proplist))
+           (cond ((eq value t)
+                  (setq elt (memq elt proplist))
+                  (setcar elt property))
+                 (t
+                  (setcdr elt value))))
+          ((eq value t)
+           (nconc proplist (cons property nil)))
+          (t
+           (nconc proplist (cons (cons property value) nil))))))
+
+(defun vcard-delete-property (proplist property)
+  "Delete from PROPLIST the specified property PROPERTY.
+This will not succeed in deleting the first member of the proplist, but
+that element should never be deleted since it is the primary key."
+  (let (elt)
+    (cond ((setq elt (member property proplist))
+           (delq (car elt) proplist))
+          ((setq elt (assoc property proplist))
+           (delq (car (memq elt proplist)) proplist)))))
 
-;; These receive both the key and data, but are expected to operate on (and
-;; return) just the data.
+
+;;; Vcard data filters.
+;;;
+;;; Filters receive both the property list and value list and may modify
+;;; either in-place.  The return value from the filters are ignored.
+;;;
+;;; These filters can be used for purposes such as removing HTML tags or
+;;; normalizing phone numbers into a standard form.
+
+(defun vcard-standard-filter (proplist values)
+  "Apply filters in `vcard-standard-filters' to attributes."
+  (vcard-filter-apply-filter-list vcard-standard-filters proplist values))
+
+;; This function could be used to dispatch other filter lists.
+(defun vcard-filter-apply-filter-list (filter-list proplist values)
+  (while filter-list
+    (funcall (car filter-list) proplist values)
+    (setq filter-list (cdr filter-list))))
+
+;; Some lusers put HTML (or even javascript!) in their vcards under the
+;; misguided notion that it's a standard feature of vcards just because
+;; Netscape supports this feature.  That is wrong; the vcard specification
+;; does not define any html content semantics and most MUAs cannot do
+;; anything with html text except display them unparsed, which is ugly.
 ;;
-;; There is probably no overwhelming need for this, except that some lusers
-;; put HTML in their vcards under the misguided notion that it's a standard
-;; feature of vcards just because Netscape supports this feature.  (Or
-;; perhaps those lusers just don't care that their vcards look like shit in
-;; every other MUA).
+;; Thank Netscape for abusing the standard and damned near rendering it
+;; useless for interoperability between MUAs.
 ;;
-;; On the other hand, perhaps someone will devise some other use for these
-;; filters, such as noticing common phone number formats and re-formatting
-;; them to fit personal preferences.
-
-(defun vcard-filter-apply-filter-list (filter-list key data)
-  (while filter-list
-    (setq data (funcall (car filter-list) key data))
-    (setq filter-list (cdr filter-list)))
-  data)
-
-(defun vcard-standard-filter (key data)
-  (vcard-filter-apply-filter-list vcard-standard-filters key data))
-
-(defun vcard-filter-html (key data)
+;; This filter does a very rudimentary job.
+(defun vcard-filter-html (proplist values)
+  "Remove HTML tags from attribute values."
   (save-match-data
-    (while (string-match "<[^<>\n]+>" data)
-      (setq data (concat (substring data 0 (match-beginning 0))
-                         (substring data (match-end 0)))))
-    data))
+    (while values
+      (while (string-match "<[^<>\n]+>" (car values))
+        (setcar values (replace-match "" t t (car values))))
+      (setq values (cdr values)))))
+
+(defun vcard-filter-adr-newlines (proplist values)
+  "Replace newlines with \"; \" in `adr' values."
+  (and (vcard-get-property proplist "adr")
+       (save-match-data
+         (while values
+           (while (string-match "[\r\n]+" (car values))
+             (setcar values (replace-match "; " t t (car values))))
+           (setq values (cdr values))))))
+
+(defun vcard-filter-tel-normalize (proplist values)
+  "Normalize telephone numbers in `tel' values.
+Spaces and hyphens are replaced with `.'.
+US domestic telephone numbers are replaced with international format."
+  (and (vcard-get-property proplist "tel")
+       (save-match-data
+         (while values
+           (while (string-match "[\t._-]+" (car values))
+             (setcar values (replace-match " " t t (car values))))
+           (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\
+\\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)"
+                              (car values))
+                (setcar values
+                        (replace-match "+1 \\1 \\2" t nil (car values))))
+           (setq values (cdr values))))))
+
+(defun vcard-filter-textprop-cr (proplist values)
+  "Strip carriage returns from text values."
+  (and (vcard-proplist-any-properties
+        proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url"))
+       (save-match-data
+         (while values
+           (while (string-match "\r+" (car values))
+             (setcar values (replace-match "" t t (car values))))
+           (setq values (cdr values))))))
 
 
-;;; Utility routines.
-
-;; This does most of the dirty work of key lookup for vcard-ref.
-(defun vcard-alist-assoc (keys alist)
-  (while (and keys alist)
-    (setq alist (cdr (assoc (car keys) alist)))
-    (setq keys (cdr keys)))
-  alist)
-
-;; In ALIST, set KEY-LIST's value to VALUE, and return new value of ALIST.
-;; KEY-LIST should be a list of nested keys, if ALIST is an alist of alists.
-;; If any key is not present in an alist, the key and value pair will be
-;; inserted into the parent alist.
-(defun vcard-set-alist-slot (alist key-list value)
-  (let* ((orig-key-list key-list)
-         (key (car key-list))
-         (elt (assoc key alist)))
-    (setq key-list (cdr key-list))
-    (cond ((and (cdr elt) key-list)
-           (vcard-set-alist-slot (cdr elt) key-list value))
-          ((and elt key-list)
-           (setcdr elt (vcard-set-alist-slot nil key-list value)))
-          (elt (setcdr elt value))
-          (t
-           (let ((new))
-             (setq key-list (reverse orig-key-list))
-             (while key-list
-               (if new
-                   (setq new (cons (car key-list) (cons new nil)))
-                 (setq new (cons (car key-list) value)))
-               (setq key-list (cdr key-list)))
-
-             (cond ((null alist)
-                    (setq alist (cons new nil)))
-                   (t
-                    (setcdr alist (cons (car alist) (cdr alist)))
-                    (setcar alist new))))))
-    alist))
-
-;; Return substring matched by last search.
-;; N specifies which match data pair to use
-;; Value is nil if there is no Nth match.
-;; If STRING is not specified, the current buffer is used.
-(defun vcard-matching-substring (n &optional string)
-  (if (match-beginning n)
-      (if string
-         (substring string (match-beginning n) (match-end n))
-       (buffer-substring (match-beginning n) (match-end n)))))
-
-;; Split STRING at occurences of SEPARATOR.  Return a list of substrings.
-;; SEPARATOR can be any regexp, but anything matching the separator will
-;; never appear in any of the returned substrings.
-(defun vcard-split-string (string separator)
-  (let* ((list nil)
-         (pos 0))
+;;; Decoding methods.
+
+(defun vcard-region-decode-quoted-printable (&optional beg end)
+  (save-excursion
+    (save-restriction
+      (save-match-data
+        (narrow-to-region (or beg (point-min)) (or end (point-max)))
+        (goto-char (point-min))
+        (while (re-search-forward "=\n" nil t)
+          (delete-region (match-beginning 0) (match-end 0)))
+        (goto-char (point-min))
+        (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t)
+          (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0))))
+            (replace-match (format "%c" (string-to-number s 16)) t t)))))))
+
+(defun vcard-region-decode-base64 (&optional beg end)
+  (save-restriction
+    (narrow-to-region (or beg (point-min)) (or end (point-max)))
     (save-match-data
-      (while (string-match separator string pos)
-        (setq list (cons (substring string pos (match-beginning 0)) list))
-        (setq pos (match-end 0)))
-      (nreverse (cons (substring string pos) list)))))
+      (goto-char (point-min))
+      (while (re-search-forward "[ \t\r\n]+" nil t)
+        (delete-region (match-beginning 0) (match-end 0))))
+    (goto-char (point-min))
+    (let ((count 0)
+          (n 0)
+          (c nil))
+      (while (not (eobp))
+        (setq c (char-after (point)))
+        (delete-char 1)
+        (cond ((char-equal c ?=)
+               (if (= count 2)
+                   (insert (lsh n -10))
+                 ;; count must be 3
+                 (insert (lsh n -16) (logand 255 (lsh n -8))))
+               (delete-region (point) (point-max)))
+              (t
+               (setq n (+ n (aref vcard-region-decode-base64-table
+                                  (char-to-int c))))
+               (setq count (1+ count))
+               (cond ((= count 4)
+                      (insert (logand 255 (lsh n -16))
+                              (logand 255 (lsh n -8))
+                              (logand 255 n))
+                      (setq n 0 count 0))
+                     (t
+                      (setq n (lsh n 6))))))))))
+
+
+(defun vcard-split-string (string &optional separator limit)
+  "Split STRING at occurences of SEPARATOR.  Return a list of substrings.
+Optional argument SEPARATOR can be any regexp, but anything matching the
+ separator will never appear in any of the returned substrings.
+ If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\".
+If optional arg LIMIT is specified, split into no more than that many
+ fields \(though it may split into fewer\)."
+  (or separator (setq separator "[ \f\t\n\r\v]+"))
+  (let ((string-list nil)
+        (len (length string))
+        (pos 0)
+        (splits 0)
+        str)
+    (save-match-data
+      (while (<= pos len)
+        (setq splits (1+ splits))
+        (cond ((and limit
+                    (>= splits limit))
+               (setq str (substring string pos))
+               (setq pos (1+ len)))
+              ((string-match separator string pos)
+               (setq str (substring string pos (match-beginning 0)))
+               (setq pos (match-end 0)))
+              (t
+               (setq str (substring string pos))
+               (setq pos (1+ len))))
+        (setq string-list (cons str string-list))))
+    (nreverse string-list)))
+
+(defun vcard-copy-tree (tree)
+  "Make a deep copy of nested conses."
+  (cond
+   ((consp tree)
+    (cons (vcard-copy-tree (car tree))
+          (vcard-copy-tree (cdr tree))))
+   (t tree)))
 
 (defun vcard-flatten (l)
   (if (consp l)
@@ -208,10 +554,10 @@ keys."
 
 ;;; Sample formatting routines.
 
-(defun vcard-format-box (vcard-data)
-  "Like `vcard-format-string', but put an ascii box around text."
-  (let* ((lines (vcard-format-lines vcard-data))
-         (len (vcard-format-max-length lines))
+(defun vcard-format-sample-box (vcard)
+  "Like `vcard-format-sample-string', but put an ascii box around text."
+  (let* ((lines (vcard-format-sample-lines vcard))
+         (len (vcard-format-sample-max-length lines))
          (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
          (line-fmt (format "| %%-%ds |" len))
          (formatted-lines
@@ -220,22 +566,22 @@ keys."
         formatted-lines
       (concat edge formatted-lines edge))))
 
-(defun vcard-format-string (vcard-data)
-  "Format VCARD-DATA into a string suitable for presentation.
-VCARD-DATA should be a parsed vcard alist.  The result is a string
+(defun vcard-format-sample-string (vcard)
+  "Format VCARD into a string suitable for display to user.
+VCARD should be a parsed vcard alist.  The result is a string
 with formatted vcard information which can be inserted into a mime
 presentation buffer."
-  (mapconcat 'identity (vcard-format-lines vcard-data) "\n"))
-
-(defun vcard-format-lines (vcard-data)
-  (let* ((name  (vcard-format-get-name      vcard-data))
-         (title (vcard-format-ref "title"   vcard-data))
-         (org   (vcard-format-ref "org"     vcard-data))
-         (addr  (vcard-format-get-address   vcard-data))
-         (tel   (vcard-format-get-telephone vcard-data))
+  (mapconcat 'identity (vcard-format-sample-lines vcard) "\n"))
+
+(defun vcard-format-sample-lines (vcard)
+  (let* ((name  (vcard-format-sample-get-name vcard))
+         (title (vcard-format-sample-values-concat vcard '("title") 1 "; "))
+         (org   (vcard-format-sample-values-concat vcard '("org")   1 "; "))
+         (addr  (vcard-format-sample-get-address vcard))
+         (tel   (vcard-format-sample-get-telephone vcard))
          (lines (delete nil (vcard-flatten (list name title org addr))))
          (col-template (format "%%-%ds%%s"
-                               (vcard-format-offset lines tel)))
+                               (vcard-format-sample-offset lines tel)))
          (l lines))
     (while tel
       (setcar l (format col-template (car l) (car tel)))
@@ -248,21 +594,52 @@ presentation buffer."
       (setq tel (cdr tel)))
     lines))
 
-
-(defun vcard-format-get-name (vcard-data)
-  (let ((name (vcard-format-ref "fn" vcard-data))
-        (email (or (vcard-format-ref '("email" "internet") vcard-data)
-                   (vcard-format-ref "email" vcard-data))))
-    (if email
-        (format "%s <%s>" name email)
-      name)))
-
-(defun vcard-format-get-address (vcard-data)
-  (let* ((addr-raw (or (vcard-format-ref '("adr" "dom") vcard-data)
-                       (vcard-format-ref "adr" vcard-data)))
-         (addr (if (consp addr-raw)
-                   addr-raw
-                 (list addr-raw)))
+(defun vcard-format-sample-get-name (vcard)
+  (let ((name (car (car (vcard-values vcard '("fn") nil 1))))
+        (email (car (vcard-format-sample-values
+                     vcard '((("email" "pref"))
+                             (("email" "internet"))
+                             (("email"))) 1))))
+    (cond ((and name email)
+           (format "%s <%s>" name email))
+          (email)
+          (name)
+          (""))))
+
+(defun vcard-format-sample-get-telephone (vcard)
+  (let ((fields '(("Work: "
+                   (("tel" "work" "pref")  . ("fax" "pager" "cell"))
+                   (("tel" "work" "voice") . ("fax" "pager" "cell"))
+                   (("tel" "work")         . ("fax" "pager" "cell")))
+                  ("Home: "
+                   (("tel" "home" "pref")  . ("fax" "pager" "cell"))
+                   (("tel" "home" "voice") . ("fax" "pager" "cell"))
+                   (("tel" "home")         . ("fax" "pager" "cell"))
+                   (("tel")                . ("fax" "pager" "cell" "work")))
+                  ("Cell: "
+                   (("tel" "cell" "pref"))
+                   (("tel" "cell")))
+                  ("Fax:  "
+                   (("tel" "pref" "fax"))
+                   (("tel" "work" "fax"))
+                   (("tel" "home" "fax"))
+                   (("tel" "fax")))))
+        (phones nil)
+        result)
+    (while fields
+      (setq result (vcard-format-sample-values vcard (cdr (car fields))))
+      (while result
+        (setq phones
+              (cons (concat (car (car fields)) (car (car result))) phones))
+        (setq result (cdr result)))
+      (setq fields (cdr fields)))
+    (nreverse phones)))
+
+(defun vcard-format-sample-get-address (vcard)
+  (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work"))
+                                                   (("adr" "pref"))
+                                                   (("adr" "work"))
+                                                   (("adr"))) 1))
          (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
          (city-list (delete "" (nthcdr 3 addr)))
          (city (cond ((null (car city-list)) nil)
@@ -271,45 +648,45 @@ presentation buffer."
                               (car city-list)
                               (mapconcat 'identity (cdr city-list) " ")))
                      (t (car city-list)))))
-    (delete nil
-            (if city
-                (append street (list city))
-              street))))
-
-(defun vcard-format-get-telephone (vcard-data)
-  (delete nil
-          (mapcar (function (lambda (x)
-                              (let ((result (vcard-format-ref (car x)
-                                                              vcard-data)))
-                                (and result
-                                     (concat (cdr x) result)))))
-                  '((("tel" "work") . "Work: ")
-                    (("tel" "home") . "Home: ")
-                    (("tel" "fax")  . "Fax:  ")))))
-
-(defun vcard-format-ref (key vcard-data)
-  (setq key (vcard-ref key vcard-data))
-  (or (cdr key)
-      (setq key (car key)))
-  (and (stringp key)
-       (string= key "")
-       (setq key nil))
-  key)
-
-(defun vcard-format-offset (row1 row2 &optional maxwidth)
+    (delete nil (if city
+                    (append street (list city))
+                  street))))
+
+(defun vcard-format-sample-values-concat (vcard have-props limit sep)
+  (let ((l (car (vcard-values vcard have-props nil limit))))
+    (and l (mapconcat 'identity (delete "" (vcard-copy-tree l)) sep))))
+
+(defun vcard-format-sample-values (vcard proplists &optional limit)
+  (let ((result (vcard-format-sample-ref vcard proplists limit)))
+    (if (equal limit 1)
+        (cdr result)
+      (mapcar 'cdr result))))
+
+(defun vcard-format-sample-ref (vcard proplists &optional limit)
+  (let ((result nil))
+    (while (and (null result) proplists)
+      (setq result (vcard-ref vcard
+                              (car (car proplists))
+                              (cdr (car proplists))
+                              limit))
+      (setq proplists (cdr proplists)))
+    (if (equal limit 1)
+        (vcard-copy-tree (car result))
+      (vcard-copy-tree result))))
+
+(defun vcard-format-sample-offset (row1 row2 &optional maxwidth)
   (or maxwidth (setq maxwidth (frame-width)))
-  (let ((max1 (vcard-format-max-length row1))
-        (max2 (vcard-format-max-length row2)))
-    (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2)))))))
-
-(defun vcard-format-max-length (strings)
-  (let ((maxlen 0)
-        (len 0))
+  (let ((max1 (vcard-format-sample-max-length row1))
+        (max2 (vcard-format-sample-max-length row2)))
+    (if (zerop max1)
+        0
+      (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2))))))))
+
+(defun vcard-format-sample-max-length (strings)
+  (let ((maxlen 0))
     (while strings
-      (setq len (length (car strings)))
-      (setq strings (cdr strings))
-      (and (> len maxlen)
-           (setq maxlen len)))
+      (setq maxlen (max maxlen (length (car strings))))
+      (setq strings (cdr strings)))
     maxlen))
 
 (provide 'vcard)