This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Scalar-List-Utils from version 1.52 to 1.53
authorSteve Hay <steve.m.hay@googlemail.com>
Mon, 28 Oct 2019 13:14:36 +0000 (13:14 +0000)
committerSteve Hay <steve.m.hay@googlemail.com>
Mon, 28 Oct 2019 13:14:36 +0000 (13:14 +0000)
Porting/Maintainers.pl
cpan/Scalar-List-Utils/ListUtil.xs
cpan/Scalar-List-Utils/lib/List/Util.pm
cpan/Scalar-List-Utils/lib/List/Util/XS.pm
cpan/Scalar-List-Utils/lib/Scalar/Util.pm
cpan/Scalar-List-Utils/lib/Sub/Util.pm
cpan/Scalar-List-Utils/t/blessed.t

index ddc2421..cd4567b 100755 (executable)
@@ -957,7 +957,7 @@ use File::Glob qw(:case);
     },
 
     'Scalar::Util' => {
-        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.52.tar.gz',
+        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.53.tar.gz',
         'FILES'        => q[cpan/Scalar-List-Utils],
     },
 
index 5998fe6..b0d98b4 100644 (file)
@@ -124,6 +124,38 @@ my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
 #  define SvNV_nomg SvNV
 #endif
 
+#if PERL_VERSION_GE(5,16,0)
+#  define HAVE_UNICODE_PACKAGE_NAMES
+
+#  ifndef sv_sethek
+#    define sv_sethek(a, b)  Perl_sv_sethek(aTHX_ a, b)
+#  endif
+
+#  ifndef sv_ref
+#  define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob)
+static SV *
+my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob)
+{
+  /* cargoculted from perl 5.22's sv.c */
+  if(!dst)
+    dst = sv_newmortal();
+
+  if(ob && SvOBJECT(sv)) {
+    if(HvNAME_get(SvSTASH(sv)))
+      sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
+    else
+      sv_setpvs(dst, "__ANON__");
+  }
+  else {
+    const char *reftype = sv_reftype(sv, 0);
+    sv_setpv(dst, reftype);
+  }
+
+  return dst;
+}
+#  endif
+#endif /* HAVE_UNICODE_PACKAGE_NAMES */
+
 enum slu_accum {
     ACC_IV,
     ACC_NV,
@@ -344,9 +376,9 @@ CODE:
                 /* else fallthrough */
             }
 
-            /* fallthrough to NV now */
             retnv = retiv;
             accum = ACC_NV;
+            /* FALLTHROUGH */
         case ACC_NV:
             is_product ? (retnv *= slu_sv_value(sv))
                        : (retnv += slu_sv_value(sv));
@@ -1310,7 +1342,7 @@ CODE:
     ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
     XSRETURN(1);
 
-char *
+SV *
 blessed(sv)
     SV *sv
 PROTOTYPE: $
@@ -1320,8 +1352,12 @@ CODE:
 
     if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
         XSRETURN_UNDEF;
-
-    RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
+#ifdef HAVE_UNICODE_PACKAGE_NAMES
+    RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE));
+#else
+    RETVAL = newSV(0);
+    sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE));
+#endif
 }
 OUTPUT:
     RETVAL
index 9d6f04f..e1b66c6 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK  = qw(
   all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
   head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
 );
-our $VERSION    = "1.52";
+our $VERSION    = "1.53";
 our $XS_VERSION = $VERSION;
 $VERSION =~ tr/_//d;
 
index b309554..4a7301c 100644 (file)
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use List::Util;
 
-our $VERSION = "1.52";       # FIXUP
+our $VERSION = "1.53";       # FIXUP
 $VERSION =~ tr/_//d;         # FIXUP
 
 1;
index c0952bc..bf670c9 100644 (file)
@@ -17,7 +17,7 @@ our @EXPORT_OK = qw(
   dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
   tainted
 );
-our $VERSION    = "1.52";
+our $VERSION    = "1.53";
 $VERSION =~ tr/_//d;
 
 require List::Util; # List::Util loads the XS
index d50cc8e..580bd8d 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK = qw(
   subname set_subname
 );
 
-our $VERSION    = "1.52";
+our $VERSION    = "1.53";
 $VERSION =~ tr/_//d;
 
 require List::Util; # as it has the XS
index 21d3a9a..2ae3679 100644 (file)
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 11;
+use Test::More tests => 12;
 use Scalar::Util qw(blessed);
 
 my $t;
@@ -46,3 +46,11 @@ cmp_ok(blessed($x), "eq", "0",       'blessed HASH-ref');
   ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" );
 }
 
+SKIP: {
+  # Unicode package names only supported in perl 5.16 onwards
+  skip "Unicode package names are not supported", 1 if $] < 5.016;
+
+  my $utf8_pack= "X\x{100}";
+  my $obj= bless {}, $utf8_pack;
+  ::is( ::blessed($obj), $utf8_pack, "blessed preserves utf8ness for utf8 class names" );
+}