cgit.sxemacs.org Git - packages/blob - xemacs-packages/gnus/lisp/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 ;; 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 3, or (at your option)
  13 ;; any later version.
  14 ;;
  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.
  19 ;;
  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.
  24
  25 ;;; Commentary:
  26
  27 ;; The display routines here are just an example.  The primitives in the
  28 ;; first section can be used to construct other vcard formatters.
  29
  30 ;;; Code:
  31
  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'.")
  37
  38 (defun vcard-parse-string (raw &optional filter)
  39   "Parse RAW vcard data as a string, and return an alist representing data.
  40
  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.
  45
  46 Vcard data is normally in the form
  47
  48     begin:        vcard
  49     key1:         field
  50     key2;subkey1: field
  51     key2;subkey2: field1;field2;field3
  52     end:          vcard
  53
  54 \(Whitespace after the colon separating the key and field is optional.\)
  55 If supplied to this function an alist of the form
  56
  57     ((\"key1\" \"field\")
  58      (\"key2\"
  59       (\"subkey2\" \"field1\" \"field2\" \"field3\")
  60       (\"subkey1\" \"field\")))
  61
  62 would be returned."
  63   (save-match-data
  64     (let ((raw-pos 0)
  65           (vcard-data nil)
  66           key data)
  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))
  70                   (string-match
  71                    "^[ \t]*\\([^:]+\\):[ \t]*\\(.*\\)[ \t]*[\n\r]+"
  72                    raw raw-pos))
  73         (setq key (vcard-matching-substring 1 raw))
  74         (setq data (vcard-matching-substring 2 raw))
  75         (setq raw-pos (match-end 0))
  76         (cond
  77          ((string= key "end")
  78           (setq raw-pos (length raw)))
  79          (t
  80           (and filter
  81                (setq data (funcall filter key data)))
  82           (setq vcard-data
  83                 (vcard-set-alist-slot vcard-data
  84                                       (vcard-split-string key ";")
  85                                       (vcard-split-string data ";"))))))
  86       (nreverse vcard-data))))
  87
  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
  91 keys."
  92   (cond ((listp key)
  93          (vcard-alist-assoc key vcard-data))
  94         ((and (stringp key)
  95               (save-match-data
  96                 (string-match ";" key)))
  97          (vcard-alist-assoc (vcard-split-string key ";") vcard-data))
  98         ((stringp key)
  99          (cdr (assoc key vcard-data)))))
 100
 101 \f
 102 ;;; Vcard data filters.
 103
 104 ;; These receive both the key and data, but are expected to operate on (and
 105 ;; return) just the data.
 106 ;;
 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
 111 ;; every other MUA).
 112 ;;
 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.
 116
 117 (defun vcard-filter-apply-filter-list (filter-list key data)
 118   (while filter-list
 119     (setq data (funcall (car filter-list) key data))
 120     (setq filter-list (cdr filter-list)))
 121   data)
 122
 123 (defun vcard-standard-filter (key data)
 124   (vcard-filter-apply-filter-list vcard-standard-filters key data))
 125
 126 (defun vcard-filter-html (key data)
 127   (save-match-data
 128     (while (string-match "<[^<>\n]+>" data)
 129       (setq data (concat (substring data 0 (match-beginning 0))
 130                          (substring data (match-end 0)))))
 131     data))
 132
 133 \f
 134 ;;; Utility routines.
 135
 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)))
 141   alist)
 142
 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))
 153           ((and elt key-list)
 154            (setcdr elt (vcard-set-alist-slot nil key-list value)))
 155           (elt (setcdr elt value))
 156           (t
 157            (let ((new))
 158              (setq key-list (nreverse (cons key key-list)))
 159              (while key-list
 160                (if new
 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)))
 164
 165              (cond ((null alist)
 166                     (setq alist (cons new nil)))
 167                    (t
 168                     (setcdr alist (cons (car alist) (cdr alist)))
 169                     (setcar alist new))))))
 170     alist))
 171
 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)
 178       (if string
 179           (substring string (match-beginning n) (match-end n))
 180         (buffer-substring (match-beginning n) (match-end n)))))
 181
 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)
 186   (let* ((list nil)
 187          (pos 0))
 188     (save-match-data
 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)))))
 193
 194 (defun vcard-flatten (l)
 195   (if (consp l)
 196       (apply 'nconc (mapcar 'vcard-flatten l))
 197     (list l)))
 198
 199 \f
 200 ;;; Sample formatting routines.
 201
 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))
 208          (formatted-lines
 209           (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n")))
 210     (if (string= formatted-lines "")
 211         formatted-lines
 212       (concat edge formatted-lines edge))))
 213
 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"))
 220
 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)))
 230          (l lines))
 231     (while 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.
 235       (and (cdr tel)
 236            (null (cdr l))
 237            (setcdr l (cons "" nil)))
 238       (setq l (cdr l))
 239       (setq tel (cdr tel)))
 240     lines))
 241
 242
 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))))
 247     (if email
 248         (format "%s <%s>" name email)
 249       name)))
 250
 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)
 255                    addr-raw
 256                  (list 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)
 260                      ((cdr city-list)
 261                       (format "%s, %s"
 262                               (car city-list)
 263                               (mapconcat 'identity (cdr city-list) " ")))
 264                      (t (car city-list)))))
 265     (delete nil
 266             (if city
 267                 (append street (list city))
 268               street))))
 269
 270 (defun vcard-format-get-telephone (vcard-data)
 271   (delete nil
 272           (mapcar (function (lambda (x)
 273                               (let ((result (vcard-format-ref (car x)
 274                                                               vcard-data)))
 275                                 (and result
 276                                      (concat (cdr x) result)))))
 277                   '((("tel" "work") . "Work: ")
 278                     (("tel" "home") . "Home: ")
 279                     (("tel" "fax")  . "Fax:  ")))))
 280
 281 (defun vcard-format-ref (key vcard-data)
 282   (setq key (vcard-ref key vcard-data))
 283   (or (cdr key)
 284       (setq key (car key)))
 285   (and (stringp key)
 286        (string= key "")
 287        (setq key nil))
 288   key)
 289
 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)))))))
 295
 296 (defun vcard-format-max-length (strings)
 297   (let ((maxlen 0)
 298         (len 0))
 299     (while strings
 300       (setq len (length (car strings)))
 301       (setq strings (cdr strings))
 302       (and (> len maxlen)
 303            (setq maxlen len)))
 304     maxlen))
 305
 306 (provide 'vcard)
 307
 308 ;;; arch-tag: 64df032f-e54c-4cfb-9e8c-8bead284f61b
 309 ;;; vcard.el ends here