Update Devel-PPPort to version 3.46
authorNicolas R <atoomic@cpan.org>
Fri, 26 Apr 2019 22:49:12 +0000 (16:49 -0600)
committerNicolas R <atoomic@cpan.org>
Fri, 26 Apr 2019 23:07:19 +0000 (17:07 -0600)
Update dist/Devel-PPPort after recent work
from khw to provide UNICODE_REPLACEMENT

Note that 3.46 is also released to CPAN.

Porting/Maintainers.pl
dist/Devel-PPPort/Changes
dist/Devel-PPPort/Makefile.PL
dist/Devel-PPPort/PPPort_pm.PL
dist/Devel-PPPort/parts/inc/misc
dist/Devel-PPPort/parts/inc/uv
dist/Devel-PPPort/parts/ppptools.pl
dist/Devel-PPPort/t/uv.t
pod/perldelta.pod

index 7d48d0d..cee5897 100755 (executable)
@@ -339,7 +339,7 @@ use File::Glob qw(:case);
     },
 
     'Devel::PPPort' => {
-        'DISTRIBUTION' => 'ATOOMIC/Devel-PPPort-3.45.tar.gz',
+        'DISTRIBUTION' => 'ATOOMIC/Devel-PPPort-3.46.tar.gz',
         'FILES'        => q[dist/Devel-PPPort],
         'EXCLUDED'     => [
             'PPPort.pm',    # we use PPPort_pm.PL instead
index 3c2daa3..c853b1e 100644 (file)
@@ -24,6 +24,7 @@
    * Provide my_strnlen()
    * Provide utf8_to_uvchr_buf()
    * Replace utf8_to_uvchr() with a safer version
+   * Provide UNICODE_REPLACEMENT
 
 3.45 - 2019-03-19
 
index 8fc4db1..c74b1db 100644 (file)
@@ -135,6 +135,24 @@ POSTAMBLE
   return $post;
 }
 
+sub MY::dist_core
+{
+  package MY;
+  my $dist = shift->SUPER::dist_core(@_);
+
+  my $updated = '';
+  my @rules = split( m{^\s*$}m, $dist );
+  foreach my $rule ( @rules ) {
+    if ( $rule =~ m{^\s*^dist\s+:}m ) {
+        $rule .= qq[\t].q[$(NOECHO) $(ECHO) "Warning: Please check '__MAX_PERL__' value in PPPort_pm.PL"].qq[\n];
+    }
+    $updated .= $rule;
+  }
+
+  return $updated;
+}
+
+
 sub MY::c_o
 {
   package MY;
index 83a0b17..b866b19 100644 (file)
@@ -121,7 +121,7 @@ $data =~ s{^__UNSUPPORTED_API__(\s*?)^}
           {join "\n", @todo}gem;
 
 $data =~ s{__MIN_PERL__}{5.003}g;
-$data =~ s{__MAX_PERL__}{5.20}g;
+$data =~ s{__MAX_PERL__}{5.30}g;
 
 open FH, ">PPPort.pm" or die "PPPort.pm: $!\n";
 print FH $data;
@@ -551,7 +551,7 @@ package Devel::PPPort;
 use strict;
 use vars qw($VERSION $data);
 
-$VERSION = '3.45';
+$VERSION = '3.46';
 
 sub _init_data
 {
index e0c6974..3fcc45b 100644 (file)
@@ -513,6 +513,8 @@ __UNDEFINED__ C_ARRAY_END(a)                ((a) + C_ARRAY_LENGTH(a))
 __UNDEFINED__ LIKELY(x) (x)
 __UNDEFINED__ UNLIKELY(x) (x)
 
+__UNDEFINED__ UNICODE_REPLACEMENT  0xFFFD
+
 #ifndef MUTABLE_PTR
 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
 #  define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
@@ -576,7 +578,6 @@ OpSIBLING_tests()
        PREINIT:
                OP *x;
                OP *kid;
-               OP *middlekid;
                OP *lastkid;
                int count = 0;
                int failures = 0;
@@ -600,7 +601,6 @@ OpSIBLING_tests()
                        kid = OpSIBLING(kid);
                        lastkid = kid;
                }
-                middlekid = OpSIBLING(x);
 
                /* Should now have a sibling */
                if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
@@ -644,9 +644,6 @@ OpSIBLING_tests()
                        failures++; warn("Op should have had a sib after maybesibset");
                }
 
-                op_free(lastkid);
-                op_free(middlekid);
-                op_free(x);
                RETVAL = failures;
        OUTPUT:
                RETVAL
index 0df7658..9d8b02f 100644 (file)
 __UNDEFINED__
 my_strnlen
 SvUOK
+utf8_to_uvchr_buf
+
+=dontwarn
+
+_ppport_utf8_to_uvchr_buf_callee
+_ppport_MIN
 
 =implementation
 
+#define _ppport_MIN(a,b) (((a) <= (b)) ? (a) : (b))
+
 __UNDEFINED__  sv_setuv(sv, uv)                     \
                STMT_START {                         \
                  UV TeMpUv = uv;                    \
@@ -54,12 +62,10 @@ __UNDEFINED__  XPUSHu(u)       STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG;
 /* Don't use official version because it uses MIN, which may not be available */
 #undef UTF8_SAFE_SKIP
 
-__UNDEFINED__  UTF8_SAFE_SKIP(s, e)  (__ASSERT_((e) >= (s))                     \
-                                      ((e) - (s)) <= 0                          \
+__UNDEFINED__  UTF8_SAFE_SKIP(s, e)  (                                          \
+                                      ((((e) - (s)) <= 0)                       \
                                       ? 0                                       \
-                                      : (((e) - (s)) >= UTF8SKIP(s))            \
-                                         ? ((e) - (s))                          \
-                                         : UTF8SKIP(s))
+                                      : _ppport_MIN(((e) - (s)), UTF8SKIP(s))))
 #endif
 
 #if !defined(my_strnlen)
@@ -78,35 +84,213 @@ my_strnlen(const char *str, Size_t maxlen)
 
 #endif
 #endif
-#if defined(utf8n_to_uvchr)
 
-__UNDEFINED__  utf8_to_uvchr_buf(s,e,lp)  (__ASSERT_(e >= s)                \
-                       utf8n_to_uvchr((s), ((e)-(s)), (lp),                 \
-                                    (UTF8_ALLOW_ANYUV & ~UTF8_ALLOW_LONG)))
+#if { VERSION < 5.30.0 }
+        /* Versions prior to this accepted things that are now considered
+         * malformations, and didn't return -1 on error with warnings enabled
+         * */
+#  undef utf8_to_uvchr_buf
+#endif
 
-#elif defined(utf8_to_uv)
+/* This implementation brings modern, generally more restricted standards to
+ * utf8_to_uvchr_buf.  Some of these are security related, and clearly must
+ * be done.  But its arguable that the others need not, and hence should not.
+ * The reason they're here is that a module that intends to play with the
+ * latest perls shoud be able to work the same in all releases.  An example is
+ * that perl no longer accepts any UV for a code point, but limits them to
+ * IV_MAX or below.  This is for future internal use of the larger code points.
+ * If it turns out that some of these changes are breaking code that isn't
+ * intended to work with modern perls, the tighter restrictions could be
+ * relaxed.  khw thinks this is unlikely, but has been wrong in the past. */
+
+#ifndef utf8_to_uvchr_buf
+   /* Choose which underlying implementation to use.  At least one must be
+    * present or the perl is too early to handle this function */
+#  if defined(utf8n_to_uvchr) || defined(utf8_to_uv)
+#    if defined(utf8n_to_uvchr)   /* This is the preferred implementation */
+#      define _ppport_utf8_to_uvchr_buf_callee utf8n_to_uvchr
+#    else
+#      define _ppport_utf8_to_uvchr_buf_callee utf8_to_uv
+#    endif
+
+#  endif
+
+#ifdef _ppport_utf8_to_uvchr_buf_callee
+#  if { NEED utf8_to_uvchr_buf }
 
-__UNDEFINED__  utf8_to_uvchr_buf(s,e,lp)  (__ASSERT_(e >= s)                \
-                       utf8_to_uv((s), ((e)-(s)), (lp),                     \
-                                    (UTF8_ALLOW_ANYUV & ~UTF8_ALLOW_LONG)))
-#endif
+UV
+utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+{
+    UV ret;
+    STRLEN curlen;
+    bool overflows = 0;
+    const U8 *cur_s = s;
+    const bool do_warnings = ckWARN_d(WARN_UTF8);
+
+    if (send > s) {
+        curlen = send - s;
+    }
+    else {
+        assert(0);  /* Modern perls die under this circumstance */
+        curlen = 0;
+        if (! do_warnings) {    /* Handle empty here if no warnings needed */
+            if (retlen) *retlen = 0;
+            return UNICODE_REPLACEMENT;
+        }
+    }
+
+    /* The modern version allows anything that evaluates to a legal UV, but not
+     * overlongs nor an empty input */
+    ret = _ppport_utf8_to_uvchr_buf_callee(
+                s, curlen, retlen,   (UTF8_ALLOW_ANYUV
+                                  & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY)));
+
+    /* But actually, modern versions restrict the UV to being no more than what
+     * an IV can hold */
+    if (ret > PERL_INT_MAX) {
+        overflows = 1;
+    }
+
+#    if { VERSION < 5.26.0 }
+#      ifndef EBCDIC
+
+        /* There are bugs in versions earlier than this on non-EBCDIC platforms
+         * in which it did not detect all instances of overflow, which could be
+         * a security hole.  Also, earlier versions did not allow the overflow
+         * malformation under any circumstances, and modern ones do.  So we
+         * need to check here.  */
+
+    else if (curlen > 0 && *s >= 0xFE) {
+
+        /* If the main routine detected overflow, great; it returned 0.  But if the
+         * input's first byte indicates it could overflow, we need to verify.
+         * First, on a 32-bit machine the first byte being at least \xFE
+         * automatically is overflow */
+        if (sizeof(ret) < 8) {
+            overflows = 1;
+        }
+        else {
+            const U8 highest[] =    /* 2*63-1 */
+                        "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
+            const U8 *cur_h = highest;
+
+            for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
+                if (UNLIKELY(*cur_s == *cur_h)) {
+                    continue;
+                }
+
+                /* If this byte is larger than the corresponding highest UTF-8
+                * byte, the sequence overflows; otherwise the byte is less than
+                * (as we handled the equality case above), and so the sequence
+                * doesn't overflow */
+                overflows = *cur_s > *cur_h;
+                break;
+
+            }
+
+            /* Here, either we set the bool and broke out of the loop, or got
+             * to the end and all bytes are the same which indicates it doesn't
+             * overflow. */
+        }
+    }
+
+#      endif
+#    endif  /* < 5.26 */
+
+    if (UNLIKELY(overflows)) {
+        if (! do_warnings) {
+            if (retlen) {
+                *retlen = _ppport_MIN(*retlen, UTF8SKIP(s));
+                *retlen = _ppport_MIN(*retlen, curlen);
+            }
+            return UNICODE_REPLACEMENT;
+        }
+        else {
+
+            /* On versions that correctly detect overflow, but forbid it
+             * always, 0 will be returned, but also a warning will have been
+             * raised.  Don't repeat it */
+            if (ret != 0) {
+                /* We use the error message in use from 5.8-5.14 */
+                Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                    "Malformed UTF-8 character (overflow at 0x%" UVxf
+                    ", byte 0x%02x, after start byte 0x%02x)",
+                    ret, *cur_s, *s);
+            }
+            if (retlen) {
+                *retlen = (STRLEN) -1;
+            }
+            return 0;
+        }
+    }
+
+    /* If failed and warnings are off, to emulate the behavior of the real
+     * utf8_to_uvchr(), try again, allowing anything.  (Note a return of 0 is
+     * ok if the input was '\0') */
+    if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) {
+
+        /* If curlen is 0, we already handled the case where warnings are
+         * disabled, so this 'if' will be true, and we won't look at the
+         * contents of 's' */
+        if (do_warnings) {
+            *retlen = (STRLEN) -1;
+        }
+        else {
+            ret = _ppport_utf8_to_uvchr_buf_callee(
+                                            s, curlen, retlen, UTF8_ALLOW_ANY);
+            /* Override with the REPLACEMENT character, as that is what the
+             * modern version of this function returns */
+            ret = UNICODE_REPLACEMENT;
+
+#           if { VERSION < 5.16.0 }
+
+            /* Versions earlier than this don't necessarily return the proper
+             * length.  It should not extend past the end of string, nor past
+             * what the first byte indicates the length is, nor past the
+             * continuation characters */
+            if (retlen && *retlen >= 0) {
+                *retlen = _ppport_MIN(*retlen, curlen);
+                *retlen = _ppport_MIN(*retlen, UTF8SKIP(s));
+                unsigned int i = 1;
+                do {
+                    if (s[i] < 0x80 || s[i] > 0xBF) {
+                        *retlen = i;
+                        break;
+                    }
+                } while (++i < *retlen);
+            }
+
+#           endif
+
+        }
+    }
+
+    return ret;
+}
 
