[WIP: PATCH 2/2] uselocale

["Miguel Ángel Arruga Vivas" <rosen644835@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 33 bytes --]

This one is the uselocale code.


[-- Attachment #1.2: 0002-uselocale.patch --]
[-- Type: text/x-patch, Size: 11437 bytes --]

From 55cdc6b3ac8642be524b1b1b8b4ee29f14b64b10 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Miguel=20=C3=81ngel=20Arruga=20Vivas?=
 <rosen644835@gmail.com>
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
 }
 
+\f
+/* 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{<locale>} 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 "<internal-uselocale>"
+{
+  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 */
+
 \f
 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>?
            string-locale-ci<? string-locale-ci>? string-locale-ci=?
@@ -91,6 +95,14 @@
   (load-extension (string-append "libguile-" (effective-version))
                   "scm_init_i18n"))
 
+\f
+;; 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* ...)))))
+
 \f
 ;;;
 ;;; 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)))))))
+\f
+;;;
+;;; 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" ;<https://bugs.gnu.org/35920>
         " 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


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 658 bytes --]