diff --git a/vcarded.scm b/vcarded.scm index 13642c8..e167d7b 100644 --- a/vcarded.scm +++ b/vcarded.scm @@ -13,12 +13,18 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . + (import scheme (chicken io) (chicken irregex) - (chicken string) - srfi-1) + srfi-1 + srfi-130) + + +;; Splits a string into a list of CRLF’d lines. +(define (unlines lines) + (string-join lines "\r\n")) ;; Splits a string into a list of CRLF’d lines. @@ -33,27 +39,41 @@ ;; Splits a line into a list of key/value pairs. (define (split-vcard-line line) - (let ([split (irregex-split (regex-unescaped-char ":") line)]) + (let [(split (irregex-split (regex-unescaped-char ":") line))] (if (>= (length split) 2) (cons (car split) - (reduce-right (lambda (a b) (conc a ":" b)) "" (cdr split))) + (reduce-right + (lambda (a b) (string-concatenate (list a ":" b))) + "" (cdr split))) #f))) ;; Splits a key or value-element into its (potentially multiple) parameters. (define (split-vcard-element key-or-value) - (irregex-split (regex-unescaped-char ";") key-or-value)) + (irregex-extract "(\\\\;|[^;])*" key-or-value)) + + +(define (parse-vcard-element kv-pair) + (case (car kv-pair) + ('VERSION + (append (list (car kv-pair) (string->number (second kv-pair))) + (cddr kv-pair))) + (else kv-pair))) ;; Parse a line of a vcard file into an alist-friendly format: ;; (KEY ("keyprop1=d" "keyprop2=b") "VALUE" ("valprop1=a" "valprop2=b")) (define (parse-vcard-line line) - (let* ([key-value-strings (split-vcard-line line)] - [key-elements (split-vcard-element (car key-value-strings))] - [value-elements (split-vcard-element (cdr key-value-strings))]) + (let* [(key-value-strings (split-vcard-line line)) + (key-elements (split-vcard-element (car key-value-strings))) + (value-elements (split-vcard-element (cdr key-value-strings)))] (list (string->symbol (car key-elements)) - (cdr key-elements) (car value-elements) + (cdr key-elements) (cdr value-elements)))) + +(define (vcard-string->alist string) + (map parse-vcard-line (lines string))) +