-#undef utf8_to_uvchr
+#  endif
+#endif
+#endif
 
-/* Always redefine this unsafe function so that it refuses to read past a NUL,
- * making it much less likely to read off the end of the buffer.  A NUL
- * indicates the start of the next character anyway.  If the input isn't
- * NUL-terminated, the function remains unsafe, as it always has been.
- */
+#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
+#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
+                        to read past a NUL, making it much less likely to read
+                        off the end of the buffer.  A NUL indicates the start
+                        of the next character anyway.  If the input isn't
+                        NUL-terminated, the function remains unsafe, as it
+                        always has been. */
 
 __UNDEFINED__  utf8_to_uvchr(s, lp)                                             \
     ((*(s) == '\0')                                                             \
     ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */        \
     : utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp)))
 
+#endif
+
 =xsinit
 
 #define NEED_my_strnlen
+#define NEED_utf8_to_uvchr_buf
 
 =xsubs
 
@@ -188,15 +372,18 @@ my_strnlen(s, max)
             RETVAL
 
 AV *
-utf8_to_uvchr_buf(s)
+utf8_to_uvchr_buf(s, adjustment)
         unsigned char *s
+        int adjustment
         PREINIT:
             AV *av;
             STRLEN len;
         CODE:
             av = newAV();
-            av_push(av, newSVuv(utf8_to_uvchr_buf(s, s + UTF8SKIP(s), &len)));
-            av_push(av, newSVuv(len));
+            av_push(av, newSVuv(utf8_to_uvchr_buf(s,
+                                                  s + UTF8SKIP(s) + adjustment,
+                                                  &len)));
+            av_push(av, newSViv((IV) len));
             RETVAL = av;
         OUTPUT:
                 RETVAL
