This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fixup POSIX::mbtowc, wctomb
authorKarl Williamson <khw@cpan.org>
Sat, 4 Jan 2020 05:18:02 +0000 (22:18 -0700)
committerKarl Williamson <khw@cpan.org>
Thu, 20 Feb 2020 05:09:48 +0000 (22:09 -0700)
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
ext/POSIX/POSIX.xs
ext/POSIX/lib/POSIX.pod
ext/POSIX/t/mb.t
intrpvar.h
locale.c
pod/perldelta.pod
sv.c
t/porting/known_pod_issues.dat

index 3970f5a..ce6ec27 100644 (file)
 #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)
 #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 */
index 9ea285b..befab77 100644 (file)
@@ -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
 
+#if defined(HAS_MBRTOWC) && (defined(USE_ITHREADS) || ! defined(HAS_MBTOWC))
+#  define USE_MBRTOWC
+#else
+#  undef USE_MBRTOWC
+#endif
+
 int
-mbtowc(pwc, s, n)
-       wchar_t *       pwc
-       char *          s
+mbtowc(pwc, s, n = ~0)
+       SV *            pwc
+       SV *            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 */
+        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
-        RETVAL = mbtowc(pwc, s, n);
+                /* 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)
index 9919f4c..2686457 100644 (file)
@@ -1098,9 +1098,35 @@ actual length of the first parameter string.
 
 =item C<mbtowc>
 
-This is identical to the C function C<mbtowc()>.
+This is the same as the C function C<mbtowc()> on unthreaded perls.  On
+threaded perls, it transparently (almost) substitutes the more
+thread-safe L<C<mbrtowc>(3)>, if available, instead of C<mbtowc>.
 
-See L</mblen>.
+Core Perl does not have any support for wide and multibyte locales,
+except Unicode UTF-8 locales.  This function, in conjunction with
+L</mblen> and L</wctomb> 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<undef> as the second parameter to this function to get the effect
+of passing NULL as the second parameter to C<mbtowc>.  This resets any
+shift state to its initial value.  The return value is undefined if
+C<mbrtowc> 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<C<use locale>>.  Perl makes no attempt at
+hiding from your code any differences in the C<errno> setting between
+C<mbtowc> and C<mbrtowc>.  It does set C<errno> to 0 before calling
+them.
 
 =item C<memchr>
 
@@ -2131,9 +2157,30 @@ See L</mblen>.
 
 =item C<wctomb>
 
-This is identical to the C function C<wctomb()>.
+This is the same as the C function C<wctomb()> on unthreaded perls.  On
+threaded perls, it transparently (almost) substitutes the more
+thread-safe L<C<wcrtomb>(3)>, if available, instead of C<wctomb>.
 
-See L</mblen>.
+Core Perl does not have any support for wide and multibyte locales,
+except Unicode UTF-8 locales.  This function, in conjunction with
+L</mblen> and L</mbtowc> may be used to roll your own decoding/encoding
+of other types of multi-byte locales.
+
+Use C<undef> as the first parameter to this function to get the effect
+of passing NULL as the first parameter to C<wctomb>.  This resets any
+shift state to its initial value.  The return value is undefined if
+C<wcrtomb> 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<C<use
+locale>>.  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<errno>
+setting between C<wctomb> and C<wcrtomb>.  It does set C<errno> to 0
+before calling them.
 
 =item C<write>
 
index b8a887d..fd3ee5c 100644 (file)
@@ -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');
+
+  }
+}
index 39bc99d..64e581a 100644 (file)
@@ -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.  */
index 787474b..d68ef50 100644 (file)
--- 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 */
index ac67d31..dbdcc36 100644 (file)
@@ -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<perlunicode/Comparison of \N{...} and \p{name=...}>.
 
-=head2 The C<POSIX::mblen()> 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<POSIX::mblen()>, C<mbtowc>, and C<wctomb> 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<perllocale>.)  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<undef>.
-
-On threaded perls, the C99 function L<mbrlen(3)>,
-when available, is substituted for plain
-C<mblen>.
-This makes this function thread-safe when executing on a locale
+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<undef>.
+
+On threaded perls, the C99 functions L<mbrlen(3)>, L<mbrtowc(3)>, and
+L<wcrtomb(3)>, 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<mblen> and C<mbtowc> 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<t/run/switches.t> no longer uses (and re-uses) the F<tmpinplace/>
 directory under F<t/>.  This may prevent spurious failures. [GH #17424]
 
+=item *
+
+Various bugs in C<POSIX::mbtowc> 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<POSIX::wctomb> 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 3c533b0..bcf2dea 100644 (file)
--- 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;
index 195040a..7b38d5f 100644 (file)
@@ -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)