i18n.test 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744
  1. ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
  2. ;;;;
  3. ;;;; Copyright (C) 2006-2007,2009-2019,2021 Free Software Foundation, Inc.
  4. ;;;; Author: 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. (define-module (test-suite i18n)
  20. #:use-module (ice-9 i18n)
  21. #:use-module (ice-9 format)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (test-suite lib))
  24. ;; Start from a pristine locale state.
  25. (setlocale LC_ALL "C")
  26. (define exception:locale-error
  27. (cons 'system-error "Failed to install locale"))
  28. (with-test-prefix "locale objects"
  29. (pass-if "make-locale (2 args)"
  30. (not (not (make-locale LC_ALL "C"))))
  31. (pass-if "make-locale (2 args, list)"
  32. (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C"))))
  33. (pass-if "make-locale (3 args)"
  34. (not (not (make-locale (list LC_COLLATE) "C"
  35. (make-locale (list LC_NUMERIC) "C")))))
  36. (pass-if-exception "make-locale with unknown locale" exception:locale-error
  37. (make-locale LC_ALL "does-not-exist"))
  38. (pass-if "locale?"
  39. (and (locale? (make-locale (list LC_ALL) "C"))
  40. (locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
  41. (make-locale (list LC_CTYPE) "C")))))
  42. (pass-if "%global-locale"
  43. (and (locale? %global-locale))
  44. (locale? (make-locale (list LC_MONETARY) "C"
  45. %global-locale))))
  46. (with-test-prefix "text collation (English)"
  47. (pass-if "string-locale<?"
  48. (and (string-locale<? "hello" "world")
  49. (string-locale<? "hello" "world"
  50. (make-locale (list LC_COLLATE) "C"))))
  51. (pass-if "char-locale<?"
  52. (and (char-locale<? #\a #\b)
  53. (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))
  54. (pass-if "string-locale-ci=?"
  55. (and (string-locale-ci=? "Hello" "HELLO")
  56. (string-locale-ci=? "Hello" "HELLO"
  57. (make-locale (list LC_COLLATE) "C"))))
  58. (pass-if "string-locale-ci<?"
  59. (and (string-locale-ci<? "hello" "WORLD")
  60. (string-locale-ci<? "hello" "WORLD"
  61. (make-locale (list LC_COLLATE) "C"))))
  62. (pass-if "large strings"
  63. ;; In Guile <= 2.2.4, these would overflow the C stack and crash.
  64. (let ((large (make-string 4000000 #\a)))
  65. (and (string-locale-ci=? large large)
  66. (not (string-locale-ci<? large large))
  67. (not (string-locale<? large large))))))
  68. (define mingw?
  69. (string-contains %host-type "-mingw32"))
  70. (define %french-locale-name
  71. (if mingw?
  72. "fra_FRA.850"
  73. "fr_FR.iso88591")) ;"iso88591" is the "normalized codeset"
  74. ;; What we really want for the following locales is that they be Unicode
  75. ;; capable, not necessarily UTF-8, which Windows does not provide.
  76. (define %french-utf8-locale-name
  77. (if mingw?
  78. "fra_FRA.1252"
  79. "fr_FR.utf8")) ;"utf8" is the "normalized codeset"
  80. (define %turkish-utf8-locale-name
  81. (if mingw?
  82. "tur_TRK.1254"
  83. "tr_TR.utf8"))
  84. (define %german-utf8-locale-name
  85. (if mingw?
  86. "deu_DEU.1252"
  87. "de_DE.utf8"))
  88. (define %greek-utf8-locale-name
  89. (if mingw?
  90. "grc_ELL.1253"
  91. "el_GR.utf8"))
  92. (define %american-english-locale-name
  93. "en_US.utf8")
  94. (define %french-locale
  95. (false-if-exception
  96. (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME LC_MONETARY)
  97. %french-locale-name)))
  98. (define %french-utf8-locale
  99. (false-if-exception
  100. (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME LC_MONETARY)
  101. %french-utf8-locale-name)))
  102. (define %german-utf8-locale
  103. (false-if-exception
  104. (make-locale LC_ALL
  105. %german-utf8-locale-name)))
  106. (define %greek-utf8-locale
  107. (false-if-exception
  108. (make-locale LC_ALL
  109. %greek-utf8-locale-name)))
  110. (define %turkish-utf8-locale
  111. (false-if-exception
  112. (make-locale LC_ALL
  113. %turkish-utf8-locale-name)))
  114. (define %american-english-locale
  115. (false-if-exception
  116. (make-locale LC_ALL
  117. %american-english-locale-name)))
  118. (define (under-locale-or-unresolved locale thunk)
  119. ;; On non-GNU systems, an exception may be raised only when the locale is
  120. ;; actually used rather than at `make-locale'-time. Thus, we must guard
  121. ;; against both.
  122. (if locale
  123. (if (string-contains %host-type "-gnu")
  124. (thunk)
  125. (catch 'system-error thunk
  126. (lambda (key . args)
  127. (throw 'unresolved))))
  128. (throw 'unresolved)))
  129. (define (under-french-locale-or-unresolved thunk)
  130. (under-locale-or-unresolved %french-locale thunk))
  131. (define (under-french-utf8-locale-or-unresolved thunk)
  132. (under-locale-or-unresolved %french-utf8-locale thunk))
  133. (define (under-turkish-utf8-locale-or-unresolved thunk)
  134. ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, Cygwin, and MinGW have
  135. ;; a broken tr_TR locale where `i' is mapped to uppercase `I'
  136. ;; instead of `İ', so disable tests on that platform.
  137. (if (or (string-contains %host-type "freebsd8")
  138. (string-contains %host-type "freebsd9")
  139. (string-contains %host-type "solaris2.10")
  140. (string-contains %host-type "darwin8")
  141. (string-contains %host-type "mingw32")
  142. (string-contains %host-type "cygwin"))
  143. (throw 'unresolved)
  144. (under-locale-or-unresolved %turkish-utf8-locale thunk)))
  145. (define (under-german-utf8-locale-or-unresolved thunk)
  146. (under-locale-or-unresolved %german-utf8-locale thunk))
  147. (define (under-greek-utf8-locale-or-unresolved thunk)
  148. (under-locale-or-unresolved %greek-utf8-locale thunk))
  149. (define (under-american-english-locale-or-unresolved thunk)
  150. (under-locale-or-unresolved %american-english-locale thunk))
  151. (with-test-prefix "text collation (French)"
  152. (pass-if "string-locale<?"
  153. (under-french-locale-or-unresolved
  154. (lambda ()
  155. (string-locale<? "été" "hiver" %french-locale))))
  156. (pass-if "char-locale<?"
  157. (under-french-locale-or-unresolved
  158. (lambda ()
  159. (char-locale<? #\é #\h %french-locale))))
  160. (pass-if "string-locale-ci=?"
  161. (under-french-locale-or-unresolved
  162. (lambda ()
  163. (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
  164. (pass-if "string-locale-ci=? (2 args, wide strings)"
  165. (under-french-utf8-locale-or-unresolved
  166. (lambda ()
  167. ;; Note: Character `œ' is not part of Latin-1, so these are wide
  168. ;; strings.
  169. (dynamic-wind
  170. (lambda ()
  171. (setlocale LC_ALL %french-utf8-locale-name))
  172. (lambda ()
  173. (string-locale-ci=? "œuf" "ŒUF"))
  174. (lambda ()
  175. (setlocale LC_ALL "C"))))))
  176. (pass-if "string-locale<?, bis"
  177. (under-french-utf8-locale-or-unresolved
  178. (lambda ()
  179. (let* ((strings (list "œa" "œb"))
  180. (heads (map (lambda (s) (substring/shared s 0 1)) strings)))
  181. (not (string-locale<? (car heads) (cadr heads)
  182. %french-utf8-locale))))))
  183. (pass-if "string-locale-ci=?, bis"
  184. (under-french-utf8-locale-or-unresolved
  185. (lambda ()
  186. (let* ((strings (list "œa" "œb"))
  187. (heads (map (lambda (s) (substring/shared s 0 1)) strings)))
  188. (string-locale-ci=? (car heads) (cadr heads)
  189. %french-utf8-locale)))))
  190. (pass-if "string-locale-ci=? (3 args, wide strings)"
  191. (under-french-utf8-locale-or-unresolved
  192. (lambda ()
  193. (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
  194. (pass-if "string-locale-ci<>?"
  195. (under-french-locale-or-unresolved
  196. (lambda ()
  197. (and (string-locale-ci<? "été" "Hiver" %french-locale)
  198. (string-locale-ci>? "HiVeR" "été" %french-locale)))))
  199. (pass-if "string-locale-ci<>? (wide strings)"
  200. (under-french-utf8-locale-or-unresolved
  201. (lambda ()
  202. ;; One of the strings is UCS-4, the other is Latin-1.
  203. (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
  204. (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
  205. (pass-if "string-locale-ci<>? (wide and narrow strings)"
  206. (under-french-utf8-locale-or-unresolved
  207. (lambda ()
  208. ;; One of the strings is UCS-4, the other is Latin-1.
  209. (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
  210. (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
  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. (pass-if "char-locale-ci<>? (wide)"
  217. (under-french-utf8-locale-or-unresolved
  218. (lambda ()
  219. (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
  220. (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
  221. (with-test-prefix "text collation (German)"
  222. (pass-if "string-locale-ci=?"
  223. (under-german-utf8-locale-or-unresolved
  224. (lambda ()
  225. (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
  226. (string-locale-ci=? "Straße" "STRASSE"))))))
  227. (with-test-prefix "text collation (Greek)"
  228. (pass-if "string-locale-ci=?"
  229. (under-greek-utf8-locale-or-unresolved
  230. (lambda ()
  231. (let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
  232. (string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
  233. (with-test-prefix "text collation (Czech)"
  234. (pass-if "string-locale<? for 'ch'"
  235. (under-locale-or-unresolved
  236. "cs_CZ.utf8"
  237. (lambda ()
  238. ;; Czech sorts digraph 'ch' between 'h' and 'i'.
  239. ;;
  240. ;; GNU libc 2.22 gets this wrong:
  241. ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=18589>. For
  242. ;; now, just skip it if it fails (XXX).
  243. (or (and (string-locale>? "chxxx" "cxxx")
  244. (string-locale>? "chxxx" "hxxx")
  245. (string-locale<? "chxxxx" "ixxx"))
  246. (throw 'unresolved))))))
  247. (with-test-prefix "character mapping"
  248. (pass-if "char-locale-downcase"
  249. (and (eqv? #\a (char-locale-downcase #\A))
  250. (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
  251. (pass-if "char-locale-upcase"
  252. (and (eqv? #\Z (char-locale-upcase #\z))
  253. (eqv? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
  254. (pass-if "char-locale-titlecase"
  255. (and (eqv? #\T (char-locale-titlecase #\t))
  256. (eqv? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
  257. (pass-if "char-locale-titlecase Dž"
  258. (and (eqv? #\762 (char-locale-titlecase #\763))
  259. (eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
  260. (pass-if "char-locale-upcase Turkish"
  261. (under-turkish-utf8-locale-or-unresolved
  262. (lambda ()
  263. (eqv? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
  264. (pass-if "char-locale-downcase Turkish"
  265. (under-turkish-utf8-locale-or-unresolved
  266. (lambda ()
  267. (eqv? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
  268. (with-test-prefix "string mapping"
  269. (pass-if "string-locale-downcase"
  270. (and (string=? "a" (string-locale-downcase "A"))
  271. (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
  272. (pass-if "string-locale-upcase"
  273. (and (string=? "Z" (string-locale-upcase "z"))
  274. (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
  275. (pass-if "string-locale-titlecase"
  276. (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
  277. (string=? "Hello, World" (string-locale-titlecase
  278. "hello, world" (make-locale LC_ALL "C")))))
  279. (pass-if "large strings"
  280. ;; In Guile <= 2.2.4, these would overflow the C stack and crash.
  281. (let ((hellos (string-join (make-list 700000 "hello")))
  282. (HELLOs (string-join (make-list 700000 "HELLO")))
  283. (Hellos (string-join (make-list 700000 "Hello"))))
  284. (and (string=? hellos (string-locale-downcase Hellos))
  285. (string=? HELLOs (string-locale-upcase Hellos))
  286. (string=? Hellos (string-locale-titlecase hellos)))))
  287. (pass-if "string-locale-upcase German"
  288. (under-german-utf8-locale-or-unresolved
  289. (lambda ()
  290. (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
  291. (string=? "STRASSE"
  292. (string-locale-upcase "Straße" de))))))
  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. (pass-if "string-locale-upcase Greek (two sigmas)"
  300. (under-greek-utf8-locale-or-unresolved
  301. (lambda ()
  302. (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
  303. (string=? "ΓΕΙΆ ΣΑΣ"
  304. (string-locale-upcase "Γειά σας" el))))))
  305. (pass-if "string-locale-downcase Greek"
  306. (under-greek-utf8-locale-or-unresolved
  307. (lambda ()
  308. (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
  309. (string=? "χαος"
  310. (string-locale-downcase "ΧΑΟΣ" el))))))
  311. (pass-if "string-locale-downcase Greek (two sigmas)"
  312. (under-greek-utf8-locale-or-unresolved
  313. (lambda ()
  314. (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
  315. (string=? "γειά σας"
  316. (string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))
  317. (pass-if "string-locale-upcase Turkish"
  318. (under-turkish-utf8-locale-or-unresolved
  319. (lambda ()
  320. (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
  321. (pass-if "string-locale-downcase Turkish"
  322. (under-turkish-utf8-locale-or-unresolved
  323. (lambda ()
  324. (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
  325. (with-test-prefix "number parsing"
  326. (pass-if "locale-string->integer"
  327. (call-with-values (lambda () (locale-string->integer "123"))
  328. (lambda (result char-count)
  329. (and (equal? result 123)
  330. (equal? char-count 3)))))
  331. (pass-if "locale-string->inexact"
  332. (call-with-values
  333. (lambda ()
  334. (locale-string->inexact "123.456"
  335. (make-locale (list LC_NUMERIC) "C")))
  336. (lambda (result char-count)
  337. (and (equal? result 123.456)
  338. (equal? char-count 7)))))
  339. (pass-if "locale-string->inexact (French)"
  340. (under-french-locale-or-unresolved
  341. (lambda ()
  342. (call-with-values
  343. (lambda ()
  344. (locale-string->inexact "123,456" %french-locale))
  345. (lambda (result char-count)
  346. (and (equal? result 123.456)
  347. (equal? char-count 7))))))))
  348. ;;;
  349. ;;; `nl-langinfo'
  350. ;;;
  351. (setlocale LC_ALL "C")
  352. (define %c-locale (make-locale LC_ALL "C"))
  353. (define %english-days
  354. '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
  355. (define (every? . args)
  356. (not (not (apply every args))))
  357. (with-test-prefix "nl-langinfo et al."
  358. (pass-if "locale-day (1 arg)"
  359. (every? equal?
  360. %english-days
  361. (map locale-day (map 1+ (iota 7)))))
  362. (pass-if "locale-day (2 args)"
  363. (every? equal?
  364. %english-days
  365. (map (lambda (day)
  366. (locale-day day %c-locale))
  367. (map 1+ (iota 7)))))
  368. (pass-if "locale-day (2 args, using `%global-locale')"
  369. (every? equal?
  370. %english-days
  371. (map (lambda (day)
  372. (locale-day day %global-locale))
  373. (map 1+ (iota 7)))))
  374. (pass-if "locale-day (French)"
  375. (under-french-locale-or-unresolved
  376. (lambda ()
  377. (let ((result (locale-day 3 %french-locale)))
  378. (and (string? result)
  379. (string-ci=? result "mardi"))))))
  380. (pass-if "locale-day (French, using `%global-locale')"
  381. ;; Make sure `%global-locale' captures the current locale settings as
  382. ;; installed using `setlocale'.
  383. (under-french-locale-or-unresolved
  384. (lambda ()
  385. (dynamic-wind
  386. (lambda ()
  387. (setlocale LC_TIME %french-locale-name))
  388. (lambda ()
  389. (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
  390. (result (locale-day 3 fr)))
  391. (setlocale LC_ALL "C")
  392. (and (string? result)
  393. (string-ci=? result "mardi"))))
  394. (lambda ()
  395. (setlocale LC_ALL "C"))))))
  396. (pass-if "default locale"
  397. ;; Make sure the default locale does not capture the current locale
  398. ;; settings as installed using `setlocale'. The default locale should be
  399. ;; "C".
  400. (under-french-locale-or-unresolved
  401. (lambda ()
  402. (dynamic-wind
  403. (lambda ()
  404. (setlocale LC_ALL %french-locale-name))
  405. (lambda ()
  406. (let* ((locale (make-locale (list LC_MONETARY) "C"))
  407. (result (locale-day 3 locale)))
  408. (setlocale LC_ALL "C")
  409. (and (string? result)
  410. (string-ci=? result "Tuesday"))))
  411. (lambda ()
  412. (setlocale LC_ALL "C"))))))
  413. (pass-if "locale-am-string"
  414. (not (not (member (locale-am-string)
  415. '("AM" "am" "A.M." "a.m.")))))
  416. (pass-if "locale-am-string (greek)"
  417. (under-greek-utf8-locale-or-unresolved
  418. (lambda ()
  419. (not (not (member (locale-am-string %greek-utf8-locale)
  420. '("ΠΜ" "πμ" "Π.Μ." "π.μ.")))))))
  421. (pass-if "locale-pm-string"
  422. (not (not (member (locale-pm-string)
  423. '("PM" "pm" "P.M." "p.m.")))))
  424. (pass-if "locale-pm-string (Greek)"
  425. (under-greek-utf8-locale-or-unresolved
  426. (lambda ()
  427. (not (not (member (locale-pm-string %greek-utf8-locale)
  428. '("ΜΜ" "μμ" "Μ.Μ." "μ.μ.")))))))
  429. (pass-if "locale-digit-grouping"
  430. ;; In the C locale, there is no rule for grouping.
  431. (null? (locale-digit-grouping)))
  432. (pass-if "locale-digit-grouping (French)"
  433. (under-french-locale-or-unresolved
  434. (lambda ()
  435. ;; All systems that have a GROUPING nl_item should know
  436. ;; that French numbers are grouped in 3 digit chunks.
  437. ;; Those systems that have no GROUPING nl_item may use
  438. ;; the hard-coded default of no grouping.
  439. (let ((result (locale-digit-grouping %french-locale)))
  440. (cond
  441. ((null? result)
  442. (throw 'unresolved))
  443. ((eqv? 3 (false-if-exception (car result)))
  444. #t)
  445. (else
  446. #f))))))
  447. (pass-if "locale-positive-separated-by-space?"
  448. ;; In any locale, this must be a boolean.
  449. (let ((result (locale-positive-separated-by-space? #f)))
  450. (or (eqv? #t result)
  451. (eqv? #f result))))
  452. (pass-if "locale-positive-separated-by-space? (international)"
  453. ;; In any locale, this must be a boolean.
  454. (let ((result (locale-positive-separated-by-space? #t)))
  455. (or (eqv? #t result)
  456. (eqv? #f result))))
  457. (pass-if "locale-monetary-grouping"
  458. ;; In the C locale, there is no rule for grouping of digits
  459. ;; of monetary values.
  460. (null? (locale-monetary-grouping)))
  461. (pass-if "locale-monetary-grouping (French)"
  462. (under-french-utf8-locale-or-unresolved
  463. (lambda ()
  464. ;; All systems that have a MON_GROUPING nl_item should know
  465. ;; that French monetary values are grouped in 3 digit chunks.
  466. ;; Those systems that have no MON_GROUPING nl_item may use the
  467. ;; hard-coded default of no grouping.
  468. (let ((result (locale-monetary-grouping %french-utf8-locale)))
  469. (cond
  470. ((null? result)
  471. (throw 'unresolved))
  472. ((eqv? 3 (false-if-exception (car result)))
  473. #t)
  474. (else
  475. #f)))))))
  476. ;;;
  477. ;;; Numbers.
  478. ;;;
  479. (define (french-number-string=? expected result)
  480. ;; Return true if RESULT is equal to EXPECTED, modulo white space.
  481. ;; This is meant to deal with French locales: glibc 2.27+ uses
  482. ;; NO-BREAK SPACE to separate 3-digit groups, whereas earlier versions
  483. ;; used SPACE.
  484. (or (string=? expected result)
  485. (string=? (string-map (lambda (chr)
  486. (case chr
  487. ((#\space) #\240)
  488. (else chr))) ;NO-BREAK SPACE
  489. expected)
  490. result)))
  491. (with-test-prefix "number->locale-string"
  492. ;; We assume the global locale is "C" at this point.
  493. (with-test-prefix "C"
  494. (pass-if-equal "no thousand separator"
  495. ""
  496. ;; Unlike in English, the "C" locale has no thousand separator.
  497. ;; If this doesn't hold, the following tests will fail.
  498. (locale-thousands-separator))
  499. (pass-if-equal "integer"
  500. "123456"
  501. (number->locale-string 123456))
  502. (pass-if-equal "fraction"
  503. "1234.567"
  504. (number->locale-string 1234.567))
  505. (pass-if-equal "fraction, 1 digit"
  506. "1234.6"
  507. (number->locale-string 1234.567 1))
  508. (pass-if-equal "fraction, 10 digits"
  509. "0.0000300000"
  510. (number->locale-string .00003 10))
  511. (pass-if-equal "trailing zeros"
  512. "-10.00000"
  513. (number->locale-string -10.0 5))
  514. (pass-if-equal "positive inexact zero, 1 digit"
  515. "0.0"
  516. (number->locale-string .0 1)))
  517. (with-test-prefix "French"
  518. (pass-if "integer"
  519. (under-french-locale-or-unresolved
  520. (lambda ()
  521. (let ((fr (make-locale LC_ALL %french-locale-name)))
  522. (french-number-string=? "123 456"
  523. (number->locale-string 123456 #t fr))))))
  524. (pass-if "negative integer"
  525. (under-french-locale-or-unresolved
  526. (lambda ()
  527. (let ((fr (make-locale LC_ALL %french-locale-name)))
  528. (french-number-string=? "-1 234 567"
  529. (number->locale-string -1234567 #t fr))))))
  530. (pass-if "fraction"
  531. (under-french-locale-or-unresolved
  532. (lambda ()
  533. (let ((fr (make-locale LC_ALL %french-locale-name)))
  534. (french-number-string=? "1 234,567"
  535. (number->locale-string 1234.567 #t fr))))))
  536. (pass-if "fraction, 1 digit"
  537. (under-french-locale-or-unresolved
  538. (lambda ()
  539. (let ((fr (make-locale LC_ALL %french-locale-name)))
  540. (french-number-string=? "1 234,6"
  541. (number->locale-string 1234.567 1 fr))))))))
  542. (with-test-prefix "format ~h"
  543. ;; Some systems like Darwin lack the `GROUPING' nl_item, and thus
  544. ;; `locale-digit-grouping' defaults to '(); skip the tests in that
  545. ;; case.
  546. (with-test-prefix "French"
  547. (pass-if "12345.678"
  548. (under-french-locale-or-unresolved
  549. (lambda ()
  550. (if (null? (locale-digit-grouping %french-locale))
  551. (throw 'unresolved)
  552. (french-number-string=? "12 345,678"
  553. (format #f "~:h" 12345.678
  554. %french-locale)))))))
  555. (with-test-prefix "English"
  556. (pass-if-equal "12345.678"
  557. "12,345.678"
  558. (under-american-english-locale-or-unresolved
  559. (lambda ()
  560. (if (null? (locale-digit-grouping %american-english-locale))
  561. (throw 'unresolved)
  562. (format #f "~:h" 12345.678
  563. %american-english-locale)))))))
  564. (with-test-prefix "monetary-amount->locale-string"
  565. (with-test-prefix "French"
  566. (pass-if "integer"
  567. (under-french-locale-or-unresolved
  568. (lambda ()
  569. (let* ((fr (make-locale LC_ALL %french-locale-name))
  570. (str (string-trim-both (monetary-amount->locale-string 123456 #f fr))))
  571. ;; Check for both NO-BREAK SPACE and SPACE.
  572. (or (string=? "123 456,00 +EUR" str)
  573. (string=? "123 456,00 +EUR" str))))))
  574. (pass-if "fraction"
  575. (under-french-locale-or-unresolved
  576. (lambda ()
  577. (let* ((fr (make-locale LC_ALL %french-locale-name))
  578. (str (monetary-amount->locale-string 1234.567 #t fr)))
  579. ;; Check for both NO-BREAK SPACE and SPACE.
  580. (or (string=? "1 234,57 EUR " str)
  581. (string=? "1 234,57 EUR " str))))))
  582. (pass-if-equal "positive inexact zero"
  583. "0,00 +EUR"
  584. (under-french-locale-or-unresolved
  585. (lambda ()
  586. (let ((fr (make-locale LC_ALL %french-locale-name)))
  587. (string-trim-both (monetary-amount->locale-string 0. #f fr))))))
  588. (pass-if-equal "one cent"
  589. "0,01 EUR "
  590. (under-french-locale-or-unresolved
  591. (lambda ()
  592. (let ((fr (make-locale LC_ALL %french-locale-name)))
  593. (monetary-amount->locale-string .01 #t fr)))))
  594. (pass-if-equal "very little money"
  595. "0,00 EUR "
  596. (under-french-locale-or-unresolved
  597. (lambda ()
  598. (let ((fr (make-locale LC_ALL %french-locale-name)))
  599. (monetary-amount->locale-string .00003 #t fr)))))))