;;;; locale-timezone.scm
;;;; From "dateutils.scm" by Graham Fawcett

(module locale-timezone (;export
  local-timezone
  local-timezone-offset
  with-tzset)

  (import chicken scheme)
  (require-extension posix)

  (declare
    (inline)
    (fixnum)
    (no-procedure-checks)
    (run-time-macros)
    (bound-to-procedure
      ##sys#error-hook) )

#>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#include <time.h>

#ifdef _WIN32
static struct tm *
localtime_r( const time_t *clock, struct tm *result )
{
  if (!clock || !result) return NULL;
  memcpy( result, localtime( clock ), sizeof( *result ) );
  return result;
}
#endif

static char *
get_tz( int yr, int mo, int dy, int hr, int mn, int sc, int as_offset )
{
  struct tm tm;
  time_t t;

  const int size = 31 + 1;
  char *buf = malloc( size * sizeof( char ) );

  memset( &tm, 0, sizeof tm );
  tm.tm_hour = hr;
  tm.tm_min = mn;
  tm.tm_sec = sc;
  tm.tm_year = yr - 1900;
  tm.tm_mon = mo;
  tm.tm_mday = dy;

  t = mktime( &tm );
  strftime( buf, size, (as_offset ? "%z" : "%Z"), localtime_r( &t, &tm ) );

  return buf;
}
<#

;;;

(define get-tz (foreign-lambda c-string* "get_tz" int int int int int int bool))

; #!required tm | hr mo dy #!optional (hr 12) (mn 0) (sc 0) #!key offset?
(define (*local-timezone loc . args)

  (let ((arglen (length args))
        (yr #f) (mo #f) (dy #f) (hr #f) (mn #f) (sc #f) (offset? #f))

    ; DSSSL lambda list parsing behavior as I wish it was
    (unless (<= 1 arglen) (##sys#error-hook 2 loc arglen 1))
    (if (vector? (car args))
        (let ((tm (car args)))
          (when (< (vector-length tm) 10) (error loc "time vector too short" tm))
          (set! yr (+ (vector-ref tm 5) 1900))
          (set! mo (vector-ref tm 4))
          (set! dy (vector-ref tm 3))
          (set! hr (vector-ref tm 2))
          (set! mn (vector-ref tm 1))
          (set! sc (vector-ref tm 0))
          (let ((args (cdr args)))
            (if (= 3 arglen)
                (let ((arg (car args)))
                  (if (eq? #:offset? arg) (set! offset? (cadr args))
                      (if (keyword? arg) (error loc "unknown keyword argument" arg)
                          (##sys#error-hook 1 loc arglen 3) ) ) )
                (unless (= 1 arglen) (##sys#error-hook 1 loc arglen 3)) ) ) )
        (begin
          (unless (<= 3 arglen) (##sys#error-hook 2 loc arglen 3))
          (set! yr (car args))
          (set! mo (cadr args))
          (set! dy (caddr args))
          (let loop ((args (cdddr args)))
            (if (null? args)
                (begin (unless hr (set! hr 12)) (unless mn (set! mn 0)) (unless sc (set! sc 0)))
                (let ((arg (car args)))
                  (cond ((keyword? arg)
                         (if (eq? #:offset? arg) (set! offset? (cadr args))
                             (error loc "unknown keyword argument" arg) )
                         (loop (cddr args)) )
                        ((and hr mn sc)
                         (##sys#error-hook 1 loc arglen 8) )
                        (else
                         (if hr (if mn (set! sc arg) (set! mn arg)) (set! hr arg))
                         (loop (cdr args)) ) ) ) ) ) ) )

    (unless (and (fixnum? yr) (fixnum? mo) (fixnum? dy) (fixnum? hr) (fixnum? mn) (fixnum? sc))
      (apply error loc "bad argument type - expected fixnum" args) )
    (unless (and (<= 0 sc 60) (<= 0 mn 59) (<= 0 hr 23) (<= 1 dy 31) (<= 0 mn 11))
      (apply error loc "bad argument type - out of range" args) )

    (get-tz yr mo dy hr mn sc offset?) ) )

;;;

;; Return the timezone for the given date as a string,
;; (e.g. "EST"). If offset?: #t, then return it in RFC-822
;; format (e.g. "-0500").

(define (local-timezone . args) (apply *local-timezone 'local-timezone args))

;; Return the timezone offset as seconds where positive is east of UTC &
;; negative is west of UTC.

(define (local-timezone-offset . args)
  (let* ((tzo (apply 'local-timezone-offset *local-timezone args))
         (1stch (string-ref tzo 0))
         (neg? (char=? #\- 1stch))
         (start (if (or neg? (char=? #\+ 1stch)) 1 0))
         (end (+ start 2))
         (secs (+ (* (string->number (substring tzo start end)) 3600)
                  (* (string->number (substring tzo end (+ end 2))) 60))) )
    (if neg? (- secs) secs) ) )

;;

(define (with-tzset tz thunk)
  (let ((orgtz (getenv "TZ")))
     (dynamic-wind
       (lambda () (setenv "TZ" tz) ((foreign-lambda void "tzset")))
       thunk
       (lambda () (setenv "TZ" orgtz) ((foreign-lambda void "tzset"))) ) ) )

) ;module locale-timezone