From 7bbf2470bbdc46089dec1eb4c2328d0c87ba594f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 3 Aug 2020 12:39:30 +0200 Subject: Resolve (datetime instance) TODO with ./configure? Tried adding a ./configure script, which mostly is responsible for downloading a default zoneinfo file, and setting up the environment for the program. I have for quite a while thought about having a configure system for things like these, but also for setting up default paths. Let's see if it works out. --- configure | 44 ++++++++++++++++++++++++++++++++++++++++++++ module/.gitignore | 1 + module/datetime/instance.scm | 41 ++++++++++++++++++++++++++++------------- module/main.scm | 8 ++++++++ module/output/ical.scm | 8 +++++--- module/util/config.scm | 3 +++ tzget | 5 +++++ 7 files changed, 94 insertions(+), 16 deletions(-) create mode 100755 configure create mode 100644 module/.gitignore diff --git a/configure b/configure new file mode 100755 index 00000000..30a78a24 --- /dev/null +++ b/configure @@ -0,0 +1,44 @@ +#!/usr/bin/guile \ +--no-auto-compile -s +!# + +(define // file-name-separator-string) + +(define here (cond ((current-filename) => dirname) + (else (getcwd)))) +(define module-dir (string-append here // "module")) +(add-to-load-path module-dir) + +(use-modules (util)) + +;; --with-zoneinfo +(define zoneinfo #t) + +;; when zoneinfo +(use-modules (ice-9 rdelim)) + +(define pipe + (-> here + (string-append "/tzget") + ((@ (ice-9 popen) open-input-pipe)))) +(define path (read-line pipe)) +(define names (string-split (read-line pipe) #\space)) + +(use-modules (util io) + (datetime)) +(with-atomic-output-to-file + (string-append module-dir // "autoconfig.scm") + (lambda () + (display ";;; Commentary:") (newline) + (display ";;; File genererated by ./configure on ") + (display (datetime->string + (current-datetime) "~Y-~m-~d ~H:~M:~S~Z")) + (newline) + (display ";;; DONT make any manual changes") (newline) + (display ";;; Code:") (newline) + (for-each (@ (ice-9 pretty-print) pretty-print) + `((define-module (autoconfig) + use-module: (util config)) + ,@(when zoneinfo + `((set-config! 'tz-file ,path) + (set-config! 'tz-list (quote ,names)))))))) diff --git a/module/.gitignore b/module/.gitignore new file mode 100644 index 00000000..0eaae741 --- /dev/null +++ b/module/.gitignore @@ -0,0 +1 @@ +autoconfig.scm diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index 9ec883e2..048c9a9b 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -1,20 +1,35 @@ (define-module (datetime instance) :use-module (util) - :use-module (ice-9 rdelim) + :use-module (util config) :use-module (datetime zic) :export (zoneinfo)) +(define-config tz-dir #f + "Directory in which zoneinfo files can be found") + +(define-config tz-list '() + "List of default zoneinfo files to be parsed") + + +(define / file-name-separator-string) ;; TODO see (vcomponent instance), this has a similar problem with early load -(define-once - zoneinfo - (let* ((pipe - (-> (@ (global) basedir) - dirname - (string-append "/tzget") - ((@ (ice-9 popen) open-input-pipe)))) - (path (read-line pipe)) - (names (string-split (read-line pipe) #\space))) - (read-zoneinfo - (map (lambda (s) (string-append path file-name-separator-string s)) - names)))) +(define-once zoneinfo + (let ((cache (make-hash-table))) + (label self + (case-lambda + (() + (define tz-dir (get-config 'tz-dir)) + (define tz-list (get-config 'tz-list)) + (when (or (not tz-dir) (null? tz-list)) + (error "Default zoneinfo only available when tz-dir and tz-list are configured")) + (self tz-dir tz-list)) + ((directory file-list) + (let ((key (cons directory file-list))) + (aif (hash-ref cache key) + it + (let ((tz (read-zoneinfo + (map (lambda (s) (string-append directory / s)) + file-list)))) + (hash-set! cache key tz) + tz)))))))) diff --git a/module/main.scm b/module/main.scm index a0708275..98a07c44 100644 --- a/module/main.scm +++ b/module/main.scm @@ -5,6 +5,14 @@ (set! (@ (global) basedir) (car %load-path)) +(catch 'misc-error + (lambda () (use-modules (autoconfig))) + (lambda (err caller fmt args . rest) + (if (eqv? (caadr args) 'autoconfig) + (format (current-error-port) "Run ./configure first~%") + (format (current-error-port) "~?~%" fmt args)) + (exit 1))) + (use-modules (srfi srfi-1) (srfi srfi-88) ; keyword syntax diff --git a/module/output/ical.scm b/module/output/ical.scm index a9d325f8..203c6d0e 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -16,7 +16,7 @@ :use-module (output types) :use-module (output common) :autoload (vcomponent instance) (global-event-object) - :autoload (datetime instance) (zoneinfo) + :use-module ((datetime instance) :select (zoneinfo)) ) @@ -172,7 +172,7 @@ (awhen (param (prop* event 'DTSTART) 'TZID) ;; TODO this is broken - (add-child! cal (zoneinfo->vtimezone zoneinfo it))) + (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) (unless (prop event 'UID) (set! (prop event 'UID) @@ -213,7 +213,9 @@ CALSCALE:GREGORIAN\r (for-each component->ical-string ;; TODO we realy should send the earliest event from each timezone here, ;; instead of just the first. - (map (lambda (name) (zoneinfo->vtimezone zoneinfo name (car events))) + (map (lambda (name) (zoneinfo->vtimezone + (zoneinfo) + name (car events))) tz-names))) (for-each component->ical-string events) diff --git a/module/util/config.scm b/module/util/config.scm index 0b6677fa..f324ff63 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -88,6 +88,9 @@ (cond [(not value) (set-value! conf #f) ((config-attribute conf #:post identity) #f)] + [(unconfig? conf) + (hashq-set! config-values key + (make-unconfig value))] [((config-attribute conf #:pre identity) value) => (lambda (it) diff --git a/tzget b/tzget index 1fd2340a..bd81e4b7 100755 --- a/tzget +++ b/tzget @@ -1,5 +1,10 @@ #!/bin/bash +# Downloads zoneinfo files if not already present +# echos 2 lines, +# - the directory with the zoneinfo files +# - the names of the zoneinfo files to be parsed + CACHE_DIR=${CACHE_DIR:-~/.cache/calp} RELEASE=2020a TZ_SRC="https://github.com/eggert/tz/archive/$RELEASE.tar.gz" -- cgit v1.2.3