Jaidyn Ann
246cec13ad
Changes the format from ((PROP TRAIT1 TRAIT2 …) (VALUE1 VALUE2 …)) to (PROP (TRAIT1 TRAIT2 …) VALUE1 VALUE2 …) Also makes the line-splitting functions more generic and efficient.
148 lines
4.7 KiB
Scheme
148 lines
4.7 KiB
Scheme
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
||
;;
|
||
;; 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 3 of
|
||
;; the License, or (at your option) any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
|
||
(import
|
||
scheme
|
||
(chicken io)
|
||
srfi-1
|
||
srfi-13
|
||
srfi-130
|
||
(prefix uri-common uri:))
|
||
|
||
|
||
(define (uri->string uri-or-str)
|
||
(if (uri:uri? uri-or-str)
|
||
(uri:uri->string uri-or-str)
|
||
uri-or-str))
|
||
|
||
|
||
(define (string->uri . strs)
|
||
(if (and (not (null? strs))
|
||
(string? (car strs)))
|
||
(uri:uri-reference (string-join strs ";"))
|
||
strs))
|
||
|
||
|
||
(define (csv-string->list str)
|
||
(string-split str ","))
|
||
|
||
|
||
(define (list->csv-string list)
|
||
(string-join list ","))
|
||
|
||
|
||
(define vcard-value-parsers
|
||
(list
|
||
(list 'PHOTO string->uri uri->string)
|
||
(list 'LOGO string->uri uri->string)
|
||
(list 'MEMBER string->uri uri->string)
|
||
(list 'SOUND string->uri uri->string)
|
||
(list 'UID string->uri uri->string)
|
||
(list 'URL string->uri uri->string)
|
||
(list 'KEY string->uri uri->string)
|
||
(list 'FBURL string->uri uri->string)
|
||
(list 'CALADRURI string->uri uri->string)
|
||
(list 'CALURI string->uri uri->string)
|
||
(list 'RELATED string->uri uri->string)
|
||
(list 'CATEGORIES csv-string->list list->csv-string)
|
||
(list 'IMPP string->uri uri->string)
|
||
(list 'GEO string->uri uri->string)))
|
||
|
||
|
||
;; 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.
|
||
(define (lines string)
|
||
(remove string-null? (string-split string "\r\n")))
|
||
|
||
|
||
;; Splits a line into a cons of the property-string and value-string.
|
||
;; … basically splits the string along the first unescaped colon (:).
|
||
;; "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad")
|
||
(define (split-vcard-line line)
|
||
(let [(split (string-split-nonescaped line ":"))]
|
||
(cons (car split)
|
||
(string-join (cdr split) ":"))))
|
||
|
||
|
||
;; Splits a string along a delimiter; while not splitting along
|
||
;; backslash-escaped delimiters. With “;” as the delimiter:
|
||
;; "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom")
|
||
(define (string-split-nonescaped string delimiter)
|
||
(let [(appendee "")]
|
||
(remove
|
||
not
|
||
(map (lambda (substr)
|
||
(let [(substr (string-concatenate (list appendee substr)))]
|
||
(if (and (not (string-null? substr))
|
||
(eq? (last (string->list substr))
|
||
#\\))
|
||
(and (set! appendee
|
||
(string-concatenate (list substr delimiter)))
|
||
#f)
|
||
(and (set! appendee "") substr))))
|
||
(string-split string delimiter)))))
|
||
|
||
|
||
(define (parse-vcard-prop property elements)
|
||
(append (list property)
|
||
(list elements)))
|
||
|
||
|
||
(define (parse-vcard-value prop elements)
|
||
(let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
|
||
(if parser-and-unparser-funcs
|
||
(list (apply (car parser-and-unparser-funcs) (list elements)))
|
||
(list elements))))
|
||
|
||
|
||
;; 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* [(prop-value-strings (split-vcard-line line))
|
||
(prop-elements (string-split-nonescaped (car prop-value-strings) ";"))
|
||
(value-elements (cdr prop-value-strings))
|
||
(property (string->symbol (string-upcase (car prop-elements))))]
|
||
(append (parse-vcard-prop property (cdr prop-elements))
|
||
(parse-vcard-value property value-elements))))
|
||
|
||
|
||
;; Reader thunk. Read/parse an entire vcard into a “vcard alist.”
|
||
(define (read-vcard)
|
||
(let [(element (read-vcard-element))]
|
||
(if (not (eof-object? (peek-char)))
|
||
(append (list element) (read-vcard))
|
||
element)))
|
||
|
||
|
||
;; Read a single unfolded line into a vcard “element” list.
|
||
(define (read-vcard-element)
|
||
(parse-vcard-line (read-folded-line)))
|
||
|
||
|
||
;; Reader-thunk. Read a “logical” folded-line, where a line beginning with a
|
||
;; space is a continuation of the previous line — like with vcards.
|
||
(define (read-folded-line)
|
||
(let [(line (read-line))]
|
||
(if (eq? (peek-char) #\space)
|
||
(string-concatenate
|
||
(list line
|
||
(string-drop (read-folded-line) 1)))
|
||
line)))
|