test-suite/tests/i18n.test

   1 ;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
   4 ;;;; Ludovic Courtès
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite i18n)
  21   :use-module (ice-9 i18n)
  22   :use-module (srfi srfi-1)
  23   :use-module (test-suite lib))
  24
  25 ;; Start from a pristine locale state.
  26 (setlocale LC_ALL "C")
  27
  28 (define exception:locale-error
  29   (cons 'system-error "Failed to install locale"))
  30
  31
  32 \f
  33 (with-test-prefix "locale objects"
  34
  35   (pass-if "make-locale (2 args)"
  36     (not (not (make-locale LC_ALL "C"))))
  37
  38   (pass-if "make-locale (2 args, list)"
  39     (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C"))))
  40
  41   (pass-if "make-locale (3 args)"
  42     (not (not (make-locale (list LC_COLLATE) "C"
  43                            (make-locale (list LC_MESSAGES) "C")))))
  44
  45   (pass-if-exception "make-locale with unknown locale" exception:locale-error
  46     (make-locale LC_ALL "does-not-exist"))
  47
  48   (pass-if "locale?"
  49     (and (locale? (make-locale (list LC_ALL) "C"))
  50          (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C"
  51                                (make-locale (list LC_CTYPE) "C")))))
  52
  53   (pass-if "%global-locale"
  54     (and (locale? %global-locale))
  55          (locale? (make-locale (list LC_MONETARY) "C"
  56                                %global-locale))))
  57
  58
  59 \f
  60 (with-test-prefix "text collation (English)"
  61
  62   (pass-if "string-locale<?"
  63     (and (string-locale<? "hello" "world")
  64          (string-locale<? "hello" "world"
  65                           (make-locale (list LC_COLLATE) "C"))))
  66
  67   (pass-if "char-locale<?"
  68     (and (char-locale<? #\a #\b)
  69          (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))
  70
  71   (pass-if "string-locale-ci=?"
  72     (and (string-locale-ci=? "Hello" "HELLO")
  73          (string-locale-ci=? "Hello" "HELLO"
  74                              (make-locale (list LC_COLLATE) "C"))))
  75
  76   (pass-if "string-locale-ci<?"
  77     (and (string-locale-ci<? "hello" "WORLD")
  78          (string-locale-ci<? "hello" "WORLD"
  79                              (make-locale (list LC_COLLATE) "C")))))
  80
  81 \f
  82 (define %french-locale-name
  83   "fr_FR.ISO-8859-1")
  84
  85 (define %french-utf8-locale-name
  86   "fr_FR.UTF-8")
  87
  88 (define %turkish-utf8-locale-name
  89   "tr_TR.UTF-8")
  90
  91 (define %french-locale
  92   (false-if-exception
  93    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
  94                 %french-locale-name)))
  95
  96 (define %french-utf8-locale
  97   (false-if-exception
  98    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
  99                 %french-utf8-locale-name)))
 100
 101 (define %turkish-utf8-locale
 102   (false-if-exception
 103    (make-locale LC_ALL
 104                 %turkish-utf8-locale-name)))
 105
 106 (define (under-locale-or-unresolved locale thunk)
 107   ;; On non-GNU systems, an exception may be raised only when the locale is
 108   ;; actually used rather than at `make-locale'-time.  Thus, we must guard
 109   ;; against both.
 110   (if locale
 111       (if (string-contains %host-type "-gnu")
 112           (thunk)
 113           (catch 'system-error thunk
 114                  (lambda (key . args)
 115                    (throw 'unresolved))))
 116       (throw 'unresolved)))
 117
 118 (define (under-french-locale-or-unresolved thunk)
 119   (under-locale-or-unresolved %french-locale thunk))
 120
 121 (define (under-french-utf8-locale-or-unresolved thunk)
 122   (under-locale-or-unresolved %french-utf8-locale thunk))
 123
 124 (define (under-turkish-utf8-locale-or-unresolved thunk)
 125   (under-locale-or-unresolved %turkish-utf8-locale thunk))
 126
 127 (with-test-prefix "text collation (French)"
 128
 129   (pass-if "string-locale<?"
 130     (under-french-locale-or-unresolved
 131       (lambda ()
 132         (string-locale<? "été" "hiver" %french-locale))))
 133
 134   (pass-if "char-locale<?"
 135     (under-french-locale-or-unresolved
 136       (lambda ()
 137         (char-locale<? #\é #\h %french-locale))))
 138
 139   (pass-if "string-locale-ci=?"
 140     (under-french-locale-or-unresolved
 141       (lambda ()
 142         (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
 143
 144   (pass-if "string-locale-ci=? (2 args, wide strings)"
 145     (under-french-utf8-locale-or-unresolved
 146       (lambda ()
 147         ;; Note: Character `œ' is not part of Latin-1, so these are wide
 148         ;; strings.
 149         (dynamic-wind
 150           (lambda ()
 151             (setlocale LC_ALL "fr_FR.UTF-8"))
 152           (lambda ()
 153             (string-locale-ci=? "œuf" "ŒUF"))
 154           (lambda ()
 155             (setlocale LC_ALL "C"))))))
 156
 157   (pass-if "string-locale-ci=? (3 args, wide strings)"
 158     (under-french-utf8-locale-or-unresolved
 159       (lambda ()
 160         (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
 161
 162   (pass-if "string-locale-ci<>?"
 163     (under-french-locale-or-unresolved
 164       (lambda ()
 165         (and (string-locale-ci<? "été" "Hiver" %french-locale)
 166              (string-locale-ci>? "HiVeR" "été" %french-locale)))))
 167
 168   (pass-if "string-locale-ci<>? (wide strings)"
 169     (under-french-utf8-locale-or-unresolved
 170       (lambda ()
 171         ;; One of the strings is UCS-4, the other is Latin-1.
 172         (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
 173              (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
 174
 175   (pass-if "string-locale-ci<>? (wide and narrow strings)"
 176     (under-french-utf8-locale-or-unresolved
 177       (lambda ()
 178         ;; One of the strings is UCS-4, the other is Latin-1.
 179         (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
 180              (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
 181
 182   (pass-if "char-locale-ci<>?"
 183      (under-french-locale-or-unresolved
 184        (lambda ()
 185          (and (char-locale-ci<? #\é #\H %french-locale)
 186               (char-locale-ci>? #\h #\É %french-locale)))))
 187
 188   (pass-if "char-locale-ci<>? (wide)"
 189      (under-french-utf8-locale-or-unresolved
 190        (lambda ()
 191          (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
 192               (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
 193
 194 \f
 195 (with-test-prefix "character mapping"
 196
 197   (pass-if "char-locale-downcase"
 198     (and (eq? #\a (char-locale-downcase #\A))
 199          (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
 200
 201   (pass-if "char-locale-upcase"
 202     (and (eq? #\Z (char-locale-upcase #\z))
 203          (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
 204
 205   (pass-if "char-locale-titlecase"
 206     (and (eq? #\T (char-locale-titlecase #\t))
 207          (eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
 208
 209   (pass-if "char-locale-titlecase Dž"
 210     (and (eq? #\762 (char-locale-titlecase #\763))
 211          (eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
 212
 213   (pass-if "char-locale-upcase Turkish"
 214     (under-turkish-utf8-locale-or-unresolved
 215      (lambda ()
 216        ;; This test is disabled for now, because char-locale-upcase is
 217        ;; incomplete.
 218        (throw 'untested)
 219        (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
 220
 221   (pass-if "char-locale-downcase Turkish"
 222     (under-turkish-utf8-locale-or-unresolved
 223      (lambda ()
 224        ;; This test is disabled for now, because char-locale-downcase
 225        ;; is incomplete.
 226        (throw 'untested)
 227        (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
 228
 229 \f
 230 (with-test-prefix "string mapping"
 231
 232   (pass-if "string-locale-downcase"
 233     (and (string=? "a" (string-locale-downcase "A"))
 234          (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
 235
 236   (pass-if "string-locale-upcase"
 237     (and (string=? "Z" (string-locale-upcase "z"))
 238          (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
 239
 240   (pass-if "string-locale-titlecase"
 241     (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
 242          (string=? "Hello, World" (string-locale-titlecase
 243                                    "hello, world" (make-locale LC_ALL "C")))))
 244
 245   (pass-if "string-locale-upcase Turkish"
 246     (under-turkish-utf8-locale-or-unresolved
 247      (lambda ()
 248        ;; This test is disabled for now, because string-locale-upcase
 249        ;; is incomplete.
 250        (throw 'untested)
 251        (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
 252
 253   (pass-if "string-locale-downcase Turkish"
 254     (under-turkish-utf8-locale-or-unresolved
 255      (lambda ()
 256        ;; This test is disabled for now, because
 257        ;; string-locale-downcase is incomplete.
 258        (throw 'untested)
 259        (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
 260
 261 \f
 262 (with-test-prefix "number parsing"
 263
 264   (pass-if "locale-string->integer"
 265     (call-with-values (lambda () (locale-string->integer "123"))
 266       (lambda (result char-count)
 267         (and (equal? result 123)
 268              (equal? char-count 3)))))
 269
 270   (pass-if "locale-string->inexact"
 271     (call-with-values
 272         (lambda ()
 273           (locale-string->inexact "123.456"
 274                                   (make-locale (list LC_NUMERIC) "C")))
 275       (lambda (result char-count)
 276         (and (equal? result 123.456)
 277              (equal? char-count 7)))))
 278
 279   (pass-if "locale-string->inexact (French)"
 280     (under-french-locale-or-unresolved
 281      (lambda ()
 282        (call-with-values
 283            (lambda ()
 284              (locale-string->inexact "123,456" %french-locale))
 285          (lambda (result char-count)
 286            (and (equal? result 123.456)
 287                 (equal? char-count 7))))))))
 288
 289 \f
 290 ;;;
 291 ;;; `nl-langinfo'
 292 ;;;
 293
 294 (setlocale LC_ALL "C")
 295 (define %c-locale (make-locale LC_ALL "C"))
 296
 297 (define %english-days
 298   '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
 299
 300 (define (every? . args)
 301   (not (not (apply every args))))
 302
 303
 304 (with-test-prefix "nl-langinfo et al."
 305
 306   (pass-if "locale-day (1 arg)"
 307     (every? equal?
 308             %english-days
 309             (map locale-day (map 1+ (iota 7)))))
 310
 311   (pass-if "locale-day (2 args)"
 312     (every? equal?
 313             %english-days
 314             (map (lambda (day)
 315                    (locale-day day %c-locale))
 316                  (map 1+ (iota 7)))))
 317
 318   (pass-if "locale-day (2 args, using `%global-locale')"
 319     (every? equal?
 320             %english-days
 321             (map (lambda (day)
 322                    (locale-day day %global-locale))
 323                  (map 1+ (iota 7)))))
 324
 325   (pass-if "locale-day (French)"
 326     (under-french-locale-or-unresolved
 327      (lambda ()
 328        (let ((result (locale-day 3 %french-locale)))
 329          (and (string? result)
 330               (string-ci=? result "mardi"))))))
 331
 332   (pass-if "locale-day (French, using `%global-locale')"
 333     ;; Make sure `%global-locale' captures the current locale settings as
 334     ;; installed using `setlocale'.
 335     (under-french-locale-or-unresolved
 336      (lambda ()
 337        (dynamic-wind
 338            (lambda ()
 339              (setlocale LC_TIME %french-locale-name))
 340            (lambda ()
 341              (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
 342                     (result (locale-day 3 fr)))
 343                (setlocale LC_ALL "C")
 344                (and (string? result)
 345                     (string-ci=? result "mardi"))))
 346            (lambda ()
 347              (setlocale LC_ALL "C"))))))
 348
 349   (pass-if "default locale"
 350     ;; Make sure the default locale does not capture the current locale
 351     ;; settings as installed using `setlocale'.  The default locale should be
 352     ;; "C".
 353     (under-french-locale-or-unresolved
 354      (lambda ()
 355        (dynamic-wind
 356            (lambda ()
 357              (setlocale LC_ALL %french-locale-name))
 358            (lambda ()
 359              (let* ((locale (make-locale (list LC_MONETARY) "C"))
 360                     (result (locale-day 3 locale)))
 361                (setlocale LC_ALL "C")
 362                (and (string? result)
 363                     (string-ci=? result "Tuesday"))))
 364            (lambda ()
 365              (setlocale LC_ALL "C")))))))
 366
 367 \f
 368 ;;;
 369 ;;; Numbers.
 370 ;;;
 371
 372 (with-test-prefix "number->locale-string"
 373
 374   ;; We assume the global locale is "C" at this point.
 375
 376   (with-test-prefix "C"
 377
 378     (pass-if "no thousand separator"
 379       ;; Unlike in English, the "C" locale has no thousand separator.
 380       ;; If this doesn't hold, the following tests will fail.
 381       (string=? "" (locale-thousands-separator)))
 382
 383     (pass-if "integer"
 384       (string=? "123456" (number->locale-string 123456)))
 385
 386     (pass-if "fraction"
 387       (string=? "1234.567" (number->locale-string 1234.567)))
 388
 389     (pass-if "fraction, 1 digit"
 390       (string=? "1234.5" (number->locale-string 1234.567 1))))
 391
 392   (with-test-prefix "French"
 393
 394     (under-french-locale-or-unresolved
 395      (lambda ()
 396        (let ((fr (make-locale LC_ALL %french-locale-name)))
 397
 398         (pass-if "integer"
 399           (string=? "123 456" (number->locale-string 123456 #t fr)))
 400
 401         (pass-if "fraction"
 402           (string=? "1 234,567" (number->locale-string 1234.567 #t fr)))
 403
 404         (pass-if "fraction, 1 digit"
 405           (string=? "1 234,5"
 406                     (number->locale-string 1234.567 1 fr))))))))