Changeset 36946 in project


Ignore:
Timestamp:
12/01/18 23:46:41 (11 days ago)
Author:
kon
Message:

do something not unreasonable w/ TZ (at least don't error-out)

Location:
release/4/locale/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/locale/trunk/locale-builtin.scm

    r35403 r36946  
    5252(define-constant DEFAULT-DST-OFFSET 3600)
    5353
    54 (define (current-local-time) (seconds->local-time (current-seconds)))
     54(define (tm-dst? tm) (vector-ref tm 8))
     55(define (tm-off tm) (vector-ref tm 9))
     56
     57(define (current-local-time) (seconds->local-time))
    5558
    5659(define (make-builtin-timezone)
    57   ; Need local timezone info
     60  ;Need local timezone info
    5861  (let* (
    59     (tv (current-local-time))
    60     (tzn (local-timezone-name tv)
     62    (tm (current-local-time))
     63    (tzn (local-timezone-name tm)
    6164          #; ;Not until Posix bug fixed
    6265          (local-timezone-abbreviation))
    63     (tzo (vector-ref tv 9))
    64     (dst? (vector-ref tv 8)) )
    65     ; Since the tzo reflects the dst status need to fake the one not in effect.
     66    (tzo (tm-off tm))
     67    (dst? (tm-dst? tm)) )
     68    ;Since the tzo reflects the dst status need to fake the one not in effect.
    6669    (if dst?
    6770      (make-posix-timezone UNKNOWN-LOCAL-TZ-NAME (+ tzo DEFAULT-DST-OFFSET) tzn tzo)
  • release/4/locale/trunk/locale-current.scm

    r35430 r36946  
    1515  current-timezone-components
    1616  current-locale-components
    17   current-second-dst?
     17  current-dst?
    1818  ;
    19   locale-setup)
     19  locale-setup
     20  ;DEPRECATED
     21  current-second-dst?)
    2022
    2123(import scheme chicken)
     
    5456;;; Utility
    5557
    56 (define (current-second-dst?)
    57   (vector-ref (seconds->local-time (current-seconds)) 8) )
     58(define (current-dst?) (vector-ref (seconds->local-time) 8))
    5859
    5960;;; Parameters (Well, parameter-like)
     
    114115;;
    115116
     117;Chicken platform extension
     118
     119(use (only (srfi 13) string-null?) (only posix local-timezone-abbreviation))
     120
     121(define (nonnull-getenv varnam)
     122  (let (
     123    (str (get-environment-variable varnam)) )
     124    (and
     125      (string? str) (not (string-null? str))
     126      str ) ) )
     127
     128(define (tm-dst? tm) (vector-ref tm 8))
     129(define (tm-off tm) (vector-ref tm 9))
     130
     131(define (synthetic-posix-timezone-components tz-str tz-src)
     132  (let* (
     133    (tz (make-timezone-components tz-str tz-src))
     134    (tm (seconds->local-time))
     135    (keys (if (tm-dst? tm) '(dst-name . dst-offset) '(std-name . std-offset))) )
     136    (set-timezone-component! tz 'dst? (tm-dst? tm))
     137    (set-timezone-component! tz (car keys) (local-timezone-abbreviation))
     138    (set-timezone-component! tz (cdr keys) (tm-off tm))
     139    tz ) )
     140
     141(define (synthetic-posix-timezone)
     142  (and-let* (
     143    (tz-str (nonnull-getenv "TZ")) )
     144    (let (
     145      (tz (synthetic-posix-timezone-components tz-str (list "POSIX" "TZ"))) )
     146      (set-locale-category! 'timezone tz) ) ) )
     147
     148;;
     149
    116150(define (locale-setup . args)
    117151  ;Native locale system 1st
     
    121155  (unless (current-timezone) (posix-load-timezone))
    122156  (unless (current-locale) (posix-load-locale))
     157  ;
     158  ;TZ Posix locale
     159  (unless (current-timezone) (synthetic-posix-timezone))
    123160  ;
    124161  ;GNU locale system extension
     
    136173  ;
    137174  ;Chicken platform extensions
    138   (when (current-timezone-components)
    139     (set-timezone-component!
    140       (current-timezone-components) 'dst?
    141       (current-second-dst?))) )
     175  (and-let* (
     176    (tz (locale-category-ref 'timezone)) )
     177    (unless (locale-component-exists? tz 'dst?)
     178      (set-timezone-component! tz 'dst? (current-dst?)) ) ) )
     179
     180;;;DEPRECATED
     181
     182(define current-second-dst? current-dst?)
     183(: current-second-dst? (deprecated current-dst?))
    142184
    143185) ;module locale
  • release/4/locale/trunk/locale-posix.scm

    r35430 r36946  
    3030(use
    3131  srfi-1 srfi-13 regex data-structures files
     32  (only posix seconds->local-time local-timezone-abbreviation)
    3233  locale-categories locale-components)
    3334
    3435;;;
     36
     37;;miscmacros
     38
     39;; evaluates body with an explicit exit continuation
     40;;
     41  (define-syntax let/cc
     42    (syntax-rules ()
     43      ((let/cc k e0 e1 ...)
     44       (call-with-current-continuation
     45        (lambda (k) e0 e1 ...)))))
    3546
    3647;;fx-utils
     
    145156                (if (not (and numstr (string-prefix? delm numstr)))
    146157                  numstr
    147                   (string-trim numstr (string-ref delm 0)) ) ) ) )
     158                  (string-trim numstr (string-ref delm 0) ) ) ) ) )
    148159          ;
    149160          (parse-timecomp
    150161            (lambda (numstr)
    151               (parse-delmcomp numstr ":")) )
     162              (parse-delmcomp numstr ":") ) )
    152163          ;
    153164          (parse-daterulecomp
    154165            (lambda (numstr)
    155               (parse-delmcomp numstr ".")) )
     166              (parse-delmcomp numstr ".") ) )
    156167          ;
    157168          (hms->offset
    158169            (lambda (sgnstr hms-lst)
    159170              (and-let* (
    160                 (hr (parse-number (car hms-lst)))
    161                 (mn (parse-timecomp (cadr hms-lst)))
    162                 (sc (parse-timecomp (caddr hms-lst))) )
     171                (hr (parse-number (first hms-lst)))
     172                (mn (parse-timecomp (second hms-lst)))
     173                (sc (parse-timecomp (third hms-lst))) )
    163174                (let (
    164175                  (secs (fx+ (fx* hr SEC/HR) (fx+ (fx* mn SEC/MIN) sc))) )
    165176                  (if (and sgnstr (string=? sgnstr "-"))
    166177                    (fxneg secs)
    167                     secs)) ) ) )
     178                    secs ) ) ) ) )
    168179          ;
    169180          (decode-dst-rule
     
    171182              ;Must begin w/ a valid integer. Interpreted later.
    172183              (and-let* (
    173                 (n1 (parse-number (car dat-lst))) )
     184                (n1 (parse-number (first dat-lst))) )
    174185                (cond
    175186                  ((not rulstr) ;Julian Leap rule
     
    182193                      ((#\M)  ;Date
    183194                        (and-let* (
    184                           (n (parse-daterulecomp (cadr dat-lst)))
    185                           (d (parse-daterulecomp (caddr dat-lst))) )
     195                          (n (parse-daterulecomp (second dat-lst)))
     196                          (d (parse-daterulecomp (third dat-lst))) )
    186197                          (make-timezone-dst-rule-mwd n1 n d off) ) )
    187198                      (else
     
    273284
    274285(define (parse-posix-pathname-timezone tz str)
    275   (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))))
     286  (let (
     287    (pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))) )
    276288    (if (file-exists? pn)
    277289      (parse-posix-tzfile tz pn)
     
    291303;;
    292304
    293 (define (posix-timezone-string->timezone-components str . src)
    294   (let (
    295     (tz (make-timezone-components str (optional src "POSIX"))) )
    296     (cond
    297       ((and (string? str) (string-prefix? ":" str))
    298         (parse-posix-implementation-defined-timezone tz str) )
    299       ((or (not (string? str)) (string-null? str))
    300         #f )
    301       (else
    302         (parse-posix-literal-timezone tz str) ) ) ) )
     305(define (posix-timezone-string->timezone-components tz-str . args)
     306  (let-optionals args (
     307    (tz-src "POSIX") )
     308    (let (
     309      (tz (make-timezone-components tz-str tz-src)) )
     310      (cond
     311        ((and (string? tz-str) (string-prefix? ":" tz-str))
     312          (parse-posix-implementation-defined-timezone tz tz-str) )
     313        ((or (not (string? tz-str)) (string-null? tz-str))
     314          #f )
     315        (else
     316          (parse-posix-literal-timezone tz tz-str) ) ) ) ) )
     317
     318;yes, ugly
     319(define *posix-timezone-string-parse-failure-info* #f)
     320(define (*maybe-posix-timezone-string->timezone-components str . args)
     321  (let-optionals args (
     322    (tz-src "POSIX") )
     323    (handle-exceptions exn
     324      (begin
     325        (set! *posix-timezone-string-parse-failure-info* exn)
     326        #f)
     327      (posix-timezone-string->timezone-components str tz-src)) ) )
     328
     329;;
     330
     331(define (tm-dst? tm) (vector-ref tm 8))
     332(define (tm-off tm) (vector-ref tm 9))
     333
     334(define (synthetic-posix-timezone-components tz-str tz-src)
     335  (let* (
     336    (tz (make-timezone-components tz-str tz-src))
     337    (tm (seconds->local-time))
     338    (keys (if (tm-dst? tm) '(dst-name . dst-offset) '(std-name . std-offset))) )
     339    (set-timezone-component! tz 'dst? (tm-dst? tm))
     340    (set-timezone-component! tz (car keys) (local-timezone-abbreviation))
     341    (set-timezone-component! tz (cdr keys) (tm-off tm))
     342    tz ) )
     343
     344(define (synthetic-posix-timezone)
     345  (and-let* (
     346    (tz-str (nonnull-getenv "TZ")) )
     347    (let (
     348      (tz (synthetic-posix-timezone-components tz-str (list "POSIX" "TZ"))) )
     349      (set-locale-category! 'timezone tz) ) ) )
    303350
    304351;;; Locale
     
    332379          (r (string-match locale-re str)) )
    333380          (let (
    334             (language (cadr r))
    335             (script (caddr r))
    336             (country (cadddr r))
    337             (subdivision (car (cddddr r)))
    338             (codeset (cadr (cddddr r)))
    339             (modifier (caddr (cddddr r)))
     381            (language (second r))
     382            (script (third r))
     383            (country (fourth r))
     384            (subdivision (fifth r))
     385            (codeset (sixth r))
     386            (modifier (seventh r))
    340387            (inc-matched-len
    341388              (lambda (v)
     
    469516(define (posix-load-timezone)
    470517  (and-let* (
    471     (str (nonnull-getenv "TZ")) )
    472     (set-locale-category!
    473       'timezone
    474       (posix-timezone-string->timezone-components
    475         str
    476         (list "POSIX" "TZ"))) ) )
     518    (tz-str (nonnull-getenv "TZ")) )
     519    (let* (
     520      (tz-src (list "POSIX" "TZ"))
     521      (tz (*maybe-posix-timezone-string->timezone-components tz-str tz-src))
     522      (tz (or tz (synthetic-posix-timezone-components tz-str tz-src))) )
     523    (set-locale-category! 'timezone tz) ) ) )
    477524
    478525;; Create all local category values from the environment
  • release/4/locale/trunk/locale.setup

    r35430 r36946  
    55(verify-extension-name "locale")
    66
    7 (setup-shared-extension-module 'locale-components (extension-version "0.7.2")
     7(setup-shared-extension-module 'locale-components (extension-version "0.7.3")
    88  #:inline? #t
    99  #:types? #t
     
    1313    -no-procedure-checks-for-toplevel-bindings))
    1414
    15 (setup-shared-extension-module 'locale-categories (extension-version "0.7.2")
     15(setup-shared-extension-module 'locale-categories (extension-version "0.7.3")
    1616  #:inline? #t
    1717  #:types? #t
     
    2121    -no-procedure-checks-for-toplevel-bindings))
    2222
    23 (setup-shared-extension-module 'locale-posix (extension-version "0.7.2")
     23(setup-shared-extension-module 'locale-posix (extension-version "0.7.3")
    2424  #:inline? #t
    2525  #:types? #t
     
    2929    -no-procedure-checks-for-toplevel-bindings))
    3030
    31 (setup-shared-extension-module 'locale-timezone (extension-version "0.7.2")
     31(setup-shared-extension-module 'locale-timezone (extension-version "0.7.3")
    3232  #:inline? #t
    3333  #:types? #t
     
    3737    -no-procedure-checks-for-toplevel-bindings))
    3838
    39 (setup-shared-extension-module 'locale-builtin (extension-version "0.7.2")
     39(setup-shared-extension-module 'locale-builtin (extension-version "0.7.3")
    4040  #:inline? #t
    4141  #:types? #t
     
    4545    -no-procedure-checks-for-toplevel-bindings))
    4646
    47 (setup-shared-extension-module 'locale-current (extension-version "0.7.2")
     47(setup-shared-extension-module 'locale-current (extension-version "0.7.3")
    4848  #:inline? #t
    4949  #:types? #t
     
    5353    -no-procedure-checks-for-toplevel-bindings))
    5454
    55 (setup-shared-extension-module 'locale (extension-version "0.7.2"))
     55(setup-shared-extension-module 'locale (extension-version "0.7.3"))
  • release/4/locale/trunk/tests/locale-test.scm

    r35426 r36946  
    11;;;; locale-test.scm
     2
     3;TZ='America/Phoenix' csi -R locale -P '(current-locale-components)'
    24
    35; Remove ALL envvars
Note: See TracChangeset for help on using the changeset viewer.