summaryrefslogtreecommitdiff
path: root/cpan/Scalar-List-Utils
diff options
context:
space:
mode:
authorTodd Rinaldo <toddr@cpan.org>2018-03-18 17:08:04 -0500
committerTodd Rinaldo <toddr@cpan.org>2018-03-18 17:08:04 -0500
commit13bb7c4d393b51a96f457e6a551acf04efb18b90 (patch)
tree7c14a6ec60ba1215b86f3305958f0e8e7c94d6df /cpan/Scalar-List-Utils
parent43de38c477bd3ba3e0305e66dc3343de1b7dbb97 (diff)
downloadperl-13bb7c4d393b51a96f457e6a551acf04efb18b90.tar.gz
Upgrade Scalar::Util from version 1.49 to 1.50
[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
Diffstat (limited to 'cpan/Scalar-List-Utils')
-rw-r--r--cpan/Scalar-List-Utils/ListUtil.xs197
-rw-r--r--cpan/Scalar-List-Utils/Makefile.PL1
-rw-r--r--cpan/Scalar-List-Utils/lib/List/Util.pm30
-rw-r--r--cpan/Scalar-List-Utils/lib/List/Util/XS.pm2
-rw-r--r--cpan/Scalar-List-Utils/lib/Scalar/Util.pm2
-rw-r--r--cpan/Scalar-List-Utils/lib/Sub/Util.pm4
-rw-r--r--cpan/Scalar-List-Utils/t/exotic_names.t122
-rw-r--r--cpan/Scalar-List-Utils/t/head-tail.t97
-rw-r--r--cpan/Scalar-List-Utils/t/product.t5
-rw-r--r--cpan/Scalar-List-Utils/t/sum.t17
-rw-r--r--cpan/Scalar-List-Utils/t/uniq.t30
11 files changed, 430 insertions, 77 deletions
diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs
index 2369919f85..12f98cde19 100644
--- a/cpan/Scalar-List-Utils/ListUtil.xs
+++ b/cpan/Scalar-List-Utils/ListUtil.xs
@@ -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
@@ -43,6 +44,34 @@
# 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
diff --git a/cpan/Scalar-List-Utils/Makefile.PL b/cpan/Scalar-List-Utils/Makefile.PL
index 9859730e75..37bd104b40 100644
--- a/cpan/Scalar-List-Utils/Makefile.PL
+++ b/cpan/Scalar-List-Utils/Makefile.PL
@@ -54,4 +54,3 @@ WriteMakefile(
)
),
);
-
diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm
index 035f67f3a3..b650d3585a 100644
--- a/cpan/Scalar-List-Utils/lib/List/Util.pm
+++ b/cpan/Scalar-List-Utils/lib/List/Util.pm
@@ -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
diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm
index 10429a71f5..c8c066f825 100644
--- a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm
+++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm
@@ -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;
diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm
index 00edd3b2c7..6982158705 100644
--- a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm
+++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm
@@ -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
diff --git a/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/cpan/Scalar-List-Utils/lib/Sub/Util.pm
index ecfab702cd..edcc6544f6 100644
--- a/cpan/Scalar-List-Utils/lib/Sub/Util.pm
+++ b/cpan/Scalar-List-Utils/lib/Sub/Util.pm
@@ -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
index 0000000000..cb5d2cc9f2
--- /dev/null
+++ b/cpan/Scalar-List-Utils/t/exotic_names.t
@@ -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
index 0000000000..9477275a08
--- /dev/null
+++ b/cpan/Scalar-List-Utils/t/head-tail.t
@@ -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} );
diff --git a/cpan/Scalar-List-Utils/t/product.t b/cpan/Scalar-List-Utils/t/product.t
index 7b5894add3..87e887cf88 100644
--- a/cpan/Scalar-List-Utils/t/product.t
+++ b/cpan/Scalar-List-Utils/t/product.t
@@ -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
diff --git a/cpan/Scalar-List-Utils/t/sum.t b/cpan/Scalar-List-Utils/t/sum.t
index 1b7258c30a..e2c416df8c 100644
--- a/cpan/Scalar-List-Utils/t/sum.t
+++ b/cpan/Scalar-List-Utils/t/sum.t
@@ -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');
diff --git a/cpan/Scalar-List-Utils/t/uniq.t b/cpan/Scalar-List-Utils/t/uniq.t
index 105c499bae..8806b8e7d7 100644
--- a/cpan/Scalar-List-Utils/t/uniq.t
+++ b/cpan/Scalar-List-Utils/t/uniq.t
@@ -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' );
}