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

(module locale-timezone

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

  (import
    scheme chicken foreign
    (only posix
      time->string seconds->local-time local-time->seconds setenv)
    (only type-checks
      check-minimum-argument-count check-argument-count
      check-fixnum)
    (only type-errors
      error-argument-count
      error-keyword error-argument-type))

  (require-library posix type-checks type-errors)

;;;

(define-syntax check-fixnums
  (syntax-rules ()
    ((_ ?loc ?nam0 ...)
      (for-each
        (lambda (x) (check-fixnum ?loc (car x) (cadr x)))
        (list (list ?nam0 '?nam0) ...)) ) ) )

(define-syntax check-closed-intervals
  (syntax-rules (<=)
    ((_ ?loc (<= ?low0 ?nam0 ?hgh0) ...)
      (for-each
        (lambda (x)
          (unless (<= (caddr x) (car x) (cadddr x))
            (error ?loc
              (string-append "bad argument " (symbol->string (cadr x)) " type - out of range")
              (car x) (caddr x) (cadddr x)) ) )
        (list (list ?nam0 '?nam0 ?low0 ?hgh0) ...)) ) ) )

;;;

(define (get-tz yr mo dy hr mn sc off? dst?)
  (let ((tv (vector sc mn hr dy mo (- yr 1900) 0 0 dst? 0)))
    (time->string (seconds->local-time (local-time->seconds tv)) (if off? "%z" "%Z")) ) )

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

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

    (define (kwdarg kwd rest)
      (cond ((eq? #:offset? kwd) (set! offset? (cadr rest)) )
           ((eq? #:dst? kwd) (set! dst? (cadr rest)) )
           (else (error-argument-type loc "keyword #:offset? or #:dst?" kwd) ) ) )

    ; DSSSL lambda list parsing behavior as I wish it was
    (check-minimum-argument-count loc argcnt 1)
    (if (vector? (car args))
        (let ((tv (car args)))
          (when (< (vector-length tv) 10) 
            (error-argument-type loc tv "ten element vector") )
          (set! dst? (vector-ref tv 8))
          (set! yr (+ (vector-ref tv 5) 1900))
          (set! mo (vector-ref tv 4))
          (set! dy (vector-ref tv 3))
          (set! hr (vector-ref tv 2))
          (set! mn (vector-ref tv 1))
          (set! sc (vector-ref tv 0))
          (let loop ((args (cdr args)))
            (unless (null? args)
              (let ((arg (car args)))
                (cond
                  ((keyword? arg)
                    (kwdarg arg args)
                    (loop (cddr args)) )
                  (else
                    (error-keyword loc arg) ) ) ) ) ) )
        (begin
          (check-minimum-argument-count loc argcnt 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)
                      (kwdarg arg args)
                      (loop (cddr args)) )
                    ((and hr mn sc)
                      (error-argument-count loc argcnt 8) )
                    (else
                      (if hr (if mn (set! sc arg) (set! mn arg)) (set! hr arg))
                      (loop (cdr args)) ) ) ) ) ) ) )

    (check-fixnums loc yr mo dy hr mn sc)
    (check-closed-intervals loc
      (<= 0 sc 60)
      (<= 0 mn 59)
      (<= 0 hr 23)
      (<= 1 dy 31)
      (<= 0 mo 11))

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

;;;

;; 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 (append args '(#:offset? #f))) )

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

(define (local-timezone-offset . args)
  (cond-expand
    ((or windows linux freebsd netbsd openbsd macosx solaris sunos)
      (let* ((tzo (apply *local-timezone 'local-timezone-offset (append args '(#:offset? #t))))
             (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) ) )
    (else
      (error 'local-timezone-offset "operation unsupported" (software-version)) ) ) )

;;

(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