From 8be804ad5f9e91befa0d1d5738b242ebc368cf36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 4 Nov 2019 14:14:53 +0100 Subject: Maybe fixed timezone? --- module/vcomponent.scm | 80 ++++++++++++++++++------------- module/vcomponent/base.scm | 4 +- module/vcomponent/parse.scm | 2 +- module/vcomponent/recurrence/generate.scm | 37 ++++++++++++++ 4 files changed, 86 insertions(+), 37 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 871ac2e7..add08775 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -26,6 +26,7 @@ (define (parse-dates! cal) "Parse all start times into scheme date objects." + #; (for tz in (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children cal)) (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) (children tz)) @@ -35,32 +36,45 @@ (make-tz-set tz))) (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal)) - (define dptr (attr* ev 'DTSTART)) - (define eptr (attr* ev 'DTEND)) - - (define date (parse-datetime (value dptr))) - (define end-date - (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] - [(not eptr) - (let ((d (set (date-hour date) = (+ 1)))) - (set! (attr ev 'DTEND) d - eptr (attr* ev 'DTEND)) - d)] - [(value eptr) => parse-datetime] - [else - (set (date-hour date) = (+ 1))])) - - (set! (value dptr) (date->time-utc date) - (value eptr) (date->time-utc end-date)) - - (when (prop (attr* ev 'DTSTART) 'TZID) - (set! (zone-offset date) (get-tz-offset ev) - (value dptr) (date->time-utc date) - - ;; The standard says that DTEND must have the same - ;; timezone as DTSTART. Here we trust that blindly. - (zone-offset end-date) (zone-offset date) - (value eptr) (date->time-utc end-date))))) + (let ((tz (getenv "TZ"))) + (aif (prop (attr* ev 'DTSTART) 'TZID) + (setenv "TZ" (car it)) + (unsetenv "TZ")) + (let* + ((dptr (attr* ev 'DTSTART)) + (eptr (attr* ev 'DTEND)) + + (date (parse-datetime (value dptr))) + (end-date + (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] + [(not eptr) + (let ((d (set (date-hour date) = (+ 1)))) + (set! (attr ev 'DTEND) d + eptr (attr* ev 'DTEND)) + d)] + [(value eptr) => parse-datetime] + [else + (set (date-hour date) = (+ 1))]))) + + (set! (value dptr) (date->time-utc date) + (value eptr) (date->time-utc end-date)) + + (when (prop (attr* ev 'DTSTART) 'TZID) + ;; (format (current-error-port) "date = ~a~%" date) + (set! (zone-offset date) (zone-offset (time-utc->date (value dptr)))) + ;; (format (current-error-port) "date = ~a~%" date) + ;; set! (zone-offset date) (get-tz-offset ev) + + (set! + (value dptr) (date->time-utc date) + + ;; The standard says that DTEND must have the same + ;; timezone as DTSTART. Here we trust that blindly. + (zone-offset end-date) (zone-offset date) + (value eptr) (date->time-utc end-date)))) + + + (setenv "TZ" tz)))) (define* (parse-calendar path) @@ -97,14 +111,12 @@ (for component in (children cal) (case (type component) ((VTIMEZONE) - (set! tz (cons component tz)) - #; - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - (filter (lambda (o) (eq? 'VTIMEZONE (type o))) - (children accum))) - (add-child! accum component))) + ;; (set! tz (cons component tz)) + (unless (find (lambda (o) (and (eq? 'VTIMEZONE (type o)) + (string=? (attr o "TZID") + (attr component "TZID")))) + (children accum)) + (add-child! accum component))) ((VEVENT) (add-child! accum component) ) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 52bbe0c3..2041e126 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -16,8 +16,8 @@ (value get-vline-value set-vline-value!) (parameters get-vline-parameters)) -(define*-public (make-vline value #:optional ht) - (make-vline% value (or ht (make-hash-table)))) +(define*-public (make-vline value #:optional (ht (make-hash-table))) + (make-vline% value ht)) (define-record-type (make-vcomponent% type children parent attributes) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 04a06d54..f862b18a 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -40,7 +40,7 @@ (define (fold-proc ctx c) - ;; First extra character optionall read is to get the \n if our line + ;; First extra character optional read is to get the \n if our line ;; ended with \r\n. Secound read is to get the first character of the ;; next line. The initial \r which might recide in @var{c} is discarded. (let ((pair (cons (if (char=? #\newline (integer->char c)) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 3f4cb869..ea17b0e0 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -43,6 +43,41 @@ ;; TODO My current naïve aproach to simple adding a constant time to an event ;; breaks with time-zones. betwen 12:00 two adjacent days might NOT be 24h. ;; Specifically, 23h or 25h when going between summer and "normal" time. + +(define (next-event ev r) + (let ((e (copy-vcomponent ev)) + (tz (getenv "TZ"))) + ;; (setenv "TZ" (car (prop (attr* e 'DTSTART) 'TZID))) + (aif (prop (attr* e 'DTSTART) 'TZID) + (setenv "TZ" (car it)) + ;; Should missing be this, or explicitly GMT? + (unsetenv "TZ")) + + (let ((d (time-utc->date (attr e 'DTSTART))) + (i (interval r))) + (case (freq r) + ((SECONDLY) (mod! (second d) = (+ i))) + ((MINUTELY) (mod! (minute d) = (+ i))) + ((HOURLY) (mod! (hour d) = (+ i))) + ((DAILY) (mod! (day d) = (+ i))) + ((WEEKLY) (mod! (day d) = (+ (* i 7)))) + ((MONTHLY) (mod! (month d) = (+ i))) + ((YEARLY) (mod! (year d) = (+ i)))) + + (set! (zone-offset d) + (zone-offset (time-utc->date (date->time-utc d)))) + + (set! (attr e 'DTSTART) (date->time-utc d))) + + (when (attr e 'DTEND) + (set! (attr e 'DTEND) + (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) + + (setenv "TZ" tz) + + e)) + +#; (define (next-event ev r) (let* ((e (copy-vcomponent ev)) (d (time-utc->date @@ -68,6 +103,8 @@ (date->time-utc d)) (when (prop (attr* e 'DTSTART) 'TZID) + ;; (list "Europe/Stockholm"), or similar + ;; (format (current-error-port) "TZID = ~a~%" (prop (attr* e 'DTSTART) 'TZID)) (let ((of (get-tz-offset e))) ;; This addition works, but we still get lunch at 13 (set! (zone-offset d) of))) -- cgit v1.2.3