mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
700f6cd86b
* test-suite/tests/i18n.test (mingw?): New variable. (%french-locale-name, %french-utf8-locale-name, %turkish-utf8-locale-name, %german-utf8-locale-name, %greek-utf8-locale-name): Add name of corresponding Windows codepage, when MINGW? is true. (under-turkish-utf8-locale-or-unresolved): Add exception for "mingw32". Co-authored-by: Eli Zaretskii <eliz@gnu.org>
558 lines
18 KiB
Scheme
558 lines
18 KiB
Scheme
;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
|
||
;;;; 2013, 2014 Free Software Foundation, Inc.
|
||
;;;; Ludovic Courtès
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-suite i18n)
|
||
#:use-module (ice-9 i18n)
|
||
#:use-module (ice-9 format)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (test-suite lib))
|
||
|
||
;; Start from a pristine locale state.
|
||
(setlocale LC_ALL "C")
|
||
|
||
(define exception:locale-error
|
||
(cons 'system-error "Failed to install locale"))
|
||
|
||
|
||
|
||
(with-test-prefix "locale objects"
|
||
|
||
(pass-if "make-locale (2 args)"
|
||
(not (not (make-locale LC_ALL "C"))))
|
||
|
||
(pass-if "make-locale (2 args, list)"
|
||
(not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C"))))
|
||
|
||
(pass-if "make-locale (3 args)"
|
||
(not (not (make-locale (list LC_COLLATE) "C"
|
||
(make-locale (list LC_NUMERIC) "C")))))
|
||
|
||
(pass-if-exception "make-locale with unknown locale" exception:locale-error
|
||
(make-locale LC_ALL "does-not-exist"))
|
||
|
||
(pass-if "locale?"
|
||
(and (locale? (make-locale (list LC_ALL) "C"))
|
||
(locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
|
||
(make-locale (list LC_CTYPE) "C")))))
|
||
|
||
(pass-if "%global-locale"
|
||
(and (locale? %global-locale))
|
||
(locale? (make-locale (list LC_MONETARY) "C"
|
||
%global-locale))))
|
||
|
||
|
||
|
||
(with-test-prefix "text collation (English)"
|
||
|
||
(pass-if "string-locale<?"
|
||
(and (string-locale<? "hello" "world")
|
||
(string-locale<? "hello" "world"
|
||
(make-locale (list LC_COLLATE) "C"))))
|
||
|
||
(pass-if "char-locale<?"
|
||
(and (char-locale<? #\a #\b)
|
||
(char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))
|
||
|
||
(pass-if "string-locale-ci=?"
|
||
(and (string-locale-ci=? "Hello" "HELLO")
|
||
(string-locale-ci=? "Hello" "HELLO"
|
||
(make-locale (list LC_COLLATE) "C"))))
|
||
|
||
(pass-if "string-locale-ci<?"
|
||
(and (string-locale-ci<? "hello" "WORLD")
|
||
(string-locale-ci<? "hello" "WORLD"
|
||
(make-locale (list LC_COLLATE) "C")))))
|
||
|
||
|
||
(define mingw?
|
||
(string-contains %host-type "-mingw32"))
|
||
|
||
(define %french-locale-name
|
||
(if mingw?
|
||
"fra_FRA.850"
|
||
"fr_FR.ISO-8859-1"))
|
||
|
||
;; What we really want for the following locales is that they be Unicode
|
||
;; capable, not necessarily UTF-8, which Windows does not provide.
|
||
|
||
(define %french-utf8-locale-name
|
||
(if mingw?
|
||
"fra_FRA.1252"
|
||
"fr_FR.UTF-8"))
|
||
|
||
(define %turkish-utf8-locale-name
|
||
(if mingw?
|
||
"tur_TRK.1254"
|
||
"tr_TR.UTF-8"))
|
||
|
||
(define %german-utf8-locale-name
|
||
(if mingw?
|
||
"deu_DEU.1252"
|
||
"de_DE.UTF-8"))
|
||
|
||
(define %greek-utf8-locale-name
|
||
(if mingw?
|
||
"grc_ELL.1253"
|
||
"el_GR.UTF-8"))
|
||
|
||
(define %american-english-locale-name
|
||
"en_US")
|
||
|
||
(define %french-locale
|
||
(false-if-exception
|
||
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
|
||
%french-locale-name)))
|
||
|
||
(define %french-utf8-locale
|
||
(false-if-exception
|
||
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
|
||
%french-utf8-locale-name)))
|
||
|
||
(define %german-utf8-locale
|
||
(false-if-exception
|
||
(make-locale LC_ALL
|
||
%german-utf8-locale-name)))
|
||
|
||
(define %greek-utf8-locale
|
||
(false-if-exception
|
||
(make-locale LC_ALL
|
||
%greek-utf8-locale-name)))
|
||
|
||
(define %turkish-utf8-locale
|
||
(false-if-exception
|
||
(make-locale LC_ALL
|
||
%turkish-utf8-locale-name)))
|
||
|
||
(define %american-english-locale
|
||
(false-if-exception
|
||
(make-locale LC_ALL
|
||
%american-english-locale-name)))
|
||
|
||
(define (under-locale-or-unresolved locale thunk)
|
||
;; On non-GNU systems, an exception may be raised only when the locale is
|
||
;; actually used rather than at `make-locale'-time. Thus, we must guard
|
||
;; against both.
|
||
(if locale
|
||
(if (string-contains %host-type "-gnu")
|
||
(thunk)
|
||
(catch 'system-error thunk
|
||
(lambda (key . args)
|
||
(throw 'unresolved))))
|
||
(throw 'unresolved)))
|
||
|
||
(define (under-french-locale-or-unresolved thunk)
|
||
(under-locale-or-unresolved %french-locale thunk))
|
||
|
||
(define (under-french-utf8-locale-or-unresolved thunk)
|
||
(under-locale-or-unresolved %french-utf8-locale thunk))
|
||
|
||
(define (under-turkish-utf8-locale-or-unresolved thunk)
|
||
;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have
|
||
;; a broken tr_TR locale where `i' is mapped to uppercase `I'
|
||
;; instead of `İ', so disable tests on that platform.
|
||
(if (or (string-contains %host-type "freebsd8")
|
||
(string-contains %host-type "freebsd9")
|
||
(string-contains %host-type "solaris2.10")
|
||
(string-contains %host-type "darwin8")
|
||
(string-contains %host-type "mingw32"))
|
||
(throw 'unresolved)
|
||
(under-locale-or-unresolved %turkish-utf8-locale thunk)))
|
||
|
||
(define (under-german-utf8-locale-or-unresolved thunk)
|
||
(under-locale-or-unresolved %german-utf8-locale thunk))
|
||
|
||
(define (under-greek-utf8-locale-or-unresolved thunk)
|
||
(under-locale-or-unresolved %greek-utf8-locale thunk))
|
||
|
||
(define (under-american-english-locale-or-unresolved thunk)
|
||
(under-locale-or-unresolved %american-english-locale thunk))
|
||
|
||
|
||
(with-test-prefix "text collation (French)"
|
||
|
||
(pass-if "string-locale<?"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(string-locale<? "été" "hiver" %french-locale))))
|
||
|
||
(pass-if "char-locale<?"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(char-locale<? #\é #\h %french-locale))))
|
||
|
||
(pass-if "string-locale-ci=?"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(string-locale-ci=? "ÉTÉ" "été" %french-locale))))
|
||
|
||
(pass-if "string-locale-ci=? (2 args, wide strings)"
|
||
(under-french-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; Note: Character `œ' is not part of Latin-1, so these are wide
|
||
;; strings.
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(setlocale LC_ALL %french-utf8-locale-name))
|
||
(lambda ()
|
||
(string-locale-ci=? "œuf" "ŒUF"))
|
||
(lambda ()
|
||
(setlocale LC_ALL "C"))))))
|
||
|
||
(pass-if "string-locale-ci=? (3 args, wide strings)"
|
||
(under-french-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
|
||
|
||
(pass-if "string-locale-ci<>?"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(and (string-locale-ci<? "été" "Hiver" %french-locale)
|
||
(string-locale-ci>? "HiVeR" "été" %french-locale)))))
|
||
|
||
(pass-if "string-locale-ci<>? (wide strings)"
|
||
(under-french-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; One of the strings is UCS-4, the other is Latin-1.
|
||
(and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
|
||
(string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
|
||
|
||
(pass-if "string-locale-ci<>? (wide and narrow strings)"
|
||
(under-french-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; One of the strings is UCS-4, the other is Latin-1.
|
||
(and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
|
||
(string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
|
||
|
||
(pass-if "char-locale-ci<>?"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(and (char-locale-ci<? #\é #\H %french-locale)
|
||
(char-locale-ci>? #\h #\É %french-locale)))))
|
||
|
||
(pass-if "char-locale-ci<>? (wide)"
|
||
(under-french-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(and (char-locale-ci<? #\o #\œ %french-utf8-locale)
|
||
(char-locale-ci>? #\Π#\e %french-utf8-locale))))))
|
||
|
||
|
||
(with-test-prefix "text collation (German)"
|
||
|
||
(pass-if "string-locale-ci=?"
|
||
(under-german-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((de (make-locale LC_ALL %german-utf8-locale-name)))
|
||
(string-locale-ci=? "Straße" "STRASSE"))))))
|
||
|
||
|
||
(with-test-prefix "text collation (Greek)"
|
||
|
||
(pass-if "string-locale-ci=?"
|
||
(under-greek-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
|
||
(string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
|
||
|
||
|
||
(with-test-prefix "character mapping"
|
||
|
||
(pass-if "char-locale-downcase"
|
||
(and (eqv? #\a (char-locale-downcase #\A))
|
||
(eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-upcase"
|
||
(and (eqv? #\Z (char-locale-upcase #\z))
|
||
(eqv? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-titlecase"
|
||
(and (eqv? #\T (char-locale-titlecase #\t))
|
||
(eqv? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-titlecase Dž"
|
||
(and (eqv? #\762 (char-locale-titlecase #\763))
|
||
(eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-upcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(eqv? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
|
||
|
||
(pass-if "char-locale-downcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(eqv? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
|
||
|
||
|
||
(with-test-prefix "string mapping"
|
||
|
||
(pass-if "string-locale-downcase"
|
||
(and (string=? "a" (string-locale-downcase "A"))
|
||
(string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "string-locale-upcase"
|
||
(and (string=? "Z" (string-locale-upcase "z"))
|
||
(string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "string-locale-titlecase"
|
||
(and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
|
||
(string=? "Hello, World" (string-locale-titlecase
|
||
"hello, world" (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "string-locale-upcase German"
|
||
(under-german-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((de (make-locale LC_ALL %german-utf8-locale-name)))
|
||
(string=? "STRASSE"
|
||
(string-locale-upcase "Straße" de))))))
|
||
|
||
(pass-if "string-locale-upcase Greek"
|
||
(under-greek-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
|
||
(string=? "ΧΑΟΣ"
|
||
(string-locale-upcase "χαος" el))))))
|
||
|
||
(pass-if "string-locale-upcase Greek (two sigmas)"
|
||
(under-greek-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
|
||
(string=? "ΓΕΙΆ ΣΑΣ"
|
||
(string-locale-upcase "Γειά σας" el))))))
|
||
|
||
(pass-if "string-locale-downcase Greek"
|
||
(under-greek-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
|
||
(string=? "χαος"
|
||
(string-locale-downcase "ΧΑΟΣ" el))))))
|
||
|
||
(pass-if "string-locale-downcase Greek (two sigmas)"
|
||
(under-greek-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
|
||
(string=? "γειά σας"
|
||
(string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))
|
||
|
||
(pass-if "string-locale-upcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
|
||
|
||
(pass-if "string-locale-downcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
(string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
|
||
|
||
|
||
(with-test-prefix "number parsing"
|
||
|
||
(pass-if "locale-string->integer"
|
||
(call-with-values (lambda () (locale-string->integer "123"))
|
||
(lambda (result char-count)
|
||
(and (equal? result 123)
|
||
(equal? char-count 3)))))
|
||
|
||
(pass-if "locale-string->inexact"
|
||
(call-with-values
|
||
(lambda ()
|
||
(locale-string->inexact "123.456"
|
||
(make-locale (list LC_NUMERIC) "C")))
|
||
(lambda (result char-count)
|
||
(and (equal? result 123.456)
|
||
(equal? char-count 7)))))
|
||
|
||
(pass-if "locale-string->inexact (French)"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(call-with-values
|
||
(lambda ()
|
||
(locale-string->inexact "123,456" %french-locale))
|
||
(lambda (result char-count)
|
||
(and (equal? result 123.456)
|
||
(equal? char-count 7))))))))
|
||
|
||
|
||
;;;
|
||
;;; `nl-langinfo'
|
||
;;;
|
||
|
||
(setlocale LC_ALL "C")
|
||
(define %c-locale (make-locale LC_ALL "C"))
|
||
|
||
(define %english-days
|
||
'("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
|
||
|
||
(define (every? . args)
|
||
(not (not (apply every args))))
|
||
|
||
|
||
(with-test-prefix "nl-langinfo et al."
|
||
|
||
(pass-if "locale-day (1 arg)"
|
||
(every? equal?
|
||
%english-days
|
||
(map locale-day (map 1+ (iota 7)))))
|
||
|
||
(pass-if "locale-day (2 args)"
|
||
(every? equal?
|
||
%english-days
|
||
(map (lambda (day)
|
||
(locale-day day %c-locale))
|
||
(map 1+ (iota 7)))))
|
||
|
||
(pass-if "locale-day (2 args, using `%global-locale')"
|
||
(every? equal?
|
||
%english-days
|
||
(map (lambda (day)
|
||
(locale-day day %global-locale))
|
||
(map 1+ (iota 7)))))
|
||
|
||
(pass-if "locale-day (French)"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((result (locale-day 3 %french-locale)))
|
||
(and (string? result)
|
||
(string-ci=? result "mardi"))))))
|
||
|
||
(pass-if "locale-day (French, using `%global-locale')"
|
||
;; Make sure `%global-locale' captures the current locale settings as
|
||
;; installed using `setlocale'.
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(setlocale LC_TIME %french-locale-name))
|
||
(lambda ()
|
||
(let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
|
||
(result (locale-day 3 fr)))
|
||
(setlocale LC_ALL "C")
|
||
(and (string? result)
|
||
(string-ci=? result "mardi"))))
|
||
(lambda ()
|
||
(setlocale LC_ALL "C"))))))
|
||
|
||
(pass-if "default locale"
|
||
;; Make sure the default locale does not capture the current locale
|
||
;; settings as installed using `setlocale'. The default locale should be
|
||
;; "C".
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(setlocale LC_ALL %french-locale-name))
|
||
(lambda ()
|
||
(let* ((locale (make-locale (list LC_MONETARY) "C"))
|
||
(result (locale-day 3 locale)))
|
||
(setlocale LC_ALL "C")
|
||
(and (string? result)
|
||
(string-ci=? result "Tuesday"))))
|
||
(lambda ()
|
||
(setlocale LC_ALL "C")))))))
|
||
|
||
|
||
;;;
|
||
;;; Numbers.
|
||
;;;
|
||
|
||
(with-test-prefix "number->locale-string"
|
||
|
||
;; We assume the global locale is "C" at this point.
|
||
|
||
(with-test-prefix "C"
|
||
|
||
(pass-if "no thousand separator"
|
||
;; Unlike in English, the "C" locale has no thousand separator.
|
||
;; If this doesn't hold, the following tests will fail.
|
||
(string=? "" (locale-thousands-separator)))
|
||
|
||
(pass-if "integer"
|
||
(string=? "123456" (number->locale-string 123456)))
|
||
|
||
(pass-if "fraction"
|
||
(string=? "1234.567" (number->locale-string 1234.567)))
|
||
|
||
(pass-if "fraction, 1 digit"
|
||
(string=? "1234.5" (number->locale-string 1234.567 1))))
|
||
|
||
(with-test-prefix "French"
|
||
|
||
(pass-if "integer"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((fr (make-locale LC_ALL %french-locale-name)))
|
||
(string=? "123 456" (number->locale-string 123456 #t fr))))))
|
||
|
||
(pass-if "fraction"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((fr (make-locale LC_ALL %french-locale-name)))
|
||
(string=? "1 234,567" (number->locale-string 1234.567 #t fr))))))
|
||
|
||
(pass-if "fraction, 1 digit"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((fr (make-locale LC_ALL %french-locale-name)))
|
||
(string=? "1 234,5"
|
||
(number->locale-string 1234.567 1 fr))))))))
|
||
|
||
(with-test-prefix "format ~h"
|
||
|
||
;; Some systems like Darwin lack the `GROUPING' nl_item, and thus
|
||
;; `locale-digit-grouping' defaults to '(); skip the tests in that
|
||
;; case.
|
||
|
||
(with-test-prefix "French"
|
||
|
||
(pass-if "12345.5678"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(if (null? (locale-digit-grouping %french-locale))
|
||
(throw 'unresolved)
|
||
(string=? "12 345,6789"
|
||
(format #f "~:h" 12345.6789 %french-locale)))))))
|
||
|
||
(with-test-prefix "English"
|
||
|
||
(pass-if "12345.5678"
|
||
(under-american-english-locale-or-unresolved
|
||
(lambda ()
|
||
(if (null? (locale-digit-grouping %american-english-locale))
|
||
(throw 'unresolved)
|
||
(string=? "12,345.6789"
|
||
(format #f "~:h" 12345.6789
|
||
%american-english-locale))))))))
|
||
|
||
(with-test-prefix "monetary-amount->locale-string"
|
||
|
||
(with-test-prefix "French"
|
||
|
||
(pass-if "integer"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((fr (make-locale LC_ALL %french-locale-name)))
|
||
(string=? "123 456 +EUR"
|
||
(monetary-amount->locale-string 123456 #f fr))))))
|
||
|
||
(pass-if "fraction"
|
||
(under-french-locale-or-unresolved
|
||
(lambda ()
|
||
(let ((fr (make-locale LC_ALL %french-locale-name)))
|
||
(string=? "1 234,56 EUR "
|
||
(monetary-amount->locale-string 1234.567 #t fr))))))))
|