mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 12:20:20 +02:00
820f33aaed
* doc/ref/api-data.texi (Characters): Documentation for `char-titlecase'. * doc/ref/api-i18n.texi (Character Case Mapping): Documentation for `char-locale-titlecase' and `string-locale-titlecase'. * libguile/chars.c, libguile/chars.h (scm_char_titlecase, scm_c_titlecase): New functions. * libguile/i18n.c, libguile/i18n.h (chr_to_case, scm_char_locale_titlecase, str_to_case, scm_string_locale_titlecase): New functions. * libguile/i18n.c (scm_char_locale_downcase, scm_char_locale_upcase, scm_string_locale_downcase, scm_string_locale_upcase): Refactor to share code via chr_to_case and str_to_case, as appropriate. * module/ice-9/i18n.scm (char-locale-title-case, string-locale-titlecase): New functions. * libguile/srfi-13.c (string_titlecase_x): Use uc_totitle instead of uc_toupper. * test-suite/tests/chars.test: Tests for `char-titlecase'. * test-suite/tests/i18n.test: Tests for `char-locale-titlecase' and `string-locale-titlecase'. * test-suite/tests/srfi-13.test: Tests for `string-titlecase'.
365 lines
12 KiB
Scheme
365 lines
12 KiB
Scheme
;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2006, 2007, 2009 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 (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_MESSAGES) "C"))))
|
||
|
||
(pass-if "make-locale (3 args)"
|
||
(not (not (make-locale (list LC_COLLATE) "C"
|
||
(make-locale (list LC_MESSAGES) "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"
|
||
(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 %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 %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 %turkish-utf8-locale
|
||
(false-if-exception
|
||
(make-locale LC_ALL
|
||
%turkish-utf8-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)
|
||
(under-locale-or-unresolved %turkish-utf8-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 "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)))))
|
||
|
||
(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 "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")))))
|
||
|
||
(pass-if "char-locale-upcase"
|
||
(and (eq? #\Z (char-locale-upcase #\z))
|
||
(eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-titlecase"
|
||
(and (eq? #\T (char-locale-titlecase #\t))
|
||
(eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-titlecase Dž"
|
||
(and (eq? #\762 (char-locale-titlecase #\763))
|
||
(eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
|
||
|
||
(pass-if "char-locale-upcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; This test is disabled for now, because char-locale-upcase is
|
||
;; incomplete.
|
||
(throw 'untested)
|
||
(eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
|
||
|
||
(pass-if "char-locale-downcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; This test is disabled for now, because char-locale-downcase
|
||
;; is incomplete.
|
||
(throw 'untested)
|
||
(eq? #\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 Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; This test is disabled for now, because string-locale-upcase
|
||
;; is incomplete.
|
||
(throw 'untested)
|
||
(string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
|
||
|
||
(pass-if "string-locale-downcase Turkish"
|
||
(under-turkish-utf8-locale-or-unresolved
|
||
(lambda ()
|
||
;; This test is disabled for now, because
|
||
;; string-locale-downcase is incomplete.
|
||
(throw 'untested)
|
||
(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")))))))
|