Commit f0f31f6eee for perl
commit f0f31f6eee14078dac9e2ec0a375d9e848cfd723
Author: Alin Iacob <alinbsp@gmail.com>
Date: Tue Sep 15 20:57:11 2026 +0300
Fix locale inheritance in Windows pseudofork
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 45e5f1f75a..c1ef55bc0f 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -528,6 +528,13 @@ manager will later use a regex to expand these into links.
=item *
+On Windows, C<fork()> now preserves the parent's locale settings in the
+child. Previously, a child could use locale-specific decimal separators
+without C<use locale>, and decimal literals compiled in the child could
+lose their fractional part. [GH #24166]
+
+=item *
+
Since 5.28.0, the numeric value of a string would sometimes not get reset
after the string was assigned to as part of a string concatenation. It
required the following circumstances to all be present for the bug to
diff --git a/t/run/locale.t b/t/run/locale.t
index 4f7ba6f6eb..4cf2a97c72 100644
--- a/t/run/locale.t
+++ b/t/run/locale.t
@@ -167,6 +167,50 @@ EOF
}
setlocale(LC_NUMERIC, $original_locale);
+ SKIP: { # GH #24166
+ skip("Windows pseudofork test", 2) unless $Config{d_pseudofork};
+ skip("no locale available where LC_NUMERIC is a comma", 2) unless $comma;
+
+ delete local $ENV{LC_ALL};
+ local $ENV{LC_NUMERIC} = $comma;
+ fresh_perl_is(<<'EOF', "1.5 0.5", { eval $switches },
+ my $pid = fork();
+ die "fork: $!" unless defined $pid;
+ if (!$pid) {
+ # Parse the decimal literal after fork to exercise the child's locale.
+ eval q{ my $f = 1.5; print "$f ", 1/2; };
+ die $@ if $@;
+ exit 0;
+ }
+ waitpid($pid, 0);
+ die "child failed: $?" if $?;
+EOF
+ "Pseudofork does not enable locale for decimal parsing or formatting");
+
+ $ENV{LC_NUMERIC} = 'C';
+ fresh_perl_is(<<"EOF",
+ use POSIX qw(locale_h);
+ setlocale(LC_NUMERIC, "$comma") or die 'setlocale';
+ my \$before = setlocale(LC_ALL);
+ my \$pid = fork();
+ die "fork: \$!" unless defined \$pid;
+ if (!\$pid) {
+ print setlocale(LC_ALL) eq \$before ? "inherited\n" : "changed\n";
+ { use locale; my \$f = 1.5; print "\$f\n"; }
+ setlocale(LC_ALL, 'C') or die 'setlocale';
+ exit 0;
+ }
+ waitpid(\$pid, 0);
+ die "child failed: \$?" if \$?;
+ print setlocale(LC_ALL) eq \$before
+ ? "parent unchanged\n" : "parent changed\n";
+ my \$f = 1.5;
+ print \$f;
+EOF
+ "inherited\n1,5\nparent unchanged\n1.5", { eval $switches },
+ "Pseudofork inherits mixed runtime locales without changing its parent");
+ }
+
SKIP: {
skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
unless $utf8_radix;
diff --git a/win32/perlhost.h b/win32/perlhost.h
index af5e320afa..5e84ed43e4 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1853,11 +1853,19 @@ PerlProcGetTimeOfDay(const struct IPerlProc** piPerl, struct timeval *t, void *z
}
#ifdef USE_ITHREADS
+struct win32_fork_params {
+ PerlInterpreter *perl;
+#ifdef USE_LOCALE
+ char locale[1];
+#endif
+};
+
PERL_STACK_REALIGN
static THREAD_RET_TYPE
win32_start_child(LPVOID arg)
{
- PerlInterpreter *my_perl = (PerlInterpreter*)arg;
+ win32_fork_params *params = (win32_fork_params *)arg;
+ PerlInterpreter *my_perl = params->perl;
int status;
HWND parent_message_hwnd;
#ifdef PERL_SYNC_FORK
@@ -1869,6 +1877,18 @@ win32_start_child(LPVOID arg)
PERL_SET_THX(my_perl);
win32_checkTLS(my_perl);
+ /* thread_locale_init() starts in the C locale. A forked child must
+ * inherit its parent's locales. Restore them through Perl_setlocale()
+ * so Perl's locale state and LC_NUMERIC toggling stay in sync. */
+ thread_locale_init();
+#ifdef USE_LOCALE
+ if (! Perl_setlocale(LC_ALL, params->locale))
+ Perl_croak(aTHX_ "panic: cannot restore locale after fork");
+#endif
+#ifndef PERL_SYNC_FORK
+ PerlMemShared_free(params);
+#endif
+
#ifdef PERL_SYNC_FORK
w32_pseudo_id = id;
#else
@@ -1986,6 +2006,20 @@ PerlProcFork(const struct IPerlProc** piPerl)
errno = EAGAIN;
return -1;
}
+ Size_t params_size = sizeof(win32_fork_params);
+#ifdef USE_LOCALE
+ const char *parent_locale = Perl_setlocale(LC_ALL, NULL);
+ params_size += strlen(parent_locale);
+#endif
+ win32_fork_params *params =
+ (win32_fork_params *)PerlMemShared_malloc(params_size);
+ if (!params) {
+ errno = ENOMEM;
+ return -1;
+ }
+#ifdef USE_LOCALE
+ strcpy(params->locale, parent_locale);
+#endif
h = new CPerlHost(*(CPerlHost*)w32_internal_host);
PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
CLONEf_COPY_STACKS,
@@ -2001,9 +2035,14 @@ PerlProcFork(const struct IPerlProc** piPerl)
);
new_perl->Isys_intern.internal_host = h;
h->host_perl = new_perl;
+ params->perl = new_perl;
# ifdef PERL_SYNC_FORK
- id = win32_start_child((LPVOID)new_perl);
+ id = win32_start_child((LPVOID)params);
PERL_SET_THX(aTHX);
+# ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
+ switch_locale_context();
+# endif
+ PerlMemShared_free(params);
# else
if (w32_message_hwnd == INVALID_HANDLE_VALUE)
w32_message_hwnd = win32_create_message_window();
@@ -2012,13 +2051,14 @@ PerlProcFork(const struct IPerlProc** piPerl)
(w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
# ifdef USE_RTL_THREAD_API
handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
- (void*)new_perl, 0, (unsigned*)&id);
+ (void*)params, 0, (unsigned*)&id);
# else
handle = CreateThread(NULL, 0, win32_start_child,
- (LPVOID)new_perl, 0, &id);
+ (LPVOID)params, 0, &id);
# endif
PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
if (!handle) {
+ PerlMemShared_free(params);
errno = EAGAIN;
return -1;
}