diff options
-rw-r--r-- | test-suite/lib.scm | 23 | ||||
-rw-r--r-- | test-suite/tests/encoding-escapes.test | 27 | ||||
-rw-r--r-- | test-suite/tests/encoding-iso88591.test | 8 | ||||
-rw-r--r-- | test-suite/tests/encoding-iso88597.test | 7 | ||||
-rw-r--r-- | test-suite/tests/encoding-utf8.test | 7 | ||||
-rw-r--r-- | test-suite/tests/srfi-14.test | 182 |
6 files changed, 124 insertions, 130 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 8190d1fd0..e5b7a0813 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -46,6 +46,9 @@ ;; Using the debugging evaluator. with-debugging-evaluator with-debugging-evaluator* +;; Using a given locale +with-locale with-locale* + ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts @@ -437,6 +440,26 @@ (define-macro (with-debugging-evaluator . body) `(with-debugging-evaluator* (lambda () ,@body))) +;;; Call THUNK with a given locale +(define (with-locale* nloc thunk) + (let ((loc #f)) + (dynamic-wind + (lambda () + (if (defined? 'setlocale) + (begin + (set! loc + (false-if-exception (setlocale LC_ALL nloc))) + (if (not loc) + (throw 'unresolved))) + (throw 'unresolved))) + thunk + (lambda () + (if (defined? 'setlocale) + (setlocale LC_ALL loc)))))) + +;;; Evaluate BODY... using the given locale. +(define-macro (with-locale loc . body) + `(with-locale* ,loc (lambda () ,@body))) ;;;; REPORTERS diff --git a/test-suite/tests/encoding-escapes.test b/test-suite/tests/encoding-escapes.test index 8859d2e83..ea7a821e7 100644 --- a/test-suite/tests/encoding-escapes.test +++ b/test-suite/tests/encoding-escapes.test @@ -118,22 +118,23 @@ (string=? "\\xfaltima" (get-output-string pt)))) (pass-if "Rashomon" - (let ((pt (open-output-string))) - (set-port-encoding! pt "ASCII") - (set-port-conversion-strategy! pt 'escape) - (display s4 pt) - (string=? "\\u7F85\\u751F\\u9580" - (get-output-string pt))))) - -(setlocale LC_ALL "en_US.utf8") + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'escape) + (display s4 pt) + (string=? "\\u7F85\\u751F\\u9580" + (get-output-string pt))))) (with-test-prefix "input escapes" - (pass-if "última" - (string=? "última" - (with-input-from-string "\"\\xfaltima\"" read))) + (pass-if "última" + (with-locale "en_US.utf8" + (string=? "última" + (with-input-from-string "\"\\xfaltima\"" read)))) (pass-if "羅生門" - (string=? "羅生門" - (with-input-from-string "\"\\u7F85\\u751F\\u9580\"" read)))) + (with-locale "en_US.utf8" + (string=? "羅生門" + (with-input-from-string + "\"\\u7F85\\u751F\\u9580\"" read))))) diff --git a/test-suite/tests/encoding-iso88591.test b/test-suite/tests/encoding-iso88591.test index edd573432..d4de5e534 100644 --- a/test-suite/tests/encoding-iso88591.test +++ b/test-suite/tests/encoding-iso88591.test @@ -28,7 +28,10 @@ (define (string-ints . args) (apply string (map integer->char args))) -(setlocale LC_ALL "") +;; Set locale to the environment's locale, so that the prints look OK. +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) (define s1 "ltima") (define s2 "cdula") @@ -132,4 +135,5 @@ (display (string-ints 256) pt)))) ;; Reset locales -(setlocale LC_ALL "C")
\ No newline at end of file +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/encoding-iso88597.test b/test-suite/tests/encoding-iso88597.test index 8985042f4..22212690c 100644 --- a/test-suite/tests/encoding-iso88597.test +++ b/test-suite/tests/encoding-iso88597.test @@ -28,7 +28,9 @@ (define (string-ints . args) (apply string (map integer->char args))) -(setlocale LC_ALL "") +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) (define s1 "") (define s2 "") @@ -133,4 +135,5 @@ (display (string-ints #x0400) pt)))) ;; Reset locale -(setlocale LC_ALL "C")
\ No newline at end of file +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/encoding-utf8.test b/test-suite/tests/encoding-utf8.test index 83e7540f3..a2613f1d7 100644 --- a/test-suite/tests/encoding-utf8.test +++ b/test-suite/tests/encoding-utf8.test @@ -28,7 +28,9 @@ (define (string-ints . args) (apply string (map integer->char args))) -(setlocale LC_ALL "") +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) (define s1 "última") (define s2 "cédula") @@ -102,4 +104,5 @@ (ñ 2)) (eq? (+ 芥川龍之介 ñ) 3)))) - +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index 2bb934aac..56c944a42 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -238,9 +238,6 @@ (string=? (char-set->string cs) "egilu")))) -;; Make sure we get an ASCII charset and character classification. -(if (defined? 'setlocale) (setlocale LC_CTYPE "C")) - (with-test-prefix "standard char sets (ASCII)" (pass-if "char-set:lower-case" @@ -340,142 +337,105 @@ (define (every? pred lst) (not (not (every pred lst)))) -(define (find-latin1-locale) - ;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure. - (if (defined? 'setlocale) - (let loop ((locales (map (lambda (lang) - (string-append lang ".iso88591")) - '("de_DE" "en_GB" "en_US" "es_ES" - "fr_FR" "it_IT")))) - (if (null? locales) - #f - (if (false-if-exception (setlocale LC_CTYPE (car locales))) - (car locales) - (loop (cdr locales))))) - #f)) - - -(define %latin1 (find-latin1-locale)) +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) (with-test-prefix "Latin-1 (8-bit charset)" (pass-if "char-set:lower-case" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string-append "abcdefghijklmnopqrstuvwxyz" - "") - char-set:lower-case)))) + (char-set<= (string->char-set + (string-append "abcdefghijklmnopqrstuvwxyz" + "") + char-set:lower-case))) (pass-if "char-set:upper-case" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "") - char-set:lower-case)))) + (char-set<= (string->char-set + (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "") + char-set:lower-case))) (pass-if "char-set:title-case" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set "") - char-set:title-case))) + (char-set<= (string->char-set "") + char-set:title-case)) (pass-if "char-set:letter" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string-append - ;; Lowercase - "abcdefghijklmnopqrstuvwxyz" - "" - ;; Uppercase - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "" - ;; Uncased - "")) - char-set:letter))) + (char-set<= (string->char-set + (string-append + ;; Lowercase + "abcdefghijklmnopqrstuvwxyz" + "" + ;; Uppercase + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "" + ;; Uncased + "")) + char-set:letter)) (pass-if "char-set:digit" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set "0123456789") - char-set:digit))) + (char-set<= (string->char-set "0123456789") + char-set:digit)) (pass-if "char-set:hex-digit" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set "0123456789abcdefABCDEF") - char-set:hex-digit))) + (char-set<= (string->char-set "0123456789abcdefABCDEF") + char-set:hex-digit)) (pass-if "char-set:letter+digit" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (char-set-union - char-set:letter - char-set:digit) - char-set:letter+digit))) + (char-set<= (char-set-union + char-set:letter + char-set:digit) + char-set:letter+digit)) (pass-if "char-set:punctuation" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string-append "!\"#%&'()*,-./:;?@[\\]_{}" - "")) - char-set:punctuation))) + (char-set<= (string->char-set + (string-append "!\"#%&'()*,-./:;?@[\\]_{}" + "")) + char-set:punctuation)) (pass-if "char-set:symbol" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string-append "$+<=>^`|~" - "")) - char-set:symbol))) + (char-set<= (string->char-set + (string-append "$+<=>^`|~" + "")) + char-set:symbol)) ;; Note that SRFI-14 itself is inconsistent here. Characters that ;; are non-digit numbers (such as category No) are clearly 'graphic' ;; but don't occur in the letter, digit, punct, or symbol charsets. (pass-if "char-set:graphic" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (char-set-union - char-set:letter - char-set:digit - char-set:punctuation - char-set:symbol) - char-set:graphic))) + (char-set<= (char-set-union + char-set:letter + char-set:digit + char-set:punctuation + char-set:symbol) + char-set:graphic)) (pass-if "char-set:whitespace" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (string - (integer->char #x09) - (integer->char #x0a) - (integer->char #x0b) - (integer->char #x0c) - (integer->char #x0d) - (integer->char #x20) - (integer->char #xa0))) - char-set:whitespace))) + (char-set<= (string->char-set + (string + (integer->char #x09) + (integer->char #x0a) + (integer->char #x0b) + (integer->char #x0c) + (integer->char #x0d) + (integer->char #x20) + (integer->char #xa0))) + char-set:whitespace)) (pass-if "char-set:printing" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (char-set-union char-set:graphic char-set:whitespace) - char-set:printing))) + (char-set<= (char-set-union char-set:graphic char-set:whitespace) + char-set:printing)) (pass-if "char-set:iso-control" - (if (not %latin1) - (throw 'unresolved) - (char-set<= (string->char-set - (apply string - (map integer->char (append - ;; U+0000 to U+001F - (iota #x20) - (list #x7f) - ;; U+007F to U+009F - (map (lambda (x) (+ #x80 x)) - (iota #x20)))))) - char-set:iso-control)))) - + (char-set<= (string->char-set + (apply string + (map integer->char (append + ;; U+0000 to U+001F + (iota #x20) + (list #x7f) + ;; U+007F to U+009F + (map (lambda (x) (+ #x80 x)) + (iota #x20)))))) + char-set:iso-control))) + +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) |