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

   1 ;;; vcard.el --- vcard parsing and display routines
   2
   3 ;; Copyright (C) 1997 Noah S. Friedman
   4
   5 ;; Author: Noah Friedman <friedman@splode.com>
   6 ;; Maintainer: friedman@splode.com
   7 ;; Keywords: extensions
   8 ;; Created: 1997-09-27
   9
  10 ;; $Id: vcard.el,v 1.1 1999/11/15 20:50:18 larsi Exp $
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, you can either send email to this
  24 ;; program's maintainer or write to: The Free Software Foundation,
  25 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; The display routines here are just an example.  The primitives in the
  30 ;; first section can be used to construct other vcard formatters.
  31
  32 ;;; Code:
  33
  34 (defvar vcard-standard-filters '(vcard-filter-html)
  35   "*Standard list of filters to apply to parsed vcard data.
  36 These filters are applied sequentially to vcard data records when
  37 the function `vcard-standard-filter' is supplied as the second argument to
  38 `vcard-parse-string'.")
  39
  40 (defun vcard-parse-string (raw &optional filter)
  41   "Parse RAW vcard data as a string, and return an alist representing data.
  42
  43 If the optional function FILTER is specified, apply that filter to the
  44 data record of each key before splitting fields.  Filters should accept
  45 two arguments: the key and the data.  They are expected to operate on
  46 \(and return\) a modified data value.
  47
  48 Vcard data is normally in the form
  49
  50     begin:        vcard
  51     key1:         field
  52     key2;subkey1: field
  53     key2;subkey2: field1;field2;field3
  54     end:          vcard
  55
  56 \(Whitespace after the colon separating the key and field is optional.\)
  57 If supplied to this function an alist of the form
  58
  59     ((\"key1\" \"field\")
  60      (\"key2\"
  61       (\"subkey2\" \"field1\" \"field2\" \"field3\")
  62       (\"subkey1\" \"field\")))
  63
  64 would be returned."
  65   (save-match-data
  66     (let ((raw-pos 0)
  67           (vcard-data nil)
  68           key data)
  69       (string-match "^[ \t]*begin:[ \t]*vcard[ \t]*[\r\n]+" raw raw-pos)
  70       (setq raw-pos (match-end 0))
  71       (while (and (< raw-pos (length raw))
  72                   (string-match
  73                    "^[ \t]*\\([^:]+\\):[ \t]*\\(.*\\)[ \t]*[\n\r]+"
  74                    raw raw-pos))
  75         (setq key (vcard-matching-substring 1 raw))
  76         (setq data (vcard-matching-substring 2 raw))
  77         (setq raw-pos (match-end 0))
  78         (cond
  79          ((string= key "end")
  80           (setq raw-pos (length raw)))
  81          (t
  82           (and filter
  83                (setq data (funcall filter key data)))
  84           (setq vcard-data
  85                 (vcard-set-alist-slot vcard-data
  86                                       (vcard-split-string key ";")
  87                                       (vcard-split-string data ";"))))))
  88       (nreverse vcard-data))))
  89
  90 (defun vcard-ref (key vcard-data)
  91   "Return the vcard data associated with KEY in VCARD-DATA.
  92 Key may be a list of nested keys or a single string of colon-separated
  93 keys."
  94   (cond ((listp key)
  95          (vcard-alist-assoc key vcard-data))
  96         ((and (stringp key)
  97               (save-match-data
  98                 (string-match ";" key)))
  99          (vcard-alist-assoc (vcard-split-string key ";") vcard-data))
 100         ((stringp key)
 101          (cdr (assoc key vcard-data)))))
 102
 103 \f
 104 ;;; Vcard data filters.
 105
 106 ;; These receive both the key and data, but are expected to operate on (and
 107 ;; return) just the data.
 108 ;;
 109 ;; There is probably no overwhelming need for this, except that some lusers
 110 ;; put HTML in their vcards under the misguided notion that it's a standard
 111 ;; feature of vcards just because Netscape supports this feature.  (Or
 112 ;; perhaps those lusers just don't care that their vcards look like shit in
 113 ;; every other MUA).
 114 ;;
 115 ;; On the other hand, perhaps someone will devise some other use for these
 116 ;; filters, such as noticing common phone number formats and re-formatting
 117 ;; them to fit personal preferences.
 118
 119 (defun vcard-filter-apply-filter-list (filter-list key data)
 120   (while filter-list
 121     (setq data (funcall (car filter-list) key data))
 122     (setq filter-list (cdr filter-list)))
 123   data)
 124
 125 (defun vcard-standard-filter (key data)
 126   (vcard-filter-apply-filter-list vcard-standard-filters key data))
 127
 128 (defun vcard-filter-html (key data)
 129   (save-match-data
 130     (while (string-match "<[^<>\n]+>" data)
 131       (setq data (concat (substring data 0 (match-beginning 0))
 132                          (substring data (match-end 0)))))
 133     data))
 134
 135 \f
 136 ;;; Utility routines.
 137
 138 ;; This does most of the dirty work of key lookup for vcard-ref.
 139 (defun vcard-alist-assoc (keys alist)
 140   (while (and keys alist)
 141     (setq alist (cdr (assoc (car keys) alist)))
 142     (setq keys (cdr keys)))
 143   alist)
 144
 145 ;; In ALIST, set KEY-LIST's value to VALUE, and return new value of ALIST.
 146 ;; KEY-LIST should be a list of nested keys, if ALIST is an alist of alists.
 147 ;; If any key is not present in an alist, the key and value pair will be
 148 ;; inserted into the parent alist.
 149 (defun vcard-set-alist-slot (alist key-list value)
 150   (let* ((key (car key-list))
 151          (elt (assoc key alist)))
 152     (setq key-list (cdr key-list))
 153     (cond ((and (cdr elt) key-list)
 154            (vcard-set-alist-slot (cdr elt) key-list value))
 155           ((and elt key-list)
 156            (setcdr elt (vcard-set-alist-slot nil key-list value)))
 157           (elt (setcdr elt value))
 158           (t
 159            (let ((new))
 160              (setq key-list (nreverse (cons key key-list)))
 161              (while key-list
 162                (if new
 163                    (setq new (cons (car key-list) (cons new nil)))
 164                  (setq new (cons (car key-list) value)))
 165                (setq key-list (cdr key-list)))
 166
 167              (cond ((null alist)
 168                     (setq alist (cons new nil)))
 169                    (t
 170                     (setcdr alist (cons (car alist) (cdr alist)))
 171                     (setcar alist new))))))
 172     alist))
 173
 174 ;; Return substring matched by last search.
 175 ;; N specifies which match data pair to use
 176 ;; Value is nil if there is no Nth match.
 177 ;; If STRING is not specified, the current buffer is used.
 178 (defun vcard-matching-substring (n &optional string)
 179   (if (match-beginning n)
 180       (if string
 181           (substring string (match-beginning n) (match-end n))
 182         (buffer-substring (match-beginning n) (match-end n)))))
 183
 184 ;; Split STRING at occurences of SEPARATOR.  Return a list of substrings.
 185 ;; SEPARATOR can be any regexp, but anything matching the separator will
 186 ;; never appear in any of the returned substrings.
 187 (defun vcard-split-string (string separator)
 188   (let* ((list nil)
 189          (pos 0))
 190     (save-match-data
 191       (while (string-match separator string pos)
 192         (setq list (cons (substring string pos (match-beginning 0)) list))
 193         (setq pos (match-end 0)))
 194       (nreverse (cons (substring string pos) list)))))
 195
 196 (defun vcard-flatten (l)
 197   (if (consp l)
 198       (apply 'nconc (mapcar 'vcard-flatten l))
 199     (list l)))
 200
 201 \f
 202 ;;; Sample formatting routines.
 203
 204 (defun vcard-format-box (vcard-data)
 205   "Like `vcard-format-string', but put an ascii box around text."
 206   (let* ((lines (vcard-format-lines vcard-data))
 207          (len (vcard-format-max-length lines))
 208          (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n"))
 209          (line-fmt (format "| %%-%ds |" len))
 210          (formatted-lines
 211           (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
 212     (if (string= formatted-lines "")
 213         formatted-lines
 214       (concat edge formatted-lines edge))))
 215
 216 (defun vcard-format-string (vcard-data)
 217   "Format VCARD-DATA into a string suitable for presentation.
 218 VCARD-DATA should be a parsed vcard alist.  The result is a string
 219 with formatted vcard information which can be inserted into a mime
 220 presentation buffer."
 221   (mapconcat 'identity (vcard-format-lines vcard-data) "\n"))
 222
 223 (defun vcard-format-lines (vcard-data)
 224   (let* ((name  (vcard-format-get-name      vcard-data))
 225          (title (vcard-format-ref "title"   vcard-data))
 226          (org   (vcard-format-ref "org"     vcard-data))
 227          (addr  (vcard-format-get-address   vcard-data))
 228          (tel   (vcard-format-get-telephone vcard-data))
 229          (lines (delete nil (vcard-flatten (list name title org addr))))
 230          (col-template (format "%%-%ds%%s"
 231                                (vcard-format-offset lines tel)))
 232          (l lines))
 233     (while tel
 234       (setcar l (format col-template (car l) (car tel)))
 235       ;; If we stripped away too many nil slots from l, add empty strings
 236       ;; back in so setcar above will work on next iteration.
 237       (and (cdr tel)
 238            (null (cdr l))
 239            (setcdr l (cons "" nil)))
 240       (setq l (cdr l))
 241       (setq tel (cdr tel)))
 242     lines))
 243
 244
 245 (defun vcard-format-get-name (vcard-data)
 246   (let ((name (vcard-format-ref "fn" vcard-data))
 247         (email (or (vcard-format-ref '("email" "internet") vcard-data)
 248                    (vcard-format-ref "email" vcard-data))))
 249     (if email
 250         (format "%s <%s>" name email)
 251       name)))
 252
 253 (defun vcard-format-get-address (vcard-data)
 254   (let* ((addr-raw (or (vcard-format-ref '("adr" "dom") vcard-data)
 255                        (vcard-format-ref "adr" vcard-data)))
 256          (addr (if (consp addr-raw)
 257                    addr-raw
 258                  (list addr-raw)))
 259          (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr))))
 260          (city-list (delete "" (nthcdr 3 addr)))
 261          (city (cond ((null (car city-list)) nil)
 262                      ((cdr city-list)
 263                       (format "%s, %s"
 264                               (car city-list)
 265                               (mapconcat 'identity (cdr city-list) " ")))
 266                      (t (car city-list)))))
 267     (delete nil
 268             (if city
 269                 (append street (list city))
 270               street))))
 271
 272 (defun vcard-format-get-telephone (vcard-data)
 273   (delete nil
 274           (mapcar (function (lambda (x)
 275                               (let ((result (vcard-format-ref (car x)
 276                                                               vcard-data)))
 277                                 (and result
 278                                      (concat (cdr x) result)))))
 279                   '((("tel" "work") . "Work: ")
 280                     (("tel" "home") . "Home: ")
 281                     (("tel" "fax")  . "Fax:  ")))))
 282
 283 (defun vcard-format-ref (key vcard-data)
 284   (setq key (vcard-ref key vcard-data))
 285   (or (cdr key)
 286       (setq key (car key)))
 287   (and (stringp key)
 288        (string= key "")
 289        (setq key nil))
 290   key)
 291
 292 (defun vcard-format-offset (row1 row2 &optional maxwidth)
 293   (or maxwidth (setq maxwidth (frame-width)))
 294   (let ((max1 (vcard-format-max-length row1))
 295         (max2 (vcard-format-max-length row2)))
 296     (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2)))))))
 297
 298 (defun vcard-format-max-length (strings)
 299   (let ((maxlen 0)
 300         (len 0))
 301     (while strings
 302       (setq len (length (car strings)))
 303       (setq strings (cdr strings))
 304       (and (> len maxlen)
 305            (setq maxlen len)))
 306     maxlen))
 307
 308 (provide 'vcard)
 309
 310 ;;; vcard.el ends here.