This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Scalar::Util from version 1.49 to 1.50
authorTodd Rinaldo <toddr@cpan.org>
Sun, 18 Mar 2018 22:08:04 +0000 (17:08 -0500)
committerTodd Rinaldo <toddr@cpan.org>
Sun, 18 Mar 2018 22:08:04 +0000 (17:08 -0500)
[DELTA]

1.50 -- 2018-02-20 19:13:27
[CHANGES]
* Added head() and tail() functions (thanks preaction)
* Support binary and Unicode in symbol names for set_subname()

[BUGFIXES]
* Fix building with C++ and C89 compilers
* Fix uniq() test for old Test::More
* Fix example get_code_info for unnamed subs (RT#116962)
* Fixes for symbol names containing ' characters
* Don't leak SVs from sum0/product1 when called with zero args (RT#124017)
* Use sv_rvunweaken() in Scalar::Util::unweaken() (thanks ilmari)
* Misc. fixes for perl 5.6

13 files changed:
MANIFEST
Porting/Maintainers.pl
cpan/Scalar-List-Utils/ListUtil.xs
cpan/Scalar-List-Utils/Makefile.PL
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/exotic_names.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/head-tail.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/product.t
cpan/Scalar-List-Utils/t/sum.t
cpan/Scalar-List-Utils/t/uniq.t

index 8493227..819daf0 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1988,8 +1988,10 @@ cpan/Scalar-List-Utils/t/00version.t             Scalar::Util
 cpan/Scalar-List-Utils/t/any-all.t             List::Util
 cpan/Scalar-List-Utils/t/blessed.t             Scalar::Util
 cpan/Scalar-List-Utils/t/dualvar.t             Scalar::Util
+cpan/Scalar-List-Utils/t/exotic_names.t
 cpan/Scalar-List-Utils/t/first.t               List::Util
 cpan/Scalar-List-Utils/t/getmagic-once.t
+cpan/Scalar-List-Utils/t/head-tail.t
 cpan/Scalar-List-Utils/t/isvstring.t           Scalar::Util
 cpan/Scalar-List-Utils/t/lln.t                 Scalar::Util
 cpan/Scalar-List-Utils/t/max.t                 List::Util
index 8898378..f15c28c 100755 (executable)
@@ -984,8 +984,8 @@ use File::Glob qw(:case);
         'FILES'        => q[dist/Safe],
     },
 
-    'Scalar-List-Utils' => {
-        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.49.tar.gz',
+    'Scalar::Util' => {
+        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.50.tar.gz',
         'FILES'        => q[cpan/Scalar-List-Utils],
     },
 
index 2369919..12f98cd 100644 (file)
@@ -10,6 +10,7 @@
 #ifdef USE_PPPORT_H
 #  define NEED_sv_2pv_flags 1
 #  define NEED_newSVpvn_flags 1
+#  define NEED_sv_catpvn_flags
 #  include "ppport.h"
 #endif
 
 #  define CvISXSUB(cv) CvXSUB(cv)
 #endif
 
+#ifndef HvNAMELEN_get
+#define HvNAMELEN_get(stash) strlen(HvNAME(stash))
+#endif
+
+#ifndef HvNAMEUTF8
+#define HvNAMEUTF8(stash) 0
+#endif
+
+#ifndef GvNAMEUTF8
+#ifdef GvNAME_HEK
+#define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
+#else
+#define GvNAMEUTF8(gv) 0
+#endif
+#endif
+
+#ifndef SV_CATUTF8
+#define SV_CATUTF8 0
+#endif
+
+#ifndef SV_CATBYTES
+#define SV_CATBYTES 0
+#endif
+
+#ifndef sv_catpvn_flags
+#define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
+#endif
+
 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
    was not exported. Therefore platforms like win32, VMS etc have problems
    so we redefine it here -- GMB
@@ -190,8 +219,8 @@ CODE:
     if(!items)
         switch(ix) {
             case 0: XSRETURN_UNDEF;
-            case 1: ST(0) = newSViv(0); XSRETURN(1);
-            case 2: ST(0) = newSViv(1); XSRETURN(1);
+            case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1);
+            case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1);
         }
 
     sv    = ST(0);
