From 5a6637f01ac3edd837722b6d156ddb2250ea049f Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 3 Jan 2020 22:18:02 -0700 Subject: [PATCH] Fixup POSIX::mbtowc, wctomb This commit enhances these functions so that on threaded perls, they use mbrtowc and wcrtomb when available, making them thread safe. The substitution isn't completely transparent, as no effort is made to hide any differences in errno setting upon error. And there may be slight differences in edge case behavior on some platforms. This commit also changes the behaviors so that they take a scalar parameter instead of a char *, and this might be 'undef' or not be forceable into a valid PV. If not a PV, the functions initialize the shift state. Previously the shift state was always reinitialized with every call, which meant these could not work on locales with shift states. In addition, there were several issues in mbtowc and wctomb that this commit fixes. mbtowc and wctomb, when used, are now run with a semaphore. This avoids races if called at the same time in another thread. The returned wide character from mbtowc() could well have been garbage. The final parameter to mbtowc is now optional, as passing an SV allows us to determine the length without the need for an extra parameter. It is now used only to restrict the parsing of the string to shorter than the actual length. wctomb would segfault if the string parameter was shared or hadn't been pre-allocated with a string of sufficient length to hold the result. --- embedvar.h | 2 + ext/POSIX/POSIX.xs | 108 +++++++++++++++++++++++++++------ ext/POSIX/lib/POSIX.pod | 55 +++++++++++++++-- ext/POSIX/t/mb.t | 80 +++++++++++++++++++++++- intrpvar.h | 6 ++ locale.c | 10 ++- pod/perldelta.pod | 42 ++++++++----- sv.c | 6 ++ t/porting/known_pod_issues.dat | 2 + 9 files changed, 270 insertions(+), 41 deletions(-) diff --git a/embedvar.h b/embedvar.h index 3970f5a42b..ce6ec27cba 100644 --- a/embedvar.h +++ b/embedvar.h @@ -204,6 +204,7 @@ #define PL_max_intro_pending (vTHX->Imax_intro_pending) #define PL_maxsysfd (vTHX->Imaxsysfd) #define PL_mbrlen_ps (vTHX->Imbrlen_ps) +#define PL_mbrtowc_ps (vTHX->Imbrtowc_ps) #define PL_memory_debug_header (vTHX->Imemory_debug_header) #define PL_mess_sv (vTHX->Imess_sv) #define PL_min_intro_pending (vTHX->Imin_intro_pending) @@ -370,6 +371,7 @@ #define PL_warnhook (vTHX->Iwarnhook) #define PL_watchaddr (vTHX->Iwatchaddr) #define PL_watchok (vTHX->Iwatchok) +#define PL_wcrtomb_ps (vTHX->Iwcrtomb_ps) #define PL_xsubfilename (vTHX->Ixsubfilename) #endif /* MULTIPLICITY */ diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 9ea285bc91..befab77181 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1545,7 +1545,7 @@ END_EXTERN_C #if ! defined(HAS_MBLEN) && ! defined(HAS_MBRLEN) #define mblen(a,b) not_here("mblen") #endif -#ifndef HAS_MBTOWC +#if ! defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC) #define mbtowc(pwc, s, n) not_here("mbtowc") #endif #ifndef HAS_WCTOMB @@ -3392,31 +3392,103 @@ mblen(s, n = ~0) OUTPUT: RETVAL -int -mbtowc(pwc, s, n) - wchar_t * pwc - char * s - size_t n - PREINIT: -#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) - mbstate_t ps; -#endif - CODE: -#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) - memset(&ps, 0, sizeof(ps));; - PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */ - errno = 0; - RETVAL = mbrtowc(pwc, s, n, &ps); /* Prefer reentrant version */ +#if defined(HAS_MBRTOWC) && (defined(USE_ITHREADS) || ! defined(HAS_MBTOWC)) +# define USE_MBRTOWC #else - RETVAL = mbtowc(pwc, s, n); +# undef USE_MBRTOWC #endif + +int +mbtowc(pwc, s, n = ~0) + SV * pwc + SV * s + size_t n + CODE: + errno = 0; + SvGETMAGIC(s); + if (! SvOK(s)) { /* Initialize state */ +#ifdef USE_MBRTOWC + /* Initialize the shift state to all zeros in PL_mbrtowc_ps. */ + memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps)); + RETVAL = 0; +#else + LOCALE_LOCK; + RETVAL = mbtowc(NULL, NULL, 0); + LOCALE_UNLOCK; +#endif + } + else { /* Not resetting state */ + wchar_t wc; + SV * byte_s = sv_2mortal(newSVsv_nomg(s)); + if (! sv_utf8_downgrade_nomg(byte_s, TRUE)) { + SETERRNO(EINVAL, LIB_INVARG); + RETVAL = -1; + } + else { + size_t len; + char * string = SvPV(byte_s, len); + if (n < len) len = n; +#ifdef USE_MBRTOWC + RETVAL = (SSize_t) mbrtowc(&wc, string, len, &PL_mbrtowc_ps); +#else + /* Locking prevents races, but locales can be switched out + * without locking, so this isn't a cure all */ + LOCALE_LOCK; + RETVAL = mbtowc(&wc, string, len); + LOCALE_UNLOCK; +#endif + if (RETVAL >= 0) { + sv_setiv_mg(pwc, wc); + } + else { /* Use mbtowc() ret code for transparency */ + RETVAL = -1; + } + } + } OUTPUT: RETVAL +#if defined(HAS_WCRTOMB) && (defined(USE_ITHREADS) || ! defined(HAS_WCTOMB)) +# define USE_WCRTOMB +#else +# undef USE_WCRTOMB +#endif + int wctomb(s, wchar) - char * s + SV * s wchar_t wchar + CODE: + errno = 0; + SvGETMAGIC(s); + if (s == &PL_sv_undef) { +#ifdef USE_WCRTOMB + /* The man pages khw looked at are in agreement that this works. + * But probably memzero would too */ + RETVAL = wcrtomb(NULL, L'\0', &PL_wcrtomb_ps); +#else + LOCALE_LOCK; + RETVAL = wctomb(NULL, L'\0'); + LOCALE_UNLOCK; +#endif + } + else { /* Not resetting state */ + char buffer[MB_LEN_MAX]; +#ifdef USE_WCRTOMB + RETVAL = wcrtomb(buffer, wchar, &PL_wcrtomb_ps); +#else + /* Locking prevents races, but locales can be switched out without + * locking, so this isn't a cure all */ + LOCALE_LOCK; + RETVAL = wctomb(buffer, wchar); + LOCALE_UNLOCK; +#endif + if (RETVAL >= 0) { + sv_setpvn_mg(s, buffer, RETVAL); + } + } + OUTPUT: + RETVAL int strcoll(s1, s2) diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod index 9919f4c67f..2686457fa7 100644 --- a/ext/POSIX/lib/POSIX.pod +++ b/ext/POSIX/lib/POSIX.pod @@ -1098,9 +1098,35 @@ actual length of the first parameter string. =item C -This is identical to the C function C. +This is the same as the C function C on unthreaded perls. On +threaded perls, it transparently (almost) substitutes the more +thread-safe L(3)>, if available, instead of C. -See L. +Core Perl does not have any support for wide and multibyte locales, +except Unicode UTF-8 locales. This function, in conjunction with +L and L may be used to roll your own decoding/encoding +of other types of multi-byte locales. + +The first parameter is a scalar into which, upon success, the wide +character represented by the multi-byte string contained in the second +parameter is stored. The optional third parameter is ignored if it is +larger than the actual length of the second parameter string. + +Use C as the second parameter to this function to get the effect +of passing NULL as the second parameter to C. This resets any +shift state to its initial value. The return value is undefined if +C was substituted, so you should never rely on it. + +When the second parameter is a scalar containing a value that either is +a PV string or can be forced into one, the return value is the number of +bytes occupied by the first character of that string; or 0 if that first +character is the wide NUL character; or negative if there is an error. +This is based on the locale that currently underlies the program, +regardless of whether or not the function is called from Perl code that +is within the scope of S>. Perl makes no attempt at +hiding from your code any differences in the C setting between +C and C. It does set C to 0 before calling +them. =item C @@ -2131,9 +2157,30 @@ See L. =item C -This is identical to the C function C. +This is the same as the C function C on unthreaded perls. On +threaded perls, it transparently (almost) substitutes the more +thread-safe L(3)>, if available, instead of C. -See L. +Core Perl does not have any support for wide and multibyte locales, +except Unicode UTF-8 locales. This function, in conjunction with +L and L may be used to roll your own decoding/encoding +of other types of multi-byte locales. + +Use C as the first parameter to this function to get the effect +of passing NULL as the first parameter to C. This resets any +shift state to its initial value. The return value is undefined if +C was substituted, so you should never rely on it. + +When the first parameter is a scalar, the code point contained in the +scalar second parameter is converted into a multi-byte string and stored +into the first parameter scalar. This is based on the locale that +currently underlies the program, regardless of whether or not the +function is called from Perl code that is within the scope of S>. The return value is the number of bytes stored; or negative +if the code point isn't representable in the current locale. Perl makes +no attempt at hiding from your code any differences in the C +setting between C and C. It does set C to 0 +before calling them. =item C diff --git a/ext/POSIX/t/mb.t b/ext/POSIX/t/mb.t index b8a887d8ce..fd3ee5c222 100644 --- a/ext/POSIX/t/mb.t +++ b/ext/POSIX/t/mb.t @@ -19,8 +19,9 @@ BEGIN { require 'test.pl'; } -plan tests => 6; +my $utf8_locale = find_utf8_ctype_locale(); +plan tests => 13; use POSIX qw(); @@ -33,7 +34,6 @@ SKIP: { skip("LC_CTYPE locale support not available", 4) unless locales_enabled('LC_CTYPE'); - my $utf8_locale = find_utf8_ctype_locale(); skip("no utf8 locale available", 4) unless $utf8_locale; local $ENV{LC_CTYPE} = $utf8_locale; @@ -69,3 +69,79 @@ SKIP: { -1, {}, 'mblen() returns -1 when input length is too short'); } } + +SKIP: { + skip("mbtowc() not present", 5) unless $Config{d_mbtowc}; + + my $wide; + + is(&POSIX::mbtowc($wide, "a"), 1, 'mbtowc() returns correct length on ASCII input'); + is($wide , ord "a", 'mbtowc() returns correct ordinal on ASCII input'); + + skip("LC_CTYPE locale support not available", 3) + unless locales_enabled('LC_CTYPE'); + + skip("no utf8 locale available", 3) unless $utf8_locale; + + local $ENV{LC_CTYPE} = $utf8_locale; + local $ENV{LC_ALL}; + delete $ENV{LC_ALL}; + local $ENV{PERL_UNICODE}; + delete $ENV{PERL_UNICODE}; + + SKIP: { + my ($major, $minor, $rest) = $Config{osvers} =~ / (\d+) \. (\d+) .* /x; + skip("mbtowc() broken (at least for c.utf8) on early HP-UX", 3) + if $Config{osname} eq 'hpux' + && $major < 11 || ($major == 11 && $minor < 31); + + fresh_perl_is( + 'use POSIX; &POSIX::mbtowc(undef, undef,0); my $wide; print &POSIX::mbtowc($wide, "' + . I8_to_native("\x{c3}\x{28}") + . '", 2)', + -1, {}, 'mbtowc() recognizes invalid multibyte characters'); + + fresh_perl_is( + 'use POSIX; &POSIX::mbtowc(undef,undef,0); + my $sigma = "\N{GREEK SMALL LETTER SIGMA}"; + utf8::encode($sigma); + my $wide; my $len = &POSIX::mbtowc($wide, $sigma, 2); + print "$len:$wide"', + "2:963", {}, 'mbtowc() works on UTF-8 characters'); + + fresh_perl_is( + 'use POSIX; &POSIX::mbtowc(undef,undef,0); + my $wide; print &POSIX::mbtowc($wide, "\N{GREEK SMALL LETTER SIGMA}", 1);', + -1, {}, 'mbtowc() returns -1 when input length is too short'); + } +} + +SKIP: { + skip("mbtowc or wctomb() not present", 2) unless $Config{d_mbtowc} && $Config{d_wctomb}; + + fresh_perl_is('use POSIX; &POSIX::wctomb(undef,0); my $string; my $len = &POSIX::wctomb($string, ord "A"); print "$len:$string"', + "1:A", {}, 'wctomb() works on ASCII input'); + + skip("LC_CTYPE locale support not available", 1) + unless locales_enabled('LC_CTYPE'); + + skip("no utf8 locale available", 1) unless $utf8_locale; + + local $ENV{LC_CTYPE} = $utf8_locale; + local $ENV{LC_ALL}; + delete $ENV{LC_ALL}; + local $ENV{PERL_UNICODE}; + delete $ENV{PERL_UNICODE}; + + SKIP: { + my ($major, $minor, $rest) = $Config{osvers} =~ / (\d+) \. (\d+) .* /x; + skip("wctomb() broken (at least for c.utf8) on early HP-UX", 1) + if $Config{osname} eq 'hpux' + && $major < 11 || ($major == 11 && $minor < 31); + + fresh_perl_is('use POSIX; &POSIX::wctomb(undef,0); my $string; my $len = &POSIX::wctomb($string, 0x100); print "$len:$string"', + "2:" . I8_to_native("\x{c4}\x{80}"), + {}, 'wctomb() works on UTF-8 characters'); + + } +} diff --git a/intrpvar.h b/intrpvar.h index 39bc99d898..64e581ab88 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -941,6 +941,12 @@ PERLVAR(I, Private_Use, SV *) #ifdef HAS_MBRLEN PERLVAR(I, mbrlen_ps, mbstate_t) #endif +#ifdef HAS_MBRTOWC +PERLVAR(I, mbrtowc_ps, mbstate_t) +#endif +#ifdef HAS_WCRTOMB +PERLVAR(I, wcrtomb_ps, mbstate_t) +#endif /* If you are adding a U8 or U16, check to see if there are 'Space' comments * above on where there are gaps which currently will be structure padding. */ diff --git a/locale.c b/locale.c index 787474b9a7..d68ef50e1b 100644 --- a/locale.c +++ b/locale.c @@ -3461,11 +3461,17 @@ Perl_init_i18nl10n(pTHX_ int printwarn) # endif # endif /* DEBUGGING */ - /* Initialize the per-thread mbrFOO() state variable. See POSIX.xs for - * why this particular incantation is used. */ + /* Initialize the per-thread mbrFOO() state variables. See POSIX.xs for + * why these particular incantations are used. */ #ifdef HAS_MBRLEN memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps)); #endif +#ifdef HAS_MBRTOWC + memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps)); +#endif +#ifdef HAS_WCTOMBR + wcrtomb(NULL, L'\0', &PL_wcrtomb_ps); +#endif /* Initialize the cache of the program's UTF-8ness for the always known * locales C and POSIX */ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index ac67d31000..dbdcc36834 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -54,26 +54,25 @@ patterns using the above syntaxes, as an alternative to C<\N{...}>. A comparison of the two methods is given in L. -=head2 The C function now works on shift state locales -and is thread-safe on C99 and above compilers; the length parameter is -now optional +=head2 The C, C, and C functions now +work on shift state locales and are thread-safe on C99 and above +compilers when executed on a platform that has locale thread-safety; the +length parameters are now optional. -This function is always executed under the current C language locale. +These functions are always executed under the current C language locale. (See L.) Most locales are stateless, but a few, notably the -very rarely encountered ISO 2022, maintain a state between calls to this -function. Previously the state was cleared on every call to this -function, but now the state is not reset unless the first parameter is -C. +very rarely encountered ISO 2022, maintain a state between calls to +these functions. Previously the state was cleared on every call, but +now the state is not reset unless the appropriate parameter is C. -On threaded perls, the C99 function L, -when available, is substituted for plain -C. -This makes this function thread-safe when executing on a locale +On threaded perls, the C99 functions L, L, and +L, when available, are substituted for the plain functions. +This makes these functions thread-safe when executing on a locale thread-safe platform. -The string length parameter is now optional; useful only if you wish to -restrict the length parsed in the source string to less than the actual -length. +The string length parameters in C and C are now optional; +useful only if you wish to restrict the length parsed in the source +string to less than the actual length. =head1 Security @@ -477,6 +476,19 @@ made: F no longer uses (and re-uses) the F directory under F. This may prevent spurious failures. [GH #17424] +=item * + +Various bugs in C were fixed. Potential races with +other threads are now avoided, and previously the returned wide +character could well be garbage. + +=item * + +Various bugs in C were fixed. Potential races with other +threads are now avoided, and previously it would segfault if the string +parameter was shared or hadn't been pre-allocated with a string of +sufficient length to hold the result. + =back =head1 Platform Support diff --git a/sv.c b/sv.c index 3c533b08d2..bcf2dead01 100644 --- a/sv.c +++ b/sv.c @@ -15691,6 +15691,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef HAS_MBRLEN PL_mbrlen_ps = proto_perl->Imbrlen_ps; #endif +#ifdef HAS_MBRTOWC + PL_mbrtowc_ps = proto_perl->Imbrtowc_ps; +#endif +#ifdef HAS_WCRTOMB + PL_wcrtomb_ps = proto_perl->Iwcrtomb_ps; +#endif PL_langinfo_buf = NULL; PL_langinfo_bufsize = 0; diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 195040af6c..7b38d5f2bf 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -201,6 +201,7 @@ Math::Random::MT::Perl Math::Random::Secure Math::TrulyRandom mbrlen(3) +mbrtowc(3) md5sum(1) Method::Signatures mmap(2) @@ -350,6 +351,7 @@ wait4(2) waitpid(2) waitpid(3) Want +wcrtomb(3) wget(1) Win32::Locale write(2)