diff options
author | Todd Rinaldo <toddr@cpan.org> | 2018-03-18 17:08:04 -0500 |
---|---|---|
committer | Todd Rinaldo <toddr@cpan.org> | 2018-03-18 17:08:04 -0500 |
commit | 13bb7c4d393b51a96f457e6a551acf04efb18b90 (patch) | |
tree | 7c14a6ec60ba1215b86f3305958f0e8e7c94d6df /cpan/Scalar-List-Utils | |
parent | 43de38c477bd3ba3e0305e66dc3343de1b7dbb97 (diff) | |
download | perl-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.xs | 197 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/Makefile.PL | 1 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/lib/List/Util.pm | 30 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/lib/List/Util/XS.pm | 2 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/lib/Scalar/Util.pm | 2 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/lib/Sub/Util.pm | 4 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/t/exotic_names.t | 122 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/t/head-tail.t | 97 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/t/product.t | 5 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/t/sum.t | 17 | ||||
-rw-r--r-- | cpan/Scalar-List-Utils/t/uniq.t | 30 |
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' ); } |