@@ -585,6 +614,56 @@ PPCODE:
 }
 
 void
+head(size,...)
+PROTOTYPE: $@
+ALIAS:
+    head = 0
+    tail = 1
+PPCODE:
+{
+    int size = 0;
+    int start = 0;
+    int end = 0;
+    int i = 0;
+
+    size = SvIV( ST(0) );
+
+    if ( ix == 0 ) {
+        start = 1;
+        end = start + size;
+        if ( size < 0 ) {
+            end += items - 1;
+        }
+        if ( end > items ) {
+            end = items;
+        }
+    }
+    else {
+        end = items;
+        if ( size < 0 ) {
+            start = -size + 1;
+        }
+        else {
+            start = end - size;
+        }
+        if ( start < 1 ) {
+            start = 1;
+        }
+    }
+
+    if ( end < start ) {
+        XSRETURN(0);
+    }
+    else {
+        EXTEND( SP, end - start );
+        for ( i = start; i <= end; i++ ) {
+            PUSHs( sv_2mortal( newSVsv( ST(i) ) ) );
+        }
+        XSRETURN( end - start );
+    }
+}
+
+void
 pairs(...)
 PROTOTYPE: @
 PPCODE:
@@ -1114,7 +1193,7 @@ CODE:
             if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
                 continue;
 
-            hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_undef, 0);
+            hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
 #endif
 
             if(GIMME_V == G_ARRAY)
@@ -1158,7 +1237,7 @@ CODE:
             if (hv_exists_ent(seen, arg, 0))
                 continue;
 
-            hv_store_ent(seen, arg, &PL_sv_undef, 0);
+            hv_store_ent(seen, arg, &PL_sv_yes, 0);
 #endif
 
             if(GIMME_V == G_ARRAY)
@@ -1287,7 +1366,10 @@ PROTOTYPE: $
 INIT:
     SV *tsv;
 CODE:
-#ifdef SvWEAKREF
+#if defined(sv_rvunweaken)
+    PERL_UNUSED_VAR(tsv);
+    sv_rvunweaken(sv);
+#elif defined(SvWEAKREF)
     /* This code stolen from core's sv_rvweaken() and modified */
     if (!SvOK(sv))
         return;
@@ -1445,14 +1527,19 @@ PPCODE:
 
 void
 set_subname(name, sub)
-    char *name
+    SV *name
     SV *sub
 PREINIT:
     CV *cv = NULL;
     GV *gv;
     HV *stash = CopSTASH(PL_curcop);
-    char *s, *end = NULL;
+    const char *s, *end = NULL, *begin = NULL;
     MAGIC *mg;
+    STRLEN namelen;
+    const char* nameptr = SvPV(name, namelen);
+    int utf8flag = SvUTF8(name);
+    int quotes_seen = 0;
+    bool need_subst = FALSE;
 PPCODE:
     if (!SvROK(sub) && SvGMAGICAL(sub))
         mg_get(sub);
@@ -1465,63 +1552,77 @@ PPCODE:
     else if (PL_op->op_private & HINT_STRICT_REFS)
         croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
               SvPV_nolen(sub), "a subroutine");
-    else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
+    else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
         cv = GvCVu(gv);
     if (!cv)
         croak("Undefined subroutine %s", SvPV_nolen(sub));
     if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
         croak("Not a subroutine reference");
