;;; vcard.el --- vcard parsing and display routines
-;; Copyright (C) 1997 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
+;; <http://www.splode.com/users/friedman/software/emacs-lisp/>
+;; Id: vcard.el,v 1.11 2000/06/29 17:07:55 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
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;;; 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)
+
+\f
+;;; No user-settable options below.
+
+;; XEmacs 21 ints and chars are disjoint types.
+;; For all else, treat them as the same.
+(defalias 'vcard-char-to-int
+ (if (fboundp 'char-to-int) 'char-to-int 'identity))
+
+;; 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 (vcard-char-to-int (aref a i)) i)
+ (setq i (1+ i)))
+ tbl))
+
+\f
+;;; 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))
+
+\f
+;;; 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 ((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 (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 (set-marker (make-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))
\f
-;;; 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.
+\f
+;;; 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))))))
\f
-;;; 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* ((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 (nreverse (cons key 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.
+
+(defmacro vcard-hexstring-to-ascii (s)
+ (if (string-lessp emacs-version "20")
+ `(format "%c" (car (read-from-string (format "?\\x%s" ,s))))
+ `(format "%c" (string-to-number ,s 16))))
+
+(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 (vcard-hexstring-to-ascii s) 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
+ (vcard-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))))))))))
+
+\f
+(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)
\f
;;; 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
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)))
(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)
(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)
-;;; arch-tag: 64df032f-e54c-4cfb-9e8c-8bead284f61b
;;; vcard.el ends here
projects / gnus / blobdiff