1 ;;; vcard.el --- vcard parsing and display routines
3 ;; Copyright (C) 1997 Noah S. Friedman
5 ;; Author: Noah Friedman <friedman@splode.com>
6 ;; Maintainer: friedman@splode.com
7 ;; Keywords: extensions
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; if not, you can either send email to this
22 ;; program's maintainer or write to: The Free Software Foundation,
23 ;; Inc.; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
27 ;; The display routines here are just an example. The primitives in the
28 ;; first section can be used to construct other vcard formatters.
32 (defvar vcard-standard-filters '(vcard-filter-html)
33 "*Standard list of filters to apply to parsed vcard data.
34 These filters are applied sequentially to vcard data records when
35 the function `vcard-standard-filter' is supplied as the second argument to
36 `vcard-parse-string'.")
38 (defun vcard-parse-string (raw &optional filter)
39 "Parse RAW vcard data as a string, and return an alist representing data.
41 If the optional function FILTER is specified, apply that filter to the
42 data record of each key before splitting fields. Filters should accept
43 two arguments: the key and the data. They are expected to operate on
44 \(and return\) a modified data value.
46 Vcard data is normally in the form
51 key2;subkey2: field1;field2;field3
54 \(Whitespace after the colon separating the key and field is optional.\)
55 If supplied to this function an alist of the form
59 (\"subkey2\" \"field1\" \"field2\" \"field3\")
60 (\"subkey1\" \"field\")))
67 (string-match "^[ \t]*begin:[ \t]*vcard[ \t]*[\r\n]+" raw raw-pos)
68 (setq raw-pos (match-end 0))
69 (while (and (< raw-pos (length raw))
71 "^[ \t]*\\([^:]+\\):[ \t]*\\(.*\\)[ \t]*[\n\r]+"
73 (setq key (vcard-matching-substring 1 raw))
74 (setq data (vcard-matching-substring 2 raw))
75 (setq raw-pos (match-end 0))
78 (setq raw-pos (length raw)))
81 (setq data (funcall filter key data)))
83 (vcard-set-alist-slot vcard-data
84 (vcard-split-string key ";")
85 (vcard-split-string data ";"))))))
86 (nreverse vcard-data))))
88 (defun vcard-ref (key vcard-data)
89 "Return the vcard data associated with KEY in VCARD-DATA.
90 Key may be a list of nested keys or a single string of colon-separated
93 (vcard-alist-assoc key vcard-data))
96 (string-match ";" key)))
97 (vcard-alist-assoc (vcard-split-string key ";") vcard-data))
99 (cdr (assoc key vcard-data)))))
102 ;;; Vcard data filters.
104 ;; These receive both the key and data, but are expected to operate on (and
105 ;; return) just the data.
107 ;; There is probably no overwhelming need for this, except that some lusers
108 ;; put HTML in their vcards under the misguided notion that it's a standard
109 ;; feature of vcards just because Netscape supports this feature. (Or
110 ;; perhaps those lusers just don't care that their vcards look like shit in
113 ;; On the other hand, perhaps someone will devise some other use for these
114 ;; filters, such as noticing common phone number formats and re-formatting
115 ;; them to fit personal preferences.
117 (defun vcard-filter-apply-filter-list (filter-list key data)
119 (setq data (funcall (car filter-list) key data))
120 (setq filter-list (cdr filter-list)))
123 (defun vcard-standard-filter (key data)
124 (vcard-filter-apply-filter-list vcard-standard-filters key data))
126 (defun vcard-filter-html (key data)
128 (while (string-match "<[^<>\n]+>" data)
129 (setq data (concat (substring data 0 (match-beginning 0))
130 (substring data (match-end 0)))))
134 ;;; Utility routines.
136 ;; This does most of the dirty work of key lookup for vcard-ref.
137 (defun vcard-alist-assoc (keys alist)
138 (while (and keys alist)
139 (setq alist (cdr (assoc (car keys) alist)))
140 (setq keys (cdr keys)))
143 ;; In ALIST, set KEY-LIST's value to VALUE, and return new value of ALIST.
144 ;; KEY-LIST should be a list of nested keys, if ALIST is an alist of alists.
145 ;; If any key is not present in an alist, the key and value pair will be
146 ;; inserted into the parent alist.
147 (defun vcard-set-alist-slot (alist key-list value)
148 (let* ((key (car key-list))
149 (elt (assoc key alist)))
150 (setq key-list (cdr key-list))
151 (cond ((and (cdr elt) key-list)
152 (vcard-set-alist-slot (cdr elt) key-list value))
154 (setcdr elt (vcard-set-alist-slot nil key-list value)))
155 (elt (setcdr elt value))
158 (setq key-list (nreverse (cons key key-list)))
161 (setq new (cons (car key-list) (cons new nil)))
162 (setq new (cons (car key-list) value)))
163 (setq key-list (cdr key-list)))
166 (setq alist (cons new nil)))
168 (setcdr alist (cons (car alist) (cdr alist)))
169 (setcar alist new))))))
172 ;; Return substring matched by last search.
173 ;; N specifies which match data pair to use
174 ;; Value is nil if there is no Nth match.
175 ;; If STRING is not specified, the current buffer is used.
176 (defun vcard-matching-substring (n &optional string)
177 (if (match-beginning n)
179 (substring string (match-beginning n) (match-end n))
180 (buffer-substring (match-beginning n) (match-end n)))))
182 ;; Split STRING at occurences of SEPARATOR. Return a list of substrings.
183 ;; SEPARATOR can be any regexp, but anything matching the separator will
184 ;; never appear in any of the returned substrings.
185 (defun vcard-split-string (string separator)
189 (while (string-match separator string pos)
190 (setq list (cons (substring string pos (match-beginning 0)) list))
191 (setq pos (match-end 0)))
192 (nreverse (cons (substring string pos) list)))))
194 (defun vcard-flatten (l)
196 (apply 'nconc (mapcar 'vcard-flatten l))
200 ;;; Sample formatting routines.
202 (defun vcard-format-box (vcard-data)
203 "Like `vcard-format-string', but put an ascii box around text."
204 (let* ((lines (vcard-format-lines vcard-data))
205 (len (vcard-format-max-length lines))
206 (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
207 (line-fmt (format "| %%-%ds |" len))
209 (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
210 (if (string= formatted-lines "")
212 (concat edge formatted-lines edge))))
214 (defun vcard-format-string (vcard-data)
215 "Format VCARD-DATA into a string suitable for presentation.
216 VCARD-DATA should be a parsed vcard alist. The result is a string
217 with formatted vcard information which can be inserted into a mime
218 presentation buffer."
219 (mapconcat 'identity (vcard-format-lines vcard-data) "\n"))
221 (defun vcard-format-lines (vcard-data)
222 (let* ((name (vcard-format-get-name vcard-data))
223 (title (vcard-format-ref "title" vcard-data))
224 (org (vcard-format-ref "org" vcard-data))
225 (addr (vcard-format-get-address vcard-data))
226 (tel (vcard-format-get-telephone vcard-data))
227 (lines (delete nil (vcard-flatten (list name title org addr))))
228 (col-template (format "%%-%ds%%s"
229 (vcard-format-offset lines tel)))
232 (setcar l (format col-template (car l) (car tel)))
233 ;; If we stripped away too many nil slots from l, add empty strings
234 ;; back in so setcar above will work on next iteration.
237 (setcdr l (cons "" nil)))
239 (setq tel (cdr tel)))
243 (defun vcard-format-get-name (vcard-data)
244 (let ((name (vcard-format-ref "fn" vcard-data))
245 (email (or (vcard-format-ref '("email" "internet") vcard-data)
246 (vcard-format-ref "email" vcard-data))))
248 (format "%s <%s>" name email)
251 (defun vcard-format-get-address (vcard-data)
252 (let* ((addr-raw (or (vcard-format-ref '("adr" "dom") vcard-data)
253 (vcard-format-ref "adr" vcard-data)))
254 (addr (if (consp addr-raw)
257 (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
258 (city-list (delete "" (nthcdr 3 addr)))
259 (city (cond ((null (car city-list)) nil)
263 (mapconcat 'identity (cdr city-list) " ")))
264 (t (car city-list)))))
267 (append street (list city))
270 (defun vcard-format-get-telephone (vcard-data)
272 (mapcar (function (lambda (x)
273 (let ((result (vcard-format-ref (car x)
276 (concat (cdr x) result)))))
277 '((("tel" "work") . "Work: ")
278 (("tel" "home") . "Home: ")
279 (("tel" "fax") . "Fax: ")))))
281 (defun vcard-format-ref (key vcard-data)
282 (setq key (vcard-ref key vcard-data))
284 (setq key (car key)))
290 (defun vcard-format-offset (row1 row2 &optional maxwidth)
291 (or maxwidth (setq maxwidth (frame-width)))
292 (let ((max1 (vcard-format-max-length row1))
293 (max2 (vcard-format-max-length row2)))
294 (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2)))))))
296 (defun vcard-format-max-length (strings)
300 (setq len (length (car strings)))
301 (setq strings (cdr strings))
308 ;;; vcard.el ends here