@@ -210,12 +397,12 @@ utf8_to_uvchr(s)
         CODE:
             av = newAV();
             av_push(av, newSVuv(utf8_to_uvchr(s, &len)));
-            av_push(av, newSVuv(len));
+            av_push(av, newSViv((IV) len));
             RETVAL = av;
         OUTPUT:
                 RETVAL
 
-=tests plan => 21
+=tests plan => 52
 
 ok(&Devel::PPPort::sv_setuv(42), 42);
 ok(&Devel::PPPort::newSVuv(123), 123);
@@ -230,15 +417,113 @@ ok(&Devel::PPPort::XPUSHu(), 43);
 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
 ok(&Devel::PPPort::my_strnlen("abc\0def", 7), 3);
-my $ret = &Devel::PPPort::utf8_to_uvchr_buf("A");
+
+my $ret = &Devel::PPPort::utf8_to_uvchr("A");
 ok($ret->[0], ord("A"));
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0");
+
+$ret = &Devel::PPPort::utf8_to_uvchr("\0");
 ok($ret->[0], 0);
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr("A");
+
+$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
 ok($ret->[0], ord("A"));
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr("\0");
+
+$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
 ok($ret->[0], 0);
 ok($ret->[1], 1);
+
+if (ord("A") != 65) {   # tests not valid for EBCDIC
+    ok(1, 1) for 1 .. (2 + 4 + (5 * 5));
+}
+else {
+    $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
+    ok($ret->[0], 0x100);
+    ok($ret->[1], 2);
+
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_; };
+
+    {
+        use warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
+        ok($ret->[0], 0);
+        ok($ret->[1], -1);
+
+        no warnings;
+        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
+        ok($ret->[0], 0xFFFD);
+        ok($ret->[1], 1);
+    }
+
+    my @buf_tests = (
+        {
+            input      => "A",
+            adjustment => -1,
+            warning    => qr/empty/,
+            no_warnings_returned_length => 0,
+        },
+        {
+            input      => "\xc4\xc5",
+            adjustment => 0,
+            warning    => qr/non-continuation/,
+            no_warnings_returned_length => 1,
+        },
+        {
+            input      => "\xc4\x80",
+            adjustment => -1,
+            warning    => qr/short|1 byte, need 2/,
+            no_warnings_returned_length => 1,
+        },
+        {
+            input      => "\xc0\x81",
+            adjustment => 0,
+            warning    => qr/overlong|2 bytes, need 1/,
+            no_warnings_returned_length => 2,
+        },
+        {                 # Old algorithm supposedly failed to detect this
+            input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
+            adjustment => 0,
+            warning    => qr/overflow/,
+            no_warnings_returned_length => 13,
+        },
+    );
+
+    # An empty input is an assertion failure on debugging builds.  It is
+    # deliberately the first test.
+    require Config; import Config;
+    use vars '%Config';
+    if ($Config{ccflags} =~ /-DDEBUGGING/) {
+        shift @buf_tests;
+        ok(1, 1) for 1..5;
+    }
+
+    for my $test (@buf_tests) {
+        my $input = $test->{'input'};
+        my $adjustment = $test->{'adjustment'};
+        my $display = 'utf8_to_uvchr_buf("';
+        for (my $i = 0; $i < length($input) + $adjustment; $i++) {
+            $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
+        }
+
+        $display .= '")';
+        my $warning = $test->{'warning'};
+
+        undef @warnings;
+        use warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
+        ok($ret->[0], 0,  "returned value $display; warnings enabled");
+        ok($ret->[1], -1, "returned length $display; warnings enabled");
+        my $all_warnings = join "; ", @warnings;
+        my $contains = grep { $_ =~ $warning } $all_warnings;
+        ok($contains, 1, $display . "; '$all_warnings' contains '$warning'");
+
+        undef @warnings;
+        no warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
+        ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
+        ok($ret->[1], $test->{'no_warnings_returned_length'},
+                      "returned length $display; warnings disabled");
+    }
+}
index 6981b1b..e84f646 100644 (file)
@@ -380,7 +380,7 @@ sub parse_version
   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
     return ($1, $2, $3);
   }
