source: project/release/4/locale/trunk/locale-current.scm @ 35430

;;;; locale-current.scm
;;;; Kon Lovett, May '06

;; Issues
;;
;; - Only Posix for now.
;; - Uses the `messages' locale category as a proxy for the singleton
;; concept of locale.

(module locale-current

(;export
  current-timezone
  current-locale
  current-timezone-components
  current-locale-components
  current-second-dst?
  ;
  locale-setup)

(import scheme chicken)
(use
  (only posix seconds->local-time)
  (only type-errors warning-argument-type)
  locale-builtin
  locale-posix
  locale-components
  locale-categories)

;;; Local Utility

;;

;TLS
(define *setup?* (make-parameter #f))

(define-inline (ensure-setup)
  ;critical region ?
  (unless (*setup?*)
    (*setup?* #t)
    (locale-setup)) )

;;

;only useful for non-scalar (non-boolean) component
(define-inline (locale-category-component-ref catnam cmpnam)
  (and-let* (
    (lc (locale-category-ref catnam)) )
    (locale-component-ref lc cmpnam)) )

(define-inline (language-components? obj)
  (and (not (timezone-components? obj)) (locale-components? obj)) )

;;; Utility

(define (current-second-dst?)
  (vector-ref (seconds->local-time (current-seconds)) 8) )

;;; Parameters (Well, parameter-like)

;Delays initialization
;TLS (via current-locale-dictionary)

;;

(define (current-timezone . args)
  (ensure-setup)
  (if (null? args)
    (locale-category-component-ref 'timezone 'name)
    (let-optionals args ((obj #f) (src "USER"))
      (cond
        ((not obj)
          (set-locale-category! 'timezone #f) )
        ((string? obj)
          (set-locale-category! 'timezone
            (posix-timezone-string->timezone-components obj src)) )
        ((timezone-components? obj)
          (set-locale-category! 'timezone obj) )
        (else
          (warning-argument-type 'current-timezone obj "string, #f or timezone-components")
          (current-timezone) ) ) ) ) )

;; A'la MzScheme
;; Treat locale as messages category

(define (current-locale . args)
  (ensure-setup)
  (if (null? args)
    (locale-category-component-ref 'current 'name)
    (let-optionals args ((obj #f) (src "USER"))
      (cond
        ((not obj)
          (set-locale-category! 'current #f) )
        ((string? obj)
          (set-locale-category!
            'current
            (posix-locale-string->locale-components obj src)) )
        ((language-components? obj)
          (set-locale-category! 'current obj) )
        (else
          (warning-argument-type 'current-locale obj "string, #f or locale-components")
          (current-locale) ) ) ) ) )

;;

(define (current-timezone-components)
  (ensure-setup)
  (locale-category-ref 'timezone) )

(define (current-locale-components)
  (ensure-setup)
  (locale-category-ref 'current) )

;;

(define (locale-setup . args)
  ;Native locale system 1st
  ;FIXME platform locale system here
  ;
  ;Posix locale system 2nd
  (unless (current-timezone) (posix-load-timezone))
  (unless (current-locale) (posix-load-locale))
  ;
  ;GNU locale system extension
  (unless (locale-category-ref 'language)
    ;GNU says only obey when locale specified
    (when (current-locale) (gnu-load-locale)) )
  ;
  ;Builtin (faked) locale system last
  (unless (current-timezone) (use-builtin-timezone))
  (unless (current-locale) (use-builtin-locale))
  ;
  ;Utility check
  (unless (current-timezone-components) (warning "cannot determine a timezone"))
  (unless (current-locale-components) (warning "cannot determine a locale"))
  ;
  ;Chicken platform extensions
  (when (current-timezone-components)
    (set-timezone-component!
      (current-timezone-components) 'dst?
      (current-second-dst?))) )

) ;module locale