-;;;; i18n.test --- Exercise the i18n API.
+;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; 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 2.1 of the License, or (at your option) any later version.
-;;;;
+;;;; 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 (srfi srfi-1)
- :use-module (test-suite lib))
+ #: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")
(not (not (make-locale LC_ALL "C"))))
(pass-if "make-locale (2 args, list)"
- (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C"))))
+ (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_MESSAGES) "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_MESSAGES LC_NUMERIC) "C"
+ (locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
(make-locale (list LC_CTYPE) "C")))))
(pass-if "%global-locale"
(define %french-locale-name
"fr_FR.ISO-8859-1")
+(define %french-utf8-locale-name
+ "fr_FR.UTF-8")
+
+(define %turkish-utf8-locale-name
+ "tr_TR.UTF-8")
+
+(define %german-utf8-locale-name
+ "de_DE.UTF-8")
+
+(define %greek-utf8-locale-name
+ "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 (under-french-locale-or-unresolved thunk)
+(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 %french-locale
- (catch 'system-error thunk
- (lambda (key . args)
- (throw 'unresolved)))
+ (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, and Darwin 8.11.0 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"))
+ (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))))
+ (string-locale<? "été" "hiver" %french-locale))))
(pass-if "char-locale<?"
(under-french-locale-or-unresolved
(lambda ()
- (char-locale<? #\é #\h %french-locale))))
+ (char-locale<? #\é #\h %french-locale))))
(pass-if "string-locale-ci=?"
(under-french-locale-or-unresolved
(lambda ()
- (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
+ (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 "fr_FR.UTF-8"))
+ (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)))))
+ (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))))))
+ (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))))))
+
+\f
+(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"))))))
+
+\f
+(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))))))
\f
(with-test-prefix "character mapping"
(pass-if "char-locale-downcase"
- (and (eq? #\a (char-locale-downcase #\A))
- (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
+ (and (eqv? #\a (char-locale-downcase #\A))
+ (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
(pass-if "char-locale-upcase"
- (and (eq? #\Z (char-locale-upcase #\z))
- (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))))
+ (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))))))
+
+\f
+(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))))))
\f
(with-test-prefix "number parsing"
(lambda ()
(setlocale LC_ALL "C")))))))
+\f
+;;;
+;;; Numbers.
+;;;
+
+(with-test-prefix "number->locale-string"
+
+ ;; We assume the global locale is "C" at this point.
-;;; Local Variables:
-;;; coding: latin-1
-;;; mode: scheme
-;;; End:
+ (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))))))))
HCoop / bpt / guile.git / blobdiff