Changeset 13886 in project


Ignore:
Timestamp:
03/24/09 07:35:11 (11 years ago)
Author:
Kon Lovett
Message:

Updated tests. Specific locales override - posix wasn't. Rnmd exported error stuff so unique.

Location:
release/3/locale/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/3/locale/trunk/locale-categories.scm

    r13881 r13886  
    2222;;
    2323
    24 (define (check-symbol loc obj) (unless (symbol? obj) (type-error loc "symbol" obj)))
     24(define (check-symbol loc obj)
     25  (unless (symbol? obj)
     26    (locale-type-error loc "symbol" obj) ) )
    2527
    2628;;;
     
    3638(define (check-locale-dictionary loc obj)
    3739  (unless (locale-dictionary? obj)
    38     (type-error loc "locale-dictionary" obj) ) )
     40    (locale-type-error loc "locale-dictionary" obj) ) )
    3941;;
    4042
     
    4345  (check-symbol 'set-locale-dictionary-category! key)
    4446  (let ((tbl (locale-dictionary-table rec)))
    45     (cond ((not val)
    46            (dict-delete! tbl key))
     47    (cond ((not val) (dict-delete! tbl key))
    4748          (else
    4849           (check-locale-components 'set-locale-dictionary-category! val)
     
    6263(define-parameter current-locale-dictionary (make-locale-dictionary)
    6364  (lambda (obj)
    64     (cond ((locale-dictionary? obj)
    65            obj)
     65    (cond ((locale-dictionary? obj) obj)
    6666          (else
    67            (warning 'current-locale-dictionary (make-type-error-message "locale-dictionary") obj)
     67           (warning 'current-locale-dictionary (make-locale-type-error-message "locale-dictionary") obj)
    6868           (current-locale-dictionary) ) ) ) )
    6969
  • release/3/locale/trunk/locale-components.scm

    r13881 r13886  
    1414  (inline)
    1515  (no-procedure-checks)
     16  (disable-interrupts)
    1617  (export
    1718    ;
     
    3435    make-timezone-dst-rule-julian-noleap
    3536    make-timezone-dst-rule-mwd
     37    timezone-dst-rule-julian?
    3638    timezone-dst-rule-julian-leap?
    3739    timezone-dst-rule-julian-noleap?
    3840    timezone-dst-rule-mwd?
     41    timezone-dst-rule-julian
    3942    timezone-dst-rule-day
    40     timezone-dst-rule-julian
    4143    timezone-dst-rule-month
    42     timezone-dst-rule-offset
    43     timezone-dst-rule-week) )
     44    timezone-dst-rule-week
     45    timezone-dst-rule-offset) )
    4446
    4547(require-extension srfi-1 locale-errors)
     
    5153(define-inline (%->boolean obj) (and obj #t))
    5254
    53 ;;; Association List Operations
     55;;; Locale Components Operations
    5456
    55 ;;
    56 
    57 (define (%locale-component-exists? al what)
     57(define-inline (*locale-component-exists? al what)
    5858  (%->boolean (assq what al)) )
    5959
    60 (define (%locale-component-ref al what . def)
    61         (let ((p (assq what al)))
    62                 (if p (cdr p)
    63         (optional def #f) ) ) )
     60(define-inline (*locale-component-ref al what def)
     61        (let ((cell (assq what al)))
     62                (if cell (cdr cell)
     63        def ) ) )
    6464
    65 ;; Components argument cannot be null to effect in-place modification.
     65; Components argument cannot be null to effect in-place modification.
    6666
    67 (define (%set-locale-component! al what value)
    68         (let ((p (assq what al)))
    69                 (cond (p
    70                         (set-cdr! p value))
    71           ((null? al)
    72             (set! al (alist-cons what value al)))
    73           (else
    74             (set-cdr! (last-pair al) (list (cons what value)))))
    75                 al ) )
     67(define (*set-locale-component! al what value)
     68  (if (null? al) (alist-cons what value al)
     69    (let ((cell (assq what al)))
     70      (cond (cell (set-cdr! cell value))
     71            (else (set-cdr! (last-pair al) (list (cons what value)))))
     72      al ) ) )
    7673
    77 ;;
     74(define (*update-locale-components! lc kvs)
     75        (let loop ((kvs kvs))
     76                (cond ((null? kvs) lc)
     77                      (else
     78           (set! lc (*set-locale-component! lc (car kvs) (cadr kvs)))
     79           (loop (cddr kvs)) ) ) ) )
    7880
    79 (define (%update-locale-components! lc . args)
    80         (let loop ((key-val-lst args))
    81                 (if (null? key-val-lst) lc
    82                     (begin
    83           (set-locale-component! lc (car key-val-lst) (cadr key-val-lst))
    84           (loop (cddr key-val-lst)) ) ) ) )
     81;;; Locale Components
     82
     83(define (make-empty-locale-components) '())
     84
     85(define (make-locale-components nam . args)
     86  (let-optionals args ((src #f) (tag 'locale))
     87    (let ((lc (*set-locale-component! (make-empty-locale-components) 'tag tag)))
     88      (*set-locale-component! lc 'name nam)
     89      (*set-locale-component! lc 'source src)
     90      lc ) ) )
     91
     92(define (locale-components? obj)
     93        (and (pair? obj)
     94             (*locale-component-exists? obj 'tag)
     95             (*locale-component-exists? obj 'name)
     96             (*locale-component-exists? obj 'source)) )
     97
     98(define (check-locale-components loc obj)
     99  (unless (locale-components? obj)
     100    (locale-type-error loc "a locale-components object" obj) ) )
     101
     102(define (locale-component-exists? lc what)
     103  (check-locale-components 'locale-component-exists? lc)
     104  (*locale-component-exists? lc what) )
     105
     106(define (locale-component-ref lc what . def)
     107  (check-locale-components 'locale-component-ref lc)
     108        (*locale-component-ref lc what (optional def #f)) )
     109
     110(define (set-locale-component! lc what value)
     111  (check-locale-components 'set-locale-component! lc)
     112        (*set-locale-component! lc what value) )
     113
     114(define (update-locale-components! lc . args)
     115  (check-locale-components 'update-locale-components! lc)
     116        (*update-locale-components! lc args) )
    85117
    86118;;; Timezone Daylight Saving Time Rule
    87119
    88 ;;
     120(define-record-type timezone-dst-rule-julian-noleap
     121  (make-timezone-dst-rule-julian-noleap j o)
     122  timezone-dst-rule-julian-noleap?
     123  (j timezone-dst-rule-julian-noleap-day)
     124  (o timezone-dst-rule-julian-noleap-offset) )
    89125
    90 (define (timezone-dst-rule-julian-noleap? r)
    91         (let ((d (car r)))
    92                 (and (= 2 (length d)) (= 1 (car d))) ) )
     126(define-record-type timezone-dst-rule-julian-leap
     127  (make-timezone-dst-rule-julian-leap j o)
     128  timezone-dst-rule-julian-leap?
     129  (j timezone-dst-rule-julian-leap-day)
     130  (o timezone-dst-rule-julian-leap-offset) )
    93131
    94 ;;
     132(define-record-type timezone-dst-rule-mwd
     133  (make-timezone-dst-rule-mwd m w d o)
     134  timezone-dst-rule-mwd?
     135  (m timezone-dst-rule-mwd-month)
     136  (w timezone-dst-rule-mwd-week)
     137  (d timezone-dst-rule-mwd-day)
     138  (o timezone-dst-rule-mwd-offset) )
    95139
    96 (define (timezone-dst-rule-julian-leap? r)
    97         (let ((d (car r)))
    98                 (and (= 2 (length d)) (= 0 (car d))) ) )
     140(define (check-timezone-dst-rule-mwd loc r)
     141  (unless (timezone-dst-rule-mwd? r)
     142    (locale-type-error loc "timezone-dst-rule-mwd" r) ) )
    99143
    100 ;;
    101 
    102 (define (timezone-dst-rule-mwd? r)
    103         (let ((d (car r)))
    104                 (= 3 (length d)) ) )
    105 
    106 ;;
     144(define (timezone-dst-rule-julian? r)
     145  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
    107146
    108147(define (timezone-dst-rule-julian r)
    109         (cadar r) )
    110 
    111 ;;
     148  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-day r))
     149        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-day r))
     150        (else
     151         (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule-julian" r) ) ) )
    112152
    113153(define (timezone-dst-rule-month r)
    114         (caar r) )
    115 
    116 ;;
     154  (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)
     155  (timezone-dst-rule-mwd-month r) )
    117156
    118157(define (timezone-dst-rule-week r)
    119         (cadar r) )
    120 
    121 ;;
     158  (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)
     159  (timezone-dst-rule-mwd-week r) )
    122160
    123161(define (timezone-dst-rule-day r)
    124         (caddar r) )
    125 
    126 ;;
     162  (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)
     163  (timezone-dst-rule-mwd-day r) )
    127164
    128165(define (timezone-dst-rule-offset r)
    129         (cdr r) )
    130 
    131 ;;
    132 
    133 (define (make-timezone-dst-rule-julian-noleap j o)
    134         (cons (list 1 j) o) )
    135 
    136 ;;
    137 
    138 (define (make-timezone-dst-rule-julian-leap j o)
    139         (cons (list 0 j) o) )
    140 
    141 ;;
    142 
    143 (define (make-timezone-dst-rule-mwd m w d o)
    144         (cons (list m w d) o) )
    145 
    146 ;;; Locale Components
    147 
    148 ;;
    149 
    150 (define (empty-locale-components)
    151         '() )
    152 
    153 ;;
    154 
    155 (define (make-locale-components nam . args)
    156   (let-optionals args ((src #f) (tag 'locale))
    157     (let ((lc (empty-locale-components)))
    158       (%set-locale-component! lc 'tag tag)
    159       (%set-locale-component! lc 'name nam)
    160       (%set-locale-component! lc 'source src)
    161       lc ) ) )
    162 
    163 ;;
    164 
    165 (define (locale-components? obj)
    166         (and (pair? obj)
    167              (%locale-component-exists? obj 'tag)
    168              (%locale-component-exists? obj 'name)
    169              (%locale-component-exists? obj 'source)) )
    170 
    171 (define (check-locale-components loc obj)
    172   (unless (locale-components? obj)
    173     (type-error loc "a locale-components object" obj) ) )
    174 
    175 ;;
    176 
    177 (define (locale-component-exists? lc what)
    178   (check-locale-components 'locale-component-exists? lc)
    179   (%locale-component-exists? lc what) )
    180 
    181 ;;
    182 
    183 (define (locale-component-ref lc what . def)
    184   (check-locale-components 'locale-component-ref lc)
    185         (apply %locale-component-ref lc what def) )
    186 
    187 ;;
    188 
    189 (define (set-locale-component! lc what value)
    190   (check-locale-components 'set-locale-component! lc)
    191         (%set-locale-component! lc what value) )
    192 
    193 ;;
    194 
    195 (define (update-locale-components! lc . args)
    196   (check-locale-components 'update-locale-components! lc)
    197         (apply %update-locale-components! lc args) )
     166  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-offset r))
     167        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-offset r))
     168        ((timezone-dst-rule-mwd? r) (timezone-dst-rule-mwd-offset r))
     169        (else
     170         (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule" r) ) ) )
    198171
    199172;;; Timezone Components
    200173
    201 ;;
    202 
    203 (define (make-timezone-components n s)
    204         (make-locale-components n s 'timezone) )
    205 
    206 ;;
     174(define (make-timezone-components nam . src)
     175  (make-locale-components nam (optional src #f) 'timezone) )
    207176
    208177(define (timezone-components? obj)
    209178        (and (locale-components? obj)
    210              (eq? 'timezone (%locale-component-ref obj 'tag))) )
     179             (eq? 'timezone (*locale-component-ref obj 'tag #f))) )
    211180
    212181(define (check-timezone-components loc obj)
    213182  (unless (timezone-components? obj)
    214     (type-error loc "a timezone-components object" obj) ) )
    215 
    216 ;;
     183    (locale-type-error loc "a timezone-components object" obj) ) )
    217184
    218185(define (timezone-component-ref tz what . def)
    219186  (check-timezone-components 'timezone-component-ref tz)
    220         (apply %locale-component-ref tz what def) )
    221 
    222 ;;
     187        (*locale-component-ref tz what (optional def #f)) )
    223188
    224189(define (set-timezone-component! tz what value)
    225190  (check-timezone-components 'set-timezone-component! tz)
    226         (%set-locale-component! tz what value) )
    227 
    228 ;;
     191        (*set-locale-component! tz what value) )
    229192
    230193(define (update-timezone-components! tz . args)
    231194  (check-timezone-components 'update-timezone-components! tz)
    232         (apply %update-locale-components! tz args) )
     195        (*update-locale-components! tz args) )
  • release/3/locale/trunk/locale-errors.scm

    r13878 r13886  
    99  (no-bound-checks)
    1010  (export
    11     make-type-error-message
    12     type-error) )
     11    make-locale-type-error-message
     12    locale-type-error) )
    1313
    1414(require-extension srfi-12)
    1515
    1616;;;
     17
     18(define (make-locale-type-error-message typmsg)
     19  (string-append "bad argument type - expected " typmsg) )
    1720
    1821;;
     
    2124  (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
    2225
    23 (define (make-type-error-message typmsg)
    24   (string-append "bad argument type - expected " typmsg) )
    25 
    2626(define (make-type-condition) (make-property-condition 'type))
    2727
    2828(define (make-type-error-condition loc typmsg bad)
    2929  (make-composite-condition
    30    (make-exn-condition loc (make-type-error-message typmsg) bad)
     30   (make-exn-condition loc (make-locale-type-error-message typmsg) bad)
    3131   (make-type-condition)) )
    3232
    3333;;
    3434
    35 (define (type-error loc typmsg bad)
     35(define (locale-type-error loc typmsg bad)
    3636  (abort (make-type-error-condition loc typmsg bad)) )
  • release/3/locale/trunk/locale-posix.scm

    r13884 r13886  
    6565(define parse-posix-standard-timezone-value
    6666        (let ((name-re (regexp "([A-Za-z]+)|<([^>]+)>"))
    67                                 (offset-re (regexp "(+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
     67                                (offset-re (regexp "(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
    6868                                (date-re (regexp ",(M|J)?([0-9]+)(\\.[0-9]+)?(\\.[0-9]+)?"))
    6969                                (time-re (regexp "/([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
     
    7575            (next-match
    7676              (lambda (re)
    77                 (and-let* ((ml (string-match re str strpos)))
     77                (and-let* ((ml (string-search re str strpos)))
    7878                  (set! strpos (+ strpos (string-length (car ml))))
    7979                  ml ) ))
    8080            (all-parsed
    81               (lambda () (>= strpos strend)))
     81              (lambda () (<= strend strpos)))
    8282            (fake-dst-rule
    8383              (lambda ()
     
    138138                       ; else dummy something up
    139139                       (fake-dst-rule)))
    140                ; Matched at least the minimum
     140               ; Matched everyting
    141141               (all-parsed)
    142142               ; Then valid timezone info
     
    176176        (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(\\.[^@]+)?(@.+)?")))
    177177                (lambda (lc str)
    178                         (and-let* ((r (string-match locale-re str))
    179                  (matched-len 0))
    180         (let ((l (cadr r))
    181               (s (caddr r))
    182               (t (cadddr r))
    183               (c (car (cddddr r)))
    184               (m (cadr (cddddr r)))
    185               (inc-matched-len
    186                 (lambda (v)
    187                   (set! matched-len (+ matched-len (string-length v))))))
    188           (when l
    189             (inc-matched-len l)
    190             (set-locale-component! lc 'language (string-downcase l)))
    191           (when s
    192             (inc-matched-len s)
    193             (set-locale-component! lc 'script (string-titlecase (substring s 1))))
    194           (when t
    195             (inc-matched-len t)
    196             (set-locale-component! lc 'region (string-upcase (substring t 1))))
    197           (when c
    198             (inc-matched-len c)
    199             (set-locale-component! lc 'codeset (substring c 1)))
    200           (when m
    201             (inc-matched-len m)
    202             (set-locale-component! lc 'modifier (substring m 1)))
    203           (and (= matched-len (string-length str))
    204                lc ) ) ) ) ) )
     178                  (let ((matched-len 0))
     179        (and-let* ((r (string-match locale-re str)))
     180          (let ((l (cadr r))
     181                (s (caddr r))
     182                (t (cadddr r))
     183                (c (car (cddddr r)))
     184                (m (cadr (cddddr r)))
     185                (inc-matched-len
     186                  (lambda (v)
     187                    (set! matched-len (+ matched-len (string-length v))))))
     188            (when l
     189              (inc-matched-len l)
     190              (set-locale-component! lc 'language (string-downcase l)))
     191            (when s
     192              (inc-matched-len s)
     193              (set-locale-component! lc 'script (string-titlecase (substring s 1))))
     194            (when t
     195              (inc-matched-len t)
     196              (set-locale-component! lc 'region (string-upcase (substring t 1))))
     197            (when c
     198              (inc-matched-len c)
     199              (set-locale-component! lc 'codeset (substring c 1)))
     200            (when m
     201              (inc-matched-len m)
     202              (set-locale-component! lc 'modifier (substring m 1)))
     203            (and (= matched-len (string-length str))
     204                 lc ) ) ) ) ) ) )
    205205
    206206(define (parse-posix-pathname-locale lc str)
     
    212212    (let ((lc (make-locale-components str src tag)))
    213213      (cond ((or (string=? str "C") (string=? str "POSIX"))
    214               #f )
     214              lc )
    215215            ((string-prefix? "/" str)
    216216              (parse-posix-pathname-locale lc str) )
     
    235235
    236236(define (set-posix-locale-categories func)
    237   ; Will not override existing category value
    238237  (for-each
    239    (lambda (p)
    240      (let ((cat (cdr p)))
    241        (unless (locale-category-ref cat)
    242          (cond ((func (car p) cat) => (cute set-locale-category! cat <>))) ) ) )
     238   (lambda (cell)
     239     (let ((cat (cdr cell)))
     240       (cond ((func (car cell) cat) => (cute set-locale-category! cat <>))) ) )
    243241   *posix-locale-category-names*) )
    244242
     
    247245(define (gnu-language-string->locale-components str . args)
    248246  (let-optionals args ((src "GNU") (tag 'language))
    249     (let ((lst
     247    (let ((lc (make-locale-components str src tag))
     248          (lst
    250249            (map
    251250             (lambda (lclstr)
    252                (let ((lc (posix-locale-string->locale-components lclstr src)))
    253                  (unless (locale-component-ref lc 'region)
    254                    (set-locale-component! lc
    255                     'region (string-upcase (locale-component-ref lc 'language))) )
    256                  lc ) )
     251               (let ((rlc (posix-locale-string->locale-components lclstr src)))
     252                 (set-locale-component! rlc
     253                  'region (string-upcase (locale-component-ref lc 'language)))
     254                 rlc ) )
    257255             (string-split str ":"))))
    258         (let ((lc (make-locale-components str src tag)))
    259           (update-locale-components! lc 'locales lst)
    260           lc ) ) ) )
     256      (update-locale-components! lc 'locales lst)
     257      lc ) ) )
    261258
    262259;;;
     
    265262
    266263(define (posix-load-timezone)
    267   (unless (locale-category-ref 'timezone)
    268     (and-let* ((str (nonnull-getenv "TZ")))
    269       (let ((lc (posix-timezone-string->timezone-components str "POSIX")))
    270         (set-locale-category! 'timezone lc)) ) ) )
     264  (and-let* ((str (nonnull-getenv "TZ")))
     265    (set-locale-category! 'timezone
     266     (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
    271267
    272268;; Create all local category values from the environment
    273269
    274270(define (posix-load-locale)
    275   ; POSIX standard
    276271        (let ((str (nonnull-getenv "LC_ALL")))
    277272                (if str
    278273        ; Then LC_ALL overrides
    279         (let ((lc (posix-locale-string->locale-components str)))
     274        (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
    280275          (set-posix-locale-categories (lambda (e c) lc)) )
    281276        ; Else set individually, w/ LANG as default
    282277        (let* ((str (nonnull-getenv "LANG"))
    283                (lc (and str (posix-locale-string->locale-components str))))
     278               (lc (and str (posix-locale-string->locale-components str '("POSIX" "LANG")))))
    284279          (set-posix-locale-categories
    285280           (lambda (e c)
    286              (cond ((nonnull-getenv e) => (cute posix-locale-string->locale-components <>))
     281             (cond ((nonnull-getenv e)
     282                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
    287283                   (else lc)))) ) ) ) )
    288284
     
    290286
    291287(define (gnu-load-locale)
    292   (unless (locale-category-ref 'language)
    293     (and-let* ((str (nonnull-getenv "LANGUAGE")))
    294       (let ((lc (gnu-language-string->locale-components str)))
    295         (set-locale-category! 'language lc) ) ) ) )
     288  (and-let* ((str (nonnull-getenv "LANGUAGE")))
     289    (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
     290      (set-locale-category! 'language lc) ) ) )
  • release/3/locale/trunk/locale.scm

    r13881 r13886  
    1919(require-extension locale-builtin locale-posix locale-components locale-categories locale-errors)
    2020
    21 ;;;
     21;;; Parameters (Well, parameter-like)
    2222
    2323;;
     
    3636               (set-locale-category! 'timezone obj) )
    3737              (else
    38                (warning 'current-timezone (make-type-error-message "string, #f or timezone-components") obj)
     38               (warning 'current-timezone (make-locale-type-error-message "string, #f or timezone-components") obj)
    3939               (current-timezone) ) ) ) ) )
    4040
     
    5555               (set-locale-category! 'messages obj) )
    5656              (else
    57                (warning 'current-locale (make-type-error-message "string, #f or locale-components") obj)
     57               (warning 'current-locale (make-locale-type-error-message "string, #f or locale-components") obj)
    5858               (current-locale) ) ) ) ) )
    5959
  • release/3/locale/trunk/tests/locale-test.scm

    r12818 r13886  
    77
    88        (test/case "Timezone" (
    9                 [tz0 (make-timezone-components
    10                                                 'name "PST+8:00"
    11                                                 'source "POSIX"
    12                                                 'std-name "PST" 'std-offset (* 8 60 60))]
    13                 [tz1 (make-timezone-components
    14                                                 'name "PST+8:00PDT+7:00:00"
    15                                                 'source "POSIX"
    16                                                 'std-name "PST" 'std-offset (* 8 60 60)
    17                                                 'dst-name "PDT" 'dst-offset (* 7 60 60)
    18                                                 'dst-start (make-timezone-dst-rule-mwd 4 1 0 3600)
    19                                                 'dst-end (make-timezone-dst-rule-mwd 10 5 0 3600))]
    20                 [tz2 (make-timezone-components
    21                                                 'name "PST+8:00PDT7,J23/12:34,34/1:00:01"
    22                                                 'source "POSIX"
    23                                                 'std-name "PST" 'std-offset (* 8 60 60)
    24                                                 'dst-name "PDT" 'dst-offset (* 7 60 60)
    25                                                 'dst-start (make-timezone-dst-rule-julian-noleap 23 (+ (* 12 60 60) (* 34 60)))
    26                                                 'dst-end (make-timezone-dst-rule-julian-leap 34 (+ (* 1 60 60) 1)))]
    27                 )
    28                
     9                [tz0 (make-timezone-components "PST+8:00" "TEST")]
     10                [tz1 (make-timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ"))]
     11                [tz2 (make-timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST")] )
     12
     13                (expect-set! tz0
     14                  (update-timezone-components! tz0
     15                    'std-name "PST" 'std-offset (* 8 60 60)))
     16                (expect-set! tz1
     17                  (update-timezone-components! tz1
     18        'std-name "PST" 'std-offset (* 8 60 60)
     19        'dst-name "PDT" 'dst-offset (* 7 60 60)
     20        'dst-start (make-timezone-dst-rule-mwd 4 1 0 3600)
     21        'dst-end (make-timezone-dst-rule-mwd 10 5 0 3600)))
     22                (expect-set! tz2
     23                  (update-timezone-components! tz2
     24        'std-name "PST" 'std-offset (* 8 60 60)
     25        'dst-name "PDT" 'dst-offset (* 7 60 60)
     26        'dst-start (make-timezone-dst-rule-julian-noleap 23 (+ (* 12 60 60) (* 34 60)))
     27        'dst-end (make-timezone-dst-rule-julian-leap 34 (+ (* 1 60 60) 1))))
     28
    2929                (expect-false "F1" (posix-timezone-string->timezone-components ":foo,bar,baz"))
    3030                (expect-false "F2" (posix-timezone-string->timezone-components "23,foo"))
     
    3232                (expect-false "F4" (posix-timezone-string->timezone-components "foo-23bar/23"))
    3333                (expect-false "F5" (posix-timezone-string->timezone-components "foo-23bar-22/23"))
    34                
     34
    3535                (expect-equal "S1" tz0
    36                         (posix-timezone-string->timezone-components "PST+8:00"))
     36                        (posix-timezone-string->timezone-components "PST+8:00" "TEST"))
    3737                (expect-equal "S2" tz1
    38                         (posix-timezone-string->timezone-components "PST+8:00PDT+7:00:00"))
     38                        (posix-timezone-string->timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ")))
    3939                (expect-equal "S3" tz2
    40                         (posix-timezone-string->timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01"))
    41                        
     40                        (posix-timezone-string->timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST"))
     41
    4242                (side-effect (setenv "TZ" "PST+8:00PDT+7:00:00"))
    4343                (side-effect (posix-load-timezone))
     
    4646
    4747        (test/case "Locale" (
    48                 [lc0 (make-locale-components
    49                                                 'name "en_US"
    50                                                 'source "POSIX"
    51                                                 'language "en"
    52                                                 'region "US")]
    53                 [lc1 (make-locale-components
    54                                                 'name "en-Latn_US.UTF8@foo,bar,baz"
    55                                                 'source "POSIX"
    56                                                 'language "en"
    57                                                 'script "Latn"
    58                                                 'region "US"
    59                                                 'codeset "UTF8"
    60                                                 'modifier "foo,bar,baz")]
    61                 )
    62                
    63                 (expect-false "F1" (posix-envvar-locale->locale-components "/foo,bar,baz"))
    64                 (expect-false "F2" (posix-envvar-locale->locale-components "23,bar,baz"))
    65                 (expect-false "F3" (posix-envvar-locale->locale-components "foo-bar_1"))
    66                
    67                 (expect-equal "S1" lc0 (posix-envvar-locale->locale-components "en_US"))
    68                 (expect-equal "S2" lc1 (posix-envvar-locale->locale-components "en-Latn_US.UTF8@foo,bar,baz"))
    69                        
     48                [lc0 (make-locale-components "en_US" '("POSIX" "LANG"))]
     49                [lc1 (make-locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST")] )
     50
     51                (expect-set! lc0
     52                  (update-locale-components! lc0
     53        'language "en"
     54        'region "US"))
     55                (expect-set! lc1
     56                  (update-locale-components! lc1
     57        'language "en"
     58        'script "Latn"
     59        'region "US"
     60        'codeset "UTF8"
     61        'modifier "foo,bar,baz"))
     62
     63                (expect-false "F1" (posix-locale-string->locale-components "/foo,bar,baz" "TEST"))
     64                (expect-false "F2" (posix-locale-string->locale-components "23,bar,baz" "TEST"))
     65                (expect-false "F3" (posix-locale-string->locale-components "foo-bar_1" "TEST"))
     66
     67                (expect-equal "S1" lc0 (posix-locale-string->locale-components "en_US" '("POSIX" "LANG")))
     68                (expect-equal "S2" lc1 (posix-locale-string->locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST"))
     69
    7070                (side-effect (setenv "LANG" "en_US"))
    7171                (side-effect (posix-load-locale))
    7272                (expect-equal "S3" lc0 (current-locale-components))
    73                 (expect-equal "S4" lc0 (locale-category-ref 'MONETARY))
     73                (expect-equal "S4" lc0 (locale-category-ref 'monetary))
    7474        )
    7575)
Note: See TracChangeset for help on using the changeset viewer.