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, 2011, 2012 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 %german-utf8-locale-name
  92   "de_DE.UTF-8")
  93
  94 (define %greek-utf8-locale-name
  95   "el_GR.UTF-8")
  96
  97 (define %french-locale
  98   (false-if-exception
  99    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
 100                 %french-locale-name)))
 101
 102 (define %french-utf8-locale
 103   (false-if-exception
 104    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
 105                 %french-utf8-locale-name)))
 106
 107 (define %german-utf8-locale
 108   (false-if-exception
 109    (make-locale LC_ALL
 110                 %german-utf8-locale-name)))
 111
 112 (define %greek-utf8-locale
 113   (false-if-exception
 114    (make-locale LC_ALL
 115                 %greek-utf8-locale-name)))
 116
 117 (define %turkish-utf8-locale
 118   (false-if-exception
 119    (make-locale LC_ALL
 120                 %turkish-utf8-locale-name)))
 121
 122 (define (under-locale-or-unresolved locale thunk)
 123   ;; On non-GNU systems, an exception may be raised only when the locale is
 124   ;; actually used rather than at `make-locale'-time.  Thus, we must guard
 125   ;; against both.
 126   (if locale
 127       (if (string-contains %host-type "-gnu")
 128           (thunk)
 129           (catch 'system-error thunk
 130                  (lambda (key . args)
 131                    (throw 'unresolved))))
 132       (throw 'unresolved)))
 133
 134 (define (under-french-locale-or-unresolved thunk)
 135   (under-locale-or-unresolved %french-locale thunk))
 136
 137 (define (under-french-utf8-locale-or-unresolved thunk)
 138   (under-locale-or-unresolved %french-utf8-locale thunk))
 139
 140 (define (under-turkish-utf8-locale-or-unresolved thunk)
 141   ;; FreeBSD 8.2, Solaris 2.10, and Darwin 8.11.0 have a broken tr_TR
 142   ;; locale where `i' is mapped to uppercase `I' instead of `İ', so
 143   ;; disable tests on that platform.
 144   (if (or (string-contains %host-type "freebsd8")
 145           (string-contains %host-type "solaris2.10")
 146           (string-contains %host-type "darwin8"))
 147       (throw 'unresolved)
 148       (under-locale-or-unresolved %turkish-utf8-locale thunk)))
 149
 150 (define (under-german-utf8-locale-or-unresolved thunk)
 151   (under-locale-or-unresolved %german-utf8-locale thunk))
 152
 153 (define (under-greek-utf8-locale-or-unresolved thunk)
 154   (under-locale-or-unresolved %greek-utf8-locale thunk))
 155
 156 (with-test-prefix "text collation (French)"
 157
 158   (pass-if "string-locale<?"
 159     (under-french-locale-or-unresolved
 160       (lambda ()
 161         (string-locale<? "été" "hiver" %french-locale))))
 162
 163   (pass-if "char-locale<?"
 164     (under-french-locale-or-unresolved
 165       (lambda ()
 166         (char-locale<? #\é #\h %french-locale))))
 167
 168   (pass-if "string-locale-ci=?"
 169     (under-french-locale-or-unresolved
 170       (lambda ()
 171         (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
 172
 173   (pass-if "string-locale-ci=? (2 args, wide strings)"
 174     (under-french-utf8-locale-or-unresolved
 175       (lambda ()
 176         ;; Note: Character `œ' is not part of Latin-1, so these are wide
 177         ;; strings.
 178         (dynamic-wind
 179           (lambda ()
 180             (setlocale LC_ALL "fr_FR.UTF-8"))
 181           (lambda ()
 182             (string-locale-ci=? "œuf" "ŒUF"))
 183           (lambda ()
 184             (setlocale LC_ALL "C"))))))
 185
 186   (pass-if "string-locale-ci=? (3 args, wide strings)"
 187     (under-french-utf8-locale-or-unresolved
 188       (lambda ()
 189         (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
 190
 191   (pass-if "string-locale-ci<>?"
 192     (under-french-locale-or-unresolved
 193       (lambda ()
 194         (and (string-locale-ci<? "été" "Hiver" %french-locale)
 195              (string-locale-ci>? "HiVeR" "été" %french-locale)))))
 196
 197   (pass-if "string-locale-ci<>? (wide strings)"
 198     (under-french-utf8-locale-or-unresolved
 199       (lambda ()
 200         ;; One of the strings is UCS-4, the other is Latin-1.
 201         (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
 202              (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
 203
 204   (pass-if "string-locale-ci<>? (wide and narrow strings)"
 205     (under-french-utf8-locale-or-unresolved
 206       (lambda ()
 207         ;; One of the strings is UCS-4, the other is Latin-1.
 208         (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
 209              (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
 210
 211   (pass-if "char-locale-ci<>?"
 212      (under-french-locale-or-unresolved
 213        (lambda ()
 214          (and (char-locale-ci<? #\é #\H %french-locale)
 215               (char-locale-ci>? #\h #\É %french-locale)))))
 216
 217   (pass-if "char-locale-ci<>? (wide)"
 218      (under-french-utf8-locale-or-unresolved
 219        (lambda ()
 220          (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
 221               (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
 222
 223 \f
 224 (with-test-prefix "text collation (German)"
 225
 226   (pass-if "string-locale-ci=?"
 227     (under-german-utf8-locale-or-unresolved
 228      (lambda ()
 229        (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
 230          (string-locale-ci=? "Straße" "STRASSE"))))))
 231
 232 \f
 233 (with-test-prefix "text collation (Greek)"
 234
 235   (pass-if "string-locale-ci=?"
 236     (under-greek-utf8-locale-or-unresolved
 237      (lambda ()
 238        (let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
 239          (string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
 240
 241 \f
 242 (with-test-prefix "character mapping"
 243
 244   (pass-if "char-locale-downcase"
 245     (and (eq? #\a (char-locale-downcase #\A))
 246          (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
 247
 248   (pass-if "char-locale-upcase"
 249     (and (eq? #\Z (char-locale-upcase #\z))
 250          (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
 251
 252   (pass-if "char-locale-titlecase"
 253     (and (eq? #\T (char-locale-titlecase #\t))
 254          (eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
 255
 256   (pass-if "char-locale-titlecase Dž"
 257     (and (eq? #\762 (char-locale-titlecase #\763))
 258          (eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
 259
 260   (pass-if "char-locale-upcase Turkish"
 261     (under-turkish-utf8-locale-or-unresolved
 262      (lambda ()
 263        (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
 264
 265   (pass-if "char-locale-downcase Turkish"
 266     (under-turkish-utf8-locale-or-unresolved
 267      (lambda ()
 268        (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
 269
 270 \f
 271 (with-test-prefix "string mapping"
 272
 273   (pass-if "string-locale-downcase"
 274     (and (string=? "a" (string-locale-downcase "A"))
 275          (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
 276
 277   (pass-if "string-locale-upcase"
 278     (and (string=? "Z" (string-locale-upcase "z"))
 279          (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
 280
 281   (pass-if "string-locale-titlecase"
 282     (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
 283          (string=? "Hello, World" (string-locale-titlecase
 284                                    "hello, world" (make-locale LC_ALL "C")))))
 285
 286   (pass-if "string-locale-upcase German"
 287     (under-german-utf8-locale-or-unresolved
 288      (lambda ()
 289        (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
 290          (string=? "STRASSE"
 291                    (string-locale-upcase "Straße" de))))))
 292
 293   (pass-if "string-locale-upcase Greek"
 294     (under-greek-utf8-locale-or-unresolved
 295      (lambda ()
 296        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 297          (string=? "ΧΑΟΣ"
 298                    (string-locale-upcase "χαος" el))))))
 299
 300   (pass-if "string-locale-upcase Greek (two sigmas)"
 301     (under-greek-utf8-locale-or-unresolved
 302      (lambda ()
 303        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 304          (string=? "ΓΕΙΆ ΣΑΣ"
 305                    (string-locale-upcase "Γειά σας" el))))))
 306
 307   (pass-if "string-locale-downcase Greek"
 308     (under-greek-utf8-locale-or-unresolved
 309      (lambda ()
 310        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 311          (string=? "χαος"
 312                    (string-locale-downcase "ΧΑΟΣ" el))))))
 313
 314   (pass-if "string-locale-downcase Greek (two sigmas)"
 315     (under-greek-utf8-locale-or-unresolved
 316      (lambda ()
 317        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 318          (string=? "γειά σας"
 319                    (string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))
 320
 321   (pass-if "string-locale-upcase Turkish"
 322     (under-turkish-utf8-locale-or-unresolved
 323      (lambda ()
 324        (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
 325
 326   (pass-if "string-locale-downcase Turkish"
 327     (under-turkish-utf8-locale-or-unresolved
 328      (lambda ()
 329        (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
 330
 331 \f
 332 (with-test-prefix "number parsing"
 333
 334   (pass-if "locale-string->integer"
 335     (call-with-values (lambda () (locale-string->integer "123"))
 336       (lambda (result char-count)
 337         (and (equal? result 123)
 338              (equal? char-count 3)))))
 339
 340   (pass-if "locale-string->inexact"
 341     (call-with-values
 342         (lambda ()
 343           (locale-string->inexact "123.456"
 344                                   (make-locale (list LC_NUMERIC) "C")))
 345       (lambda (result char-count)
 346         (and (equal? result 123.456)
 347              (equal? char-count 7)))))
 348
 349   (pass-if "locale-string->inexact (French)"
 350     (under-french-locale-or-unresolved
 351      (lambda ()
 352        (call-with-values
 353            (lambda ()
 354              (locale-string->inexact "123,456" %french-locale))
 355          (lambda (result char-count)
 356            (and (equal? result 123.456)
 357                 (equal? char-count 7))))))))
 358
 359 \f
 360 ;;;
 361 ;;; `nl-langinfo'
 362 ;;;
 363
 364 (setlocale LC_ALL "C")
 365 (define %c-locale (make-locale LC_ALL "C"))
 366
 367 (define %english-days
 368   '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
 369
 370 (define (every? . args)
 371   (not (not (apply every args))))
 372
 373
 374 (with-test-prefix "nl-langinfo et al."
 375
 376   (pass-if "locale-day (1 arg)"
 377     (every? equal?
 378             %english-days
 379             (map locale-day (map 1+ (iota 7)))))
 380
 381   (pass-if "locale-day (2 args)"
 382     (every? equal?
 383             %english-days
 384             (map (lambda (day)
 385                    (locale-day day %c-locale))
 386                  (map 1+ (iota 7)))))
 387
 388   (pass-if "locale-day (2 args, using `%global-locale')"
 389     (every? equal?
 390             %english-days
 391             (map (lambda (day)
 392                    (locale-day day %global-locale))
 393                  (map 1+ (iota 7)))))
 394
 395   (pass-if "locale-day (French)"
 396     (under-french-locale-or-unresolved
 397      (lambda ()
 398        (let ((result (locale-day 3 %french-locale)))
 399          (and (string? result)
 400               (string-ci=? result "mardi"))))))
 401
 402   (pass-if "locale-day (French, using `%global-locale')"
 403     ;; Make sure `%global-locale' captures the current locale settings as
 404     ;; installed using `setlocale'.
 405     (under-french-locale-or-unresolved
 406      (lambda ()
 407        (dynamic-wind
 408            (lambda ()
 409              (setlocale LC_TIME %french-locale-name))
 410            (lambda ()
 411              (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
 412                     (result (locale-day 3 fr)))
 413                (setlocale LC_ALL "C")
 414                (and (string? result)
 415                     (string-ci=? result "mardi"))))
 416            (lambda ()
 417              (setlocale LC_ALL "C"))))))
 418
 419   (pass-if "default locale"
 420     ;; Make sure the default locale does not capture the current locale
 421     ;; settings as installed using `setlocale'.  The default locale should be
 422     ;; "C".
 423     (under-french-locale-or-unresolved
 424      (lambda ()
 425        (dynamic-wind
 426            (lambda ()
 427              (setlocale LC_ALL %french-locale-name))
 428            (lambda ()
 429              (let* ((locale (make-locale (list LC_MONETARY) "C"))
 430                     (result (locale-day 3 locale)))
 431                (setlocale LC_ALL "C")
 432                (and (string? result)
 433                     (string-ci=? result "Tuesday"))))
 434            (lambda ()
 435              (setlocale LC_ALL "C")))))))
 436
 437 \f
 438 ;;;
 439 ;;; Numbers.
 440 ;;;
 441
 442 (with-test-prefix "number->locale-string"
 443
 444   ;; We assume the global locale is "C" at this point.
 445
 446   (with-test-prefix "C"
 447
 448     (pass-if "no thousand separator"
 449       ;; Unlike in English, the "C" locale has no thousand separator.
 450       ;; If this doesn't hold, the following tests will fail.
 451       (string=? "" (locale-thousands-separator)))
 452
 453     (pass-if "integer"
 454       (string=? "123456" (number->locale-string 123456)))
 455
 456     (pass-if "fraction"
 457       (string=? "1234.567" (number->locale-string 1234.567)))
 458
 459     (pass-if "fraction, 1 digit"
 460       (string=? "1234.5" (number->locale-string 1234.567 1))))
 461
 462   (with-test-prefix "French"
 463
 464     (pass-if "integer"
 465       (under-french-locale-or-unresolved
 466        (lambda ()
 467          (let ((fr (make-locale LC_ALL %french-locale-name)))
 468            (string=? "123 456" (number->locale-string 123456 #t fr))))))
 469
 470     (pass-if "fraction"
 471       (under-french-locale-or-unresolved
 472        (lambda ()
 473          (let ((fr (make-locale LC_ALL %french-locale-name)))
 474            (string=? "1 234,567" (number->locale-string 1234.567 #t fr))))))
 475
 476     (pass-if "fraction, 1 digit"
 477       (under-french-locale-or-unresolved
 478        (lambda ()
 479          (let ((fr (make-locale LC_ALL %french-locale-name)))
 480            (string=? "1 234,5"
 481                      (number->locale-string 1234.567 1 fr))))))))