;;;; 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-fixnum)
          (only type-errors error-keyword error-argument-type))

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

  (declare
    (inline)
    (local)
    (fixnum)
    (no-procedure-checks)
    (bound-to-procedure
      ##sys#error-hook) )

;;;

(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-interval
  (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 (error-minimum-argument-count loc argcnt cnt)
  (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )

(define (error-argument-count loc argcnt cnt)
  (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )

(define (check-minimum-argument-count loc actargc minargc)
  (unless (<= minargc actargc)
    (error-minimum-argument-count loc actargc minargc)) )

(define (check-argument-count loc actargc maxargc)
  (unless (<= actargc maxargc)
    (error-argument-count loc actargc maxargc)) )

;;;

(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-interval 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