-  elsif ($ver !~ /^\d+\.[\d_]+$/) {
+  elsif ($ver !~ /^\d+\.\d{3}(?:_\d{2})?$/) {
     die "cannot parse version '$ver'\n";
   }
 
index 3da70ce..7f5d78b 100644 (file)
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (21) {
+  if (52) {
     load();
-    plan(tests => 21);
+    plan(tests => 52);
   }
 }
 
@@ -61,16 +61,114 @@ ok(&Devel::PPPort::XPUSHu(), 43);
 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
 ok(&Devel::PPPort::my_strnlen("abc\0def", 7), 3);
-my $ret = &Devel::PPPort::utf8_to_uvchr_buf("A");
+
+my $ret = &Devel::PPPort::utf8_to_uvchr("A");
 ok($ret->[0], ord("A"));
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0");
+
+$ret = &Devel::PPPort::utf8_to_uvchr("\0");
 ok($ret->[0], 0);
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr("A");
+
+$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
 ok($ret->[0], ord("A"));
 ok($ret->[1], 1);
-$ret = &Devel::PPPort::utf8_to_uvchr("\0");
+
+$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
 ok($ret->[0], 0);
 ok($ret->[1], 1);
 
+if (ord("A") != 65) {   # tests not valid for EBCDIC
+    ok(1, 1) for 1 .. (2 + 4 + (5 * 5));
+}
+else {
+    $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
+    ok($ret->[0], 0x100);
+    ok($ret->[1], 2);
+
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_; };
+
+    {
+        use warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
+        ok($ret->[0], 0);
+        ok($ret->[1], -1);
+
+        no warnings;
+        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
+        ok($ret->[0], 0xFFFD);
+        ok($ret->[1], 1);
+    }
+
+    my @buf_tests = (
+        {
+            input      => "A",
+            adjustment => -1,
+            warning    => qr/empty/,
+            no_warnings_returned_length => 0,
+        },
+        {
+            input      => "\xc4\xc5",
+            adjustment => 0,
+            warning    => qr/non-continuation/,
+            no_warnings_returned_length => 1,
+        },
+        {
+            input      => "\xc4\x80",
+            adjustment => -1,
+            warning    => qr/short|1 byte, need 2/,
+            no_warnings_returned_length => 1,
+        },
+        {
+            input      => "\xc0\x81",
+            adjustment => 0,
+            warning    => qr/overlong|2 bytes, need 1/,
+            no_warnings_returned_length => 2,
+        },
+        {                 # Old algorithm supposedly failed to detect this
+            input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
+            adjustment => 0,
+            warning    => qr/overflow/,
+            no_warnings_returned_length => 13,
+        },
+    );
+
+    # An empty input is an assertion failure on debugging builds.  It is
+    # deliberately the first test.
+    require Config; import Config;
+    use vars '%Config';
+    if ($Config{ccflags} =~ /-DDEBUGGING/) {
+        shift @buf_tests;
+        ok(1, 1) for 1..5;
+    }
+
+    for my $test (@buf_tests) {
+        my $input = $test->{'input'};
+        my $adjustment = $test->{'adjustment'};
+        my $display = 'utf8_to_uvchr_buf("';
+        for (my $i = 0; $i < length($input) + $adjustment; $i++) {
+            $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
+        }
+
+        $display .= '")';
+        my $warning = $test->{'warning'};
+
+        undef @warnings;
+        use warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
+        ok($ret->[0], 0,  "returned value $display; warnings enabled");
+        ok($ret->[1], -1, "returned length $display; warnings enabled");
+        my $all_warnings = join "; ", @warnings;
+        my $contains = grep { $_ =~ $warning } $all_warnings;
+        ok($contains, 1, $display . "; '$all_warnings' contains '$warning'");
+
+        undef @warnings;
+        no warnings 'utf8';
+        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
+        ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
+        ok($ret->[1], $test->{'no_warnings_returned_length'},
+                      "returned length $display; warnings disabled");
+    }
+}
+
index 40a5961..aa3caa8 100644 (file)
@@ -133,6 +133,8 @@ If there was something important to note about this change, include that here.
 
 L<Module::CoreList> has been upgraded from version 5.20190420 to 5.20190520.
 
+L<Devel::PPPort> has been upgraded from version 3.45 to 3.46.
+
 =back
 
 =head2 Removed Modules and Pragmata