235 lines
8.9 KiB
Scheme
235 lines
8.9 KiB
Scheme
(import (chicken base)
|
|
scheme
|
|
(scheme base)
|
|
(chicken foreign)
|
|
(chicken memory)
|
|
(chicken gc)
|
|
(chicken format)
|
|
rfc3339
|
|
coops
|
|
coops-primitive-objects)
|
|
|
|
(foreign-declare "#include <toml.h>")
|
|
|
|
(define (zeropad n)
|
|
(if (< n 10)
|
|
(sprintf "0~S" n)
|
|
(sprintf "~S" n)))
|
|
|
|
(define (set-toml-table-finalizer ttable)
|
|
(set-finalizer! ttable
|
|
(lambda (obj)
|
|
((foreign-lambda* void ((c-pointer ttp))
|
|
"toml_free(ttp);")
|
|
(ptr ttable)))))
|
|
|
|
(define-class <TomlArray> ()
|
|
((ptr :accessor ptr :initform #f)))
|
|
|
|
(define-class <TomlTable> ()
|
|
((ptr :accessor ptr :initform #f)))
|
|
|
|
|
|
|
|
(define-method (toml-self-key (tarr <TomlArray>))
|
|
((foreign-lambda* c-string ((c-pointer tarr))
|
|
"C_return(toml_array_key(tarr));")
|
|
(ptr tarr)))
|
|
|
|
(define-method (toml-count-entries (tarr <TomlArray>))
|
|
((foreign-lambda* int ((c-pointer tarr))
|
|
"C_return(toml_array_nelem(tarr));")
|
|
(ptr tarr)))
|
|
|
|
(define-method (toml-string (tarr <TomlArray>) (index <integer>))
|
|
((foreign-primitive ((c-pointer tarr)
|
|
(int index))
|
|
"toml_datum_t datum = toml_string_at(tarr, index);"
|
|
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
|
|
"C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
|
|
"free(datum.u.s);"
|
|
"C_values(3, data);")
|
|
(ptr tarr) index))
|
|
|
|
(define-method (toml-bool (tarr <TomlArray>) (index <integer>))
|
|
((foreign-lambda* bool ((c-pointer tarr)
|
|
(int index))
|
|
"C_return(toml_bool_at(tarr, index).u.b);")
|
|
(ptr tarr) index))
|
|
|
|
(define-method (toml-int (tarr <TomlArray>) (index <integer>))
|
|
((foreign-lambda* int ((c-pointer tarr)
|
|
(int index))
|
|
"C_return(toml_int_at(tarr, index).u.i);")
|
|
(ptr tarr) index))
|
|
|
|
(define-method (toml-double (tarr <TomlArray>) (index <integer>))
|
|
((foreign-lambda* double ((c-pointer tarr)
|
|
(int index))
|
|
"C_return(toml_double_at(tarr, index).u.d);")
|
|
(ptr tarr) index))
|
|
|
|
(define-method (toml-timestamp (tarr <TomlArray>) (index <integer>))
|
|
(let*-values (((Y M D h m s millis z)
|
|
((foreign-primitive ((c-pointer tarr)
|
|
(int index))
|
|
"toml_datum_t datum = toml_timestamp_at(tarr, index);"
|
|
"toml_timestamp_t* stamp = datum.u.ts;"
|
|
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
|
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
|
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
|
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
|
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
|
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
|
"free(datum.u.ts);"
|
|
"C_values(10, data);")
|
|
(ptr tarr) index))
|
|
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
|
Y (zeropad M) (zeropad D)
|
|
(zeropad h) (zeropad m) (zeropad s)
|
|
millis z)))
|
|
(string->rfc3339 rfcstr)))
|
|
|
|
(define-method (toml-array (tarr <TomlArray>) (index <integer>))
|
|
(make <TomlArray> 'ptr
|
|
((foreign-lambda* c-pointer ((c-pointer tarr)
|
|
(int index))
|
|
"C_return(toml_array_at(tarr, index));")
|
|
(ptr tarr) index)))
|
|
|
|
(define-method (toml-table (tarr <TomlArray>) (index <integer>))
|
|
(make <TomlTable> 'ptr
|
|
((foreign-lambda* c-pointer ((c-pointer tarr)
|
|
(int index))
|
|
"C_return(toml_table_at(tarr, index));")
|
|
(ptr tarr) index)))
|
|
|
|
|
|
|
|
(define (table-from-file filename)
|
|
(let ((ttp ((foreign-lambda* c-pointer ((c-string fname))
|
|
"FILE* fp = fopen(fname, \"r\");"
|
|
"char errbuf[200];"
|
|
"toml_table_t* conf = toml_parse_file(fp, errbuf, sizeof(errbuf));"
|
|
"fclose(fp);"
|
|
"C_return(conf);")
|
|
filename)))
|
|
(when (not (eq? ttp 0))
|
|
(let ((tomltable (make <TomlTable> 'ptr ttp)))
|
|
(set-toml-table-finalizer tomltable)
|
|
tomltable))))
|
|
|
|
(define (table-from-string str)
|
|
(let ((ttp ((foreign-lambda* c-pointer ((c-string confdata))
|
|
"char errbuf[200];"
|
|
"toml_table_t* conf = toml_parse(confdata, errbuf, sizeof(errbuf));"
|
|
"C_return(conf);")
|
|
str)))
|
|
(when (not (eq? ttp 0))
|
|
(let ((tomltable (make <TomlTable> 'ptr ttp)))
|
|
(set-toml-table-finalizer tomltable)
|
|
tomltable))))
|
|
|
|
(define (set-toml-datum-string-finalizer tdatum)
|
|
(set-finalizer! tdatum
|
|
(lambda (obj)
|
|
((foreign-lambda* void ((c-pointer tdat))
|
|
"free(tdat);")
|
|
(ptr tdatum)))))
|
|
|
|
(define-method (toml-self-key (ttbl <TomlTable>))
|
|
((foreign-lambda* c-string ((c-pointer ttbl))
|
|
"C_return(toml_table_key(ttbl));")
|
|
(ptr ttbl)))
|
|
|
|
(define-method (toml-key-exists? (ttbl <TomlTable>) (key <string>))
|
|
(= 1
|
|
((foreign-lambda* int ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_key_exists(ttbl, key));")
|
|
(ptr ttbl) key)))
|
|
|
|
(define-method (toml-count-key-vals (ttbl <TomlTable>))
|
|
((foreign-lambda* int ((c-pointer ttbl))
|
|
"C_return(toml_table_nkval(ttbl));")
|
|
(ptr ttbl)))
|
|
|
|
(define-method (toml-count-arrays (ttbl <TomlTable>))
|
|
((foreign-lambda* int ((c-pointer ttbl))
|
|
"C_return(toml_table_narr(ttbl));")
|
|
(ptr ttbl)))
|
|
|
|
(define-method (toml-count-tables (ttbl <TomlTable>))
|
|
((foreign-lambda* int ((c-pointer ttbl))
|
|
"C_return(toml_table_ntab(ttbl));")
|
|
(ptr ttbl)))
|
|
|
|
(define-method (toml-key-at (ttbl <TomlTable>) (index <integer>))
|
|
((foreign-lambda* c-string ((c-pointer ttbl)
|
|
(int index))
|
|
"C_return(toml_key_in(ttbl, index));")
|
|
(ptr ttbl) index))
|
|
|
|
(define-method (toml-string (ttbl <TomlTable>) (key <string>))
|
|
((foreign-primitive ((c-pointer ttbl)
|
|
(c-string key))
|
|
"toml_datum_t datum = toml_string_in(ttbl, key);"
|
|
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
|
|
"C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
|
|
"free(datum.u.s);"
|
|
"C_values(3, data);")
|
|
(ptr ttbl) key))
|
|
|
|
(define-method (toml-bool (ttbl <TomlTable>) (key <string>))
|
|
((foreign-lambda* bool ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_bool_in(ttbl, key).u.b);")
|
|
(ptr ttbl) key))
|
|
|
|
(define-method (toml-int (ttbl <TomlTable>) (key <string>))
|
|
((foreign-lambda* int ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_int_in(ttbl, key).u.i);")
|
|
(ptr ttbl) key))
|
|
|
|
(define-method (toml-double (ttbl <TomlTable>) (key <string>))
|
|
((foreign-lambda* double ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_double_in(ttbl, key).u.d);")
|
|
(ptr ttbl) key))
|
|
|
|
(define-method (toml-timestamp (ttbl <TomlTable>) (key <string>))
|
|
(let*-values (((Y M D h m s millis z)
|
|
((foreign-primitive ((c-pointer ttbl)
|
|
(c-string key))
|
|
"toml_datum_t datum = toml_timestamp_in(ttbl, key);"
|
|
"toml_timestamp_t* stamp = datum.u.ts;"
|
|
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
|
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
|
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
|
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
|
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
|
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
|
"free(datum.u.ts);"
|
|
"C_values(10, data);")
|
|
(ptr ttbl) key))
|
|
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
|
Y (zeropad M) (zeropad D)
|
|
(zeropad h) (zeropad m) (zeropad s)
|
|
millis z)))
|
|
(string->rfc3339 rfcstr)))
|
|
|
|
(define-method (toml-array (ttbl <TomlTable>) (key <string>))
|
|
(make <TomlArray> 'ptr
|
|
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_array_in(ttbl, key));")
|
|
(ptr ttbl) key)))
|
|
|
|
(define-method (toml-table (ttbl <TomlTable>) (key <string>))
|
|
(make <TomlTable> 'ptr
|
|
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
|
(c-string key))
|
|
"C_return(toml_table_in(ttbl, key));")
|
|
(ptr ttbl) key)))
|