-    for (s = name; *s++; ) {
-        if (*s == ':' && s[-1] == ':')
-            end = ++s;
-        else if (*s && s[-1] == '\'')
-            end = s;
+    for (s = nameptr; s <= nameptr + namelen; s++) {
+        if (s > nameptr && *s == ':' && s[-1] == ':') {
+            end = s - 1;
+            begin = ++s;
+            if (quotes_seen)
+                need_subst = TRUE;
+        }
+        else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
+            end = s - 1;
+            begin = s;
+            if (quotes_seen++)
+                need_subst = TRUE;
+        }
     }
     s--;
     if (end) {
-        char *namepv = savepvn(name, end - name);
-        stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
-        Safefree(namepv);
-        name = end;
+        SV* tmp;
+        if (need_subst) {
+            STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0);
+            char* left;
+            int i, j;
+            tmp = sv_2mortal(newSV(length));
+            left = SvPVX(tmp);
+            for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
+                if (nameptr[j] == '\'') {
+                    left[i] = ':';
+                    left[++i] = ':';
+                }
+                else {
+                    left[i] = nameptr[j];
+                }
+            }
+            stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
+        }
+        else
+            stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
+        nameptr = begin;
+        namelen -= begin - nameptr;
     }
 
     /* under debugger, provide information about sub location */
     if (PL_DBsub && CvGV(cv)) {
-        HV *hv = GvHV(PL_DBsub);
-
-        char *new_pkg = HvNAME(stash);
-
-        char *old_name = GvNAME( CvGV(cv) );
-        char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
-
-        int old_len = strlen(old_name) + strlen(old_pkg);
-        int new_len = strlen(name) + strlen(new_pkg);
-
-        SV **old_data;
-        char *full_name;
-
-        Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
-
-        strcat(full_name, old_pkg);
-        strcat(full_name, "::");
-        strcat(full_name, old_name);
-
-        old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
-
-        if (old_data) {
-            strcpy(full_name, new_pkg);
-            strcat(full_name, "::");
-            strcat(full_name, name);
-
-            SvREFCNT_inc(*old_data);
-            if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
-                SvREFCNT_dec(*old_data);
+        HV* DBsub = GvHV(PL_DBsub);
+        HE* old_data;
+
+        GV* oldgv = CvGV(cv);
+        HV* oldhv = GvSTASH(oldgv);
+        SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0));
+        sv_catpvn(old_full_name, "::", 2);
+        sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
+
+        old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
+
+        if (old_data && HeVAL(old_data)) {
+            SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
+            sv_catpvn(new_full_name, "::", 2);
+            sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
+            SvREFCNT_inc(HeVAL(old_data));
+            if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL)
+                SvREFCNT_inc(HeVAL(old_data));
         }
-        Safefree(full_name);
     }
 
     gv = (GV *) newSV(0);
