From 55cdc6b3ac8642be524b1b1b8b4ee29f14b64b10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miguel=20=C3=81ngel=20Arruga=20Vivas?= Date: Mon, 12 Oct 2020 14:02:40 +0200 Subject: [PATCH 2/2] Add support for thread-local locale when available. * libguile/i18n.c (scm_uselocale): New interface for uselocale. (internal_uselocale): New internal function. (scm_with_thread_locale): New function. (scm_init_i18n): Add feature "uselocale". Remove comment about LC_GLOBAL_LOCALE, as it is not exposed directly to Scheme code. * libguile/i18n.h (scm_uselocale, scm_with_thread_locale): New prototypes. * module/ice-9/i18n.scm (with-thread-locale): New macro. * test-suite/tests/i18n.test: Add tests for uselocale feature. * test-suite/tests/time.test: Likewise. These tests were adapted from previous examples. --- libguile/i18n.c | 130 ++++++++++++++++++++++++++++++++++++- libguile/i18n.h | 3 + module/ice-9/i18n.scm | 12 ++++ test-suite/tests/i18n.test | 49 ++++++++++++++ test-suite/tests/time.test | 37 ++++++++++- 5 files changed, 225 insertions(+), 6 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 7b80e7427..b8a14741e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -33,6 +33,7 @@ #include "chars.h" #include "dynwind.h" #include "extensions.h" +#include "eval.h" /* for `scm_call_0' */ #include "feature.h" #include "gsubr.h" #include "list.h" @@ -1886,6 +1887,126 @@ define_langinfo_items (void) #undef DEFINE_NLITEM_CONSTANT } + +/* Thread-specific locale. */ + +#ifdef USE_GNU_LOCALE_API + +SCM_DEFINE (scm_uselocale, "uselocale", 0, 1, 0, (SCM locale), + "This procedure checks and/or modifies the locale used\n" + "by the current thread @emph{without} modifying the\n" + "output port status.\n\n" + "It's responsibility of the user to not rely on the\n" + "globally accessible input and output ports, which usually\n" + "usually is a bad idea in a multi-threaded scenario.\n\n" + "The behaviour is determined by @var{locale}:\n\n" + "@table @r\n" + "@item @var{locale} is not provided\n" + "Only retrieve the locale used by the current thread.\n" + "@item @var{locale} is @code{#f}\n" + "Remove the locale installed in the current thread, if\n" + "there was one installed, and use the global locale.\n" + "@item @var{locale} is a valid @code{} object.\n" + "Install the provided locale to be used by the current\n" + "thread.\n" + "@end table\n\n" + "This procedure return two values:\n\n" + "@enumerate\n" + "@item\n" + "A boolean indicating whether thread has a thread-specific\n" + "locale installed or not.\n" + "@item\n" + "The locale in use by the thread before the call.\n" + "@end enumerate") +#define FUNC_NAME s_scm_uselocale +{ + SCM is_thr_local, ret; + scm_t_locale c_locale, current; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (locale)) + c_locale = (scm_t_locale) 0; + else if (scm_is_false (locale)) + c_locale = LC_GLOBAL_LOCALE; + else + SCM_VALIDATE_LOCALE_COPY(1, locale, c_locale); + + current = uselocale (c_locale); + + if (current == (scm_t_locale) 0) + SCM_SYSERROR; + + if (current == LC_GLOBAL_LOCALE) + is_thr_local = SCM_BOOL_F; + else + is_thr_local = SCM_BOOL_T; + + current = duplocale (current); + + if (current == (scm_t_locale) 0) + SCM_SYSERROR; + + scm_dynwind_unwind_handler ((void (*)(void *))freelocale, current, 0); + + SCM_NEWSMOB (ret, scm_tc16_locale_smob_type, current); + + scm_dynwind_end (); + return scm_values_2 (is_thr_local, ret); +} +#undef FUNC_NAME + +static void +internal_uselocale (void *locale) +#define FUNC_NAME "" +{ + if (uselocale ((scm_t_locale) locale) == (scm_t_locale) 0) + SCM_SYSERROR; +} +#undef FUNC_NAME + +SCM_DEFINE(scm_with_thread_locale, "%with-thread-locale", + 2, 0, 0, + (SCM locale, SCM thunk), + "Execute @var{thunk} with the thread-specific locale\n" + "set to @var{locale}.\n\n" + "It's behaviour is equivalent to the following Scheme\n" + "code:\n\n" + "@example\n" + "(define (%with-thread-locale locale thunk)\n" + " (let (at-exit)\n" + " (define (in-guard)\n" + " (define-values (is-tl locale) (uselocale locale))\n" + " (set! at-exit (and is-tl locale)))\n" + " (define (out-guard)\n" + " (uselocale at-exit))\n" + " (dynamic-wind in-guard thunk out-guard)))\n" + "@end example") +#define FUNC_NAME s_scm_with_thread_locale +{ + SCM ret; + scm_t_locale c_locale, c_current; + + scm_dynwind_begin (0); + + SCM_VALIDATE_LOCALE_COPY(1, locale, c_locale); + + c_current = uselocale (c_locale); + if (c_current == (scm_t_locale) 0) + SCM_SYSERROR; + + scm_dynwind_rewind_handler (internal_uselocale, c_locale, 0); + scm_dynwind_unwind_handler (internal_uselocale, c_current, + SCM_F_WIND_EXPLICITLY); + + ret = scm_call_0 (thunk); + scm_dynwind_end (); + return ret; +} +#undef FUNC_NAME + +#endif /* USE_GNU_LOCALE_API */ + void scm_init_i18n () @@ -1895,12 +2016,15 @@ scm_init_i18n () scm_add_feature ("nl-langinfo"); define_langinfo_items (); +#ifdef USE_GNU_LOCALE_API + scm_add_feature ("uselocale"); +#endif + #include "i18n.x" /* Initialize the global locale object with a special `locale' SMOB. */ - /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of - glibc <= 2.11 not (yet) worked around by Gnulib. See - http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details. */ + /* LC_GLOBAL_LOCALE is only exposed indirectly through uselocale + interface when this is available. */ SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL); SCM_VARIABLE_SET (scm_global_locale, global_locale_smob); } diff --git a/libguile/i18n.h b/libguile/i18n.h index 8ce1ce8e6..0538453ab 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -46,6 +46,9 @@ SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale); SCM_INTERNAL SCM scm_nl_langinfo (SCM item, SCM locale); +SCM_API SCM scm_uselocale (SCM locale); +SCM_API SCM scm_with_thread_locale (SCM locale, SCM thunk); + SCM_INTERNAL void scm_init_i18n (void); SCM_INTERNAL void scm_bootstrap_i18n (void); diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 319d5a23c..8eb931acf 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -35,6 +35,10 @@ make-locale locale? %global-locale + ;; thread-specific locale + uselocale + with-thread-locale + ;; text collation string-locale? string-locale-ci? string-locale-ci=? @@ -91,6 +95,14 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_i18n")) + +;; Define the macro with-thread-locale when the implementation is +;; available. +(define-syntax with-thread-locale + (syntax-rules () + ((_ locale exp exp* ...) + (%with-thread-locale locale (lambda () exp exp* ...))))) + ;;; ;;; Charset/encoding. diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 427aef4f5..f76af4ea6 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -20,6 +20,7 @@ (define-module (test-suite i18n) #:use-module (ice-9 i18n) + #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (test-suite lib)) @@ -726,3 +727,51 @@ (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string .00003 #t fr))))))) + +;;; +;;; Thread local facilities. +;;; + +(with-test-prefix "uselocale" + (define (check-provided features) + (for-each (lambda (feature) + (or (provided? feature) (throw 'unsupported))) + features)) + + (pass-if "main thread use global locale" + (check-provided '(uselocale)) + + (not (uselocale))) + + (pass-if "fresh thread use global locale" + (check-provided '(uselocale threads)) + + (join-thread (begin-thread (not (uselocale))))) + + (pass-if "fresh thread install locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + + (join-thread + (begin-thread + (uselocale %c-locale) + (uselocale)))) + + (pass-if "clean thread locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + (join-thread + (begin-thread + (uselocale %c-locale) + (uselocale #f) + (not (uselocale))))) + + (with-test-prefix "with-thread-locale" + + (pass-if "locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + + (join-thread + (begin-thread + (with-thread-locale %c-locale (uselocale))))))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index 0291b6bdf..0758e3940 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -19,7 +19,8 @@ (define-module (test-suite test-time) #:use-module (test-suite lib) - #:use-module (ice-9 threads)) + #:use-module (ice-9 threads) + #:use-module (ice-9 i18n)) ;;; ;;; gmtime @@ -240,7 +241,22 @@ (pass-if-equal "strftime fr_FR.iso88591" ; " 1 février 1970" (with-locale "fr_FR.iso88591" - (strftime "%e %B %Y" (gmtime (* 31 24 3600))))))) + (strftime "%e %B %Y" (gmtime (* 31 24 3600)))))) + + (with-test-prefix "uselocale" + (define (strftime-tl loc fmt tm) + (unless (and (provided? 'threads) (provided? 'uselocale)) + (throw 'unsupported)) + (join-thread + (begin-thread + (with-thread-locale (make-locale LC_ALL loc) (strftime fmt tm))))) + + (pass-if-equal "fr_FR.utf8" + " 1 février 1970" + (strftime-tl "fr_FR.utf8" "%e %B %Y" (gmtime (* 31 24 3600)))) + (pass-if-equal "fr_FR.iso88591" + " 1 février 1970" + (strftime-tl "fr_FR.iso88591" "%e %B %Y" (gmtime (* 31 24 3600)))))) ;;; ;;; strptime @@ -295,4 +311,19 @@ (putenv "TZ=EST+5") (tzset) (let ((tm (car (strptime "%s" "86400")))) - (eqv? (* 5 3600) (tm:gmtoff tm)))))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + (with-test-prefix "uselocale" + (define (strptime-tl loc fmt str) + (unless (and (provided? 'threads) (provided? 'uselocale)) + (throw 'unsupported)) + (join-thread + (begin-thread + (with-thread-locale (make-locale LC_ALL loc) + (let ((tm (car (strptime fmt str)))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))))) + (pass-if-equal "strftime fr_FR.utf8" + '(1 2 1999) + (strptime-tl "fr_FR.utf8" "%e %B %Y" " 1 février 1999")))) -- 2.28.0