source: project/release/4/locale/trunk/locale-timezone.scm @ 35363

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

(module locale-timezone

(;export
  local-timezone-name
  local-timezone-offset
  local-timezone-name+offset
  with-tzset
  ;Deprecated
  local-timezone)

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

;;;

(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 tv)
  ;Note that the tz-off should be in the tv!
  (let* ((tz (time->string (seconds->local-time (local-time->seconds tv)) "%z %Z"))
         (1stch (string-ref tz 0))
         (neg? (char=? #\- 1stch))
         (start (if (or neg? (char=? #\+ 1stch)) 1 0))
         (end (+ start 2))
         (secs (+ (* (string->number (substring tz start end)) 3600)
                  (* (string->number (substring tz end (+ end 2))) 60))) )
    (values (if neg? (- secs) secs) (substring tz (+ start 5))) ) )

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

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

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

    ; DSSSL lambda list parsing behavior as I wish it was
    (check-minimum-argument-count loc argcnt 1)
    (if (vector? (car args))
        ;then time-vector is argument
        ;kwd dst? overrides vector elm
        (let ((tv (car args)))
          (when (< (vector-length tv) 10)
            (error-argument-type loc tv "ten element time 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) ) ) ) ) ) )
        ;else atomic time elements
        (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 (vector sc mn hr dy mo (- yr 1900) 0 0 dst? 0)) ) )

;;;

;; Return the timezone for the given date as a string, (e.g. "EST").

(define (local-timezone-name . args)
  (let-values (((tzo tzn) (apply *local-tz-info 'local-timezone-name args)))
    tzn ) )

(define local-timezone local-timezone-name)

;; Return the timezone offset as seconds where positive is east of UTC &
;; negative is west of UTC. RFC-822 format (e.g. "-0500").

(define (local-timezone-offset . args)
  (let-values (((tzo tzn) (apply *local-tz-info 'local-timezone-offset args)))
    tzo ) )

;; Return the timezone for the given date.

(define (local-timezone-name+offset . args)
  (apply *local-tz-info 'local-timezone-name+offset args) )

;;

(define (with-tzset tz thunk)
  (let ((orgtz (get-environment-variable "TZ")))
    (dynamic-wind
      (lambda () (setenv "TZ" tz) ((foreign-lambda void "tzset")))
      thunk
      (lambda ()
        (if orgtz (setenv "TZ" orgtz) (unsetenv "TZ"))
        ((foreign-lambda void "tzset")) ) ) ) )

) ;module locale-timezone