-    gv_init(gv, stash, name, s - name, TRUE);
+    gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 
     /*
      * set_subname needs to create a GV to store the name. The CvGV field of a
index 035f67f..b650d35 100644 (file)
@@ -13,9 +13,9 @@ require Exporter;
 our @ISA        = qw(Exporter);
 our @EXPORT_OK  = qw(
   all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
-  pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
+  head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
 );
-our $VERSION    = "1.49";
+our $VERSION    = "1.50";
 our $XS_VERSION = $VERSION;
 $VERSION    = eval $VERSION;
 
@@ -553,6 +553,32 @@ entire list of values returned by C<uniqstr> are well-behaved as strings.
 
 =cut
 
+=head2 head
+
+    my @values = head $size, @list;
+
+Returns the first C<$size> elements from C<@list>. If C<$size> is negative, returns
+all but the last C<$size> elements from C<@list>.
+
+    @result = head 2, qw( foo bar baz );
+    # foo, bar
+
+    @result = head -2, qw( foo bar baz );
+    # foo
+
+=head2 tail
+
+    my @values = tail $size, @list;
+
+Returns the last C<$size> elements from C<@list>. If C<$size> is negative, returns
+all but the first C<$size> elements from C<@list>.
+
+    @result = tail 2, qw( foo bar baz );
+    # bar, baz
+
+    @result = tail -2, qw( foo bar baz );
+    # baz
+
 =head1 KNOWN BUGS
 
 =head2 RT #95409
index 10429a7..c8c066f 100644 (file)
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use List::Util;
 
-our $VERSION = "1.49";       # FIXUP
+our $VERSION = "1.50";       # FIXUP
 $VERSION = eval $VERSION;    # FIXUP
 
 1;
index 00edd3b..6982158 100644 (file)
@@ -17,7 +17,7 @@ our @EXPORT_OK = qw(
   dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
   tainted
 );
-our $VERSION    = "1.49";
+our $VERSION    = "1.50";
 $VERSION   = eval $VERSION;
 
 require List::Util; # List::Util loads the XS
index ecfab70..edcc654 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK = qw(
   subname set_subname
 );
 
-our $VERSION    = "1.49";
+our $VERSION    = "1.50";
 $VERSION   = eval $VERSION;
 
 require List::Util; # as it has the XS
@@ -102,7 +102,7 @@ This function was inspired by C<sub_fullname> from L<Sub::Identify>. The
 remaining functions that C<Sub::Identify> implements can easily be emulated
 using regexp operations, such as
 
- sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.+?)$/ }
+ sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.*?)$/ }
  sub sub_name      { return (get_code_info $_[0])[0] }
  sub stash_name    { return (get_code_info $_[0])[1] }
 
diff --git a/cpan/Scalar-List-Utils/t/exotic_names.t b/cpan/Scalar-List-Utils/t/exotic_names.t
new file mode 100644 (file)
index 0000000..cb5d2cc
--- /dev/null
@@ -0,0 +1,122 @@
+use strict;
+use warnings;
+
+use Test::More;
+use B 'svref_2object';
+BEGIN { $^P |= 0x210 }
+
+# This is a mess. The stash can supposedly handle Unicode but the behavior
+# is literally undefined before 5.16 (with crashes beyond the basic plane),
+# and remains unclear past 5.16 with evalbytes and feature unicode_eval
+# In any case - Sub::Name needs to *somehow* work with this, so we will do
+# a heuristic with ambiguous eval and looking for octets in the stash
+use if $] >= 5.016, feature => 'unicode_eval';
+
+if ($] >= 5.008) {
+       my $builder = Test::More->builder;
+       binmode $builder->output,         ":encoding(utf8)";
+       binmode $builder->failure_output, ":encoding(utf8)";
+       binmode $builder->todo_output,    ":encoding(utf8)";
+}
+
+sub compile_named_sub {
+    my ( $fullname, $body ) = @_;
+    my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
+    return $sub if $sub;
+    my $e = $@;
+    require Carp;
+    Carp::croak $e;
+}
+
+sub caller3_ok {
+    my ( $sub, $expected, $type, $ord ) = @_;
+
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    my $for_what = sprintf "when it contains \\x%s ( %s )", (
+        ( ($ord > 255)
+            ? sprintf "{%X}", $ord
+            : sprintf "%02X", $ord
+        ),
+        (
+            $ord > 255                    ? unpack('H*', pack 'C0U', $ord )
+            : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord
+            :                                 sprintf '\%o', $ord
+        ),
+    );
+
+    $expected =~ s/'/::/g;
+
+    # this is apparently how things worked before 5.16
+    utf8::encode($expected) if $] < 5.016 and $ord > 255;
+
+    my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
+
+    is $stash_name, $expected, "stash name for $type is correct $for_what";
+    is $sub->(), $expected, "caller() in $type returns correct name $for_what";
+    SKIP: {
+      skip '%DB::sub not populated when enabled at runtime', 1
+        unless keys %DB::sub;
+      my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/;
+      my ($db_found) = grep /^$prefix/, keys %DB::sub;
+      is $db_found, $expected, "%DB::sub entry for $type is correct $for_what";
+    }
+}
+
+#######################################################################
+
+use Sub::Util 'set_subname';
+
+my @ordinal = ( 1 .. 255 );
+
+# 5.14 is the first perl to start properly handling \0 in identifiers
+unshift @ordinal, 0
+    unless $] < 5.014;
+
+# Unicode in 5.6 is not sane (crashes etc)
+push @ordinal,
+    0x100,    # LATIN CAPITAL LETTER A WITH MACRON
+    0x498,    # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
+    0x2122,   # TRADE MARK SIGN
+    0x1f4a9,  # PILE OF POO
+    unless $] < 5.008;
+
+plan tests => @ordinal * 2 * 3;
+
+my $legal_ident_char = "A-Z_a-z0-9'";
+$legal_ident_char .= join '', map chr, 0x100, 0x498
+    unless $] < 5.008;
+
+my $uniq = 'A000';
+for my $ord (@ordinal) {
+    my $sub;
+    $uniq++;
+    my $pkg      = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
+    my $subname  = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
+    my $fullname = join '::', $pkg, $subname;
+
+    $sub = set_subname $fullname => sub { (caller(0))[3] };
+    caller3_ok $sub, $fullname, 'renamed closure', $ord;
+
+    # test that we can *always* compile at least within the correct package
+    my $expected;
+    if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
+        $expected = "native::$fullname";
+        $sub = compile_named_sub $expected => '(caller(0))[3]';
+    }
+    else { # not a legal identifier but at least test the package name by aliasing
+        $expected = "aliased::native::$fullname";
+        {
+          no strict 'refs';
+          *palatable:: = *{"aliased::native::${pkg}::"};
+          # now palatable:: literally means aliased::native::${pkg}::
+          my $encoded_sub = $subname;
+          utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
+          ${"palatable::$encoded_sub"} = 1;
+          ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
+          # and palatable::sub means aliased::native::${pkg}::${subname}
+        }
+        $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
+    }
+    caller3_ok $sub, $expected, 'natively compiled sub', $ord;
+}
diff --git a/cpan/Scalar-List-Utils/t/head-tail.t b/cpan/Scalar-List-Utils/t/head-tail.t
new file mode 100644 (file)
index 0000000..9477275
--- /dev/null
@@ -0,0 +1,97 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use List::Util qw(head tail);
+use Test::More;
+plan tests => 42;
+
+my @ary;
+
+ok(defined &head, 'defined');
+ok(defined &tail, 'defined');
+
+@ary = head 1, ( 4, 5, 6 );
+is( scalar @ary, 1 );
+is( $ary[0], 4 );
+
+@ary = head 2, ( 4, 5, 6 );
+is( scalar @ary, 2 );
+is( $ary[0], 4 );
+is( $ary[1], 5 );
+
+@ary = head -1, ( 4, 5, 6 );
+is( scalar @ary, 2 );
+is( $ary[0], 4 );
+is( $ary[1], 5 );
+
+@ary = head -2, ( 4, 5, 6 );
+is( scalar @ary, 1 );
+is( $ary[0], 4 );
+
+@ary = head 999, ( 4, 5, 6 );
+is( scalar @ary, 3 );
+is( $ary[0], 4 );
+is( $ary[1], 5 );
+is( $ary[2], 6 );
+
+@ary = head 0, ( 4, 5, 6 );
+is( scalar @ary, 0 );
+
+@ary = head 0;
+is( scalar @ary, 0 );
+
+@ary = head 5;
+is( scalar @ary, 0 );
+
+@ary = head -3, ( 4, 5, 6 );
+is( scalar @ary, 0 );
+
+@ary = head -999, ( 4, 5, 6 );
+is( scalar @ary, 0 );
+
+eval '@ary = head';
+like( $@, qr{^Not enough arguments for List::Util::head} );
+
+@ary = head 4, ( 4, 5, 6 );
+is( scalar @ary, 3 );
+is( $ary[0], 4 );
+is( $ary[1], 5 );
+is( $ary[2], 6 );
+
+@ary = tail 1, ( 4, 5, 6 );
+is( scalar @ary, 1 );
+is( $ary[0], 6 );
+
+@ary = tail 2, ( 4, 5, 6 );
+is( scalar @ary, 2 );
+is( $ary[0], 5 );
+is( $ary[1], 6 );
+
+@ary = tail -1, ( 4, 5, 6 );
+is( scalar @ary, 2 );
+is( $ary[0], 5 );
+is( $ary[1], 6 );
+
+@ary = tail -2, ( 4, 5, 6 );
+is( scalar @ary, 1 );
+is( $ary[0], 6 );
+
+@ary = tail 0, ( 4, 5, 6 );
+is( scalar @ary, 0 );
+
+@ary = tail 0;
+is( scalar @ary, 0 );
+
+@ary = tail 5;
+is( scalar @ary, 0 );
+
+@ary = tail -3;
+is( scalar @ary, 0 );
+
+@ary = tail -999;
+is( scalar @ary, 0 );
+
+eval '@ary = tail';
+like( $@, qr{^Not enough arguments for List::Util::tail} );
index 7b5894a..87e887c 100644 (file)
@@ -113,11 +113,8 @@ SKIP: {
   $t = product($max, $min);
   is($t, (1<<31) - (1<<62), 'max * min');
 
-  SKIP: {
-  skip "known to fail on $]", 1 if $] le "5.006002";
   $t = product($max, $max);
-  is($t,  (1<<62)-(1<<32)+1, 'max * max');
-  }
+  is($t,  4611686014132420609, 'max * max'); # (1<<62)-(1<<32)+1), but Perl 5.6 does not compute constant correctly
 
   $t = product($min*8, $min);
   cmp_ok($t, '>',  (1<<61), 'min*8*min'); # may be an NV
index 1b7258c..e2c416d 100644 (file)
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 17;
+use Test::More tests => 18;
 
 use Config;
 use List::Util qw(sum);
@@ -91,15 +91,20 @@ is($v, $v1 + 42 + 2, 'bigint + builtin int');
 }
 
 SKIP: {
-  skip "IV is not at least 64bit", 3 unless $Config{ivsize} >= 8;
-  skip "known to fail on $]", 3 if $] le "5.006002";
+  skip "IV is not at least 64bit", 4 unless $Config{ivsize} >= 8;
 
   # Sum using NV will only preserve 53 bits of integer precision
-  my $t = sum(1<<60, 1);
-  cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
+  my $t = sum(1152921504606846976, 1); # 1<<60, but Perl 5.6 does not compute constant correctly
+  cmp_ok($t, 'gt', 1152921504606846976, 'sum uses IV where it can'); # string comparison because Perl 5.6 does not compare it numerically correctly
+
+  SKIP: {
+    skip "known to fail on $]", 1 if $] le "5.006002";
+    $t = sum(1<<60, 1);
+    cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
+  }
 
   my $min = -(1<<63);
-  my $max = (1<<63)-1;
+  my $max = 9223372036854775807; # (1<<63)-1, but Perl 5.6 does not compute constant correctly
 
   $t = sum($min, $max);
   is($t, -1, 'min + max');
index 105c499..8806b8e 100644 (file)
@@ -54,11 +54,15 @@ SKIP: {
                [ $cafe ],
                'uniqstr is happy with Unicode strings' );
 
-    utf8::encode( my $cafebytes = $cafe );
+    SKIP: {
+      skip "utf8::encode not available", 1
+        unless defined &utf8::encode;
+      utf8::encode( my $cafebytes = $cafe );
 
-    is_deeply( [ uniqstr $cafe, $cafebytes ],
-               [ $cafe, $cafebytes ],
-               'uniqstr does not squash bytewise-equal but differently-encoded strings' );
+      is_deeply( [ uniqstr $cafe, $cafebytes ],
+                [ $cafe, $cafebytes ],
+                'uniqstr does not squash bytewise-equal but differently-encoded strings' );
+    }
 
     is( $warnings, "", 'No warnings are printed when handling Unicode strings' );
 }
@@ -81,10 +85,14 @@ is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
            'uniqnum preserves the special values of +-Inf and Nan' );
 
 {
-    my $maxint = ~0;
+    my $maxuint = ~0;
+    my $maxint = ~0 >> 1;
+    my $minint = -(~0 >> 1) - 1;
 
-    is_deeply( [ uniqnum $maxint, $maxint-1, -1 ],
-               [ $maxint, $maxint-1, -1 ],
+    my @nums = ($maxuint, $maxuint-1, -1, $Inf, $NaN, $maxint, $minint, 1 );
+
+    is_deeply( [ uniqnum @nums, 1.0 ],
+               [ @nums ],
                'uniqnum preserves uniqness of full integer range' );
 }
 
@@ -124,9 +132,7 @@ is_deeply( [ uniq () ],
 
 is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' );
 
-SKIP: {
-    skip "known to fail on $]", 1 if $] le "5.006002";
-
+{
     package Stringify;
 
     use overload '""' => sub { return $_[0]->{str} };
@@ -137,8 +143,8 @@ SKIP: {
 
     my @strs = map { Stringify->new( $_ ) } qw( foo foo bar );
 
-    is_deeply( [ uniqstr @strs ],
-               [ $strs[0], $strs[2] ],
+    is_deeply( [ map "$_", uniqstr @strs ],
+               [ map "$_", $strs[0], $strs[2] ],
                'uniqstr respects stringify overload' );
 }