diff options
author | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2012-05-27 22:19:38 +0100 |
---|---|---|
committer | bingos <bingos@azkaban.(none)> | 2012-06-12 11:03:21 +0100 |
commit | 3630f57ef8a29a646a6848f4e93d25ac47093a3c (patch) | |
tree | ff688ac4d2523139edb7e3efbe8e7dd96d9fa419 /cpan/List-Util | |
parent | e5cccf3ce5d62591703f2998f30d65ba7f551844 (diff) | |
download | perl-3630f57ef8a29a646a6848f4e93d25ac47093a3c.tar.gz |
Update List-Util to CPAN version 1.25
[DELTA]
1.25 -- Sat Mar 24 13:10:13 UTC 2012
* Restore back-compat. to perl 5.6 (thanks to Zefram)
1.24 -- Thu Mar 22 18:10:10 UTC 2012
* Update to 1.24 release version (no other changes since 1.23_04).
1.23_04 -- Sat Mar 10 00:16:16 UTC 2012
* RT#72700 Fix off-by-two on string literal length
1.23_03 -- Tue Sep 14 10:09:59 CDT 2010
* Min perl version supported for build is not 5.008
* Dropped the pure-Perl implementation of both Scalar::- and List::Util.
* RT#61118 Fix assumption in sum() that once magic, always magic
1.23_02 -- Tue Mar 30 11:09:15 CDT 2010
* Fix first() and reduce() to check the callback first; &first(1) is now illigal. [gfx]
* Fix reduce() to allow XSUB callbacks [gfx]
* Fix first() to allow XSUB callbacks [gfx]
* Resolve RT #55763: tainted() doesn't do SvGETMAGIC(sv) [gfx]
* define CvISXSUB so older perl versions will still compile
1.23_01 -- Mon Mar 22 08:24:11 CDT 2010
* Add failing tests; SVt_RV is not directly SvROK [gfx]
* Implement openhandle() in XS (with extra tests) [gfx]
* Modernize *.pm [gfx]
* Modernize ListUtil.xs [gfx]
* Add ppport.h [gfx]
* Fix an overloading issue on sum(), and add tests for overloading [gfx]
* Small tweaks for minstr()/maxstr() [gfx]
* Optimize dualvar() [gfx]
* Use sv_copypv() instead of SvPV() and sv_setpv() [gfx]
* avoid non-portable warnings
Diffstat (limited to 'cpan/List-Util')
35 files changed, 402 insertions, 727 deletions
diff --git a/cpan/List-Util/Changes b/cpan/List-Util/Changes index 552a95a13c..f737c1da5a 100644 --- a/cpan/List-Util/Changes +++ b/cpan/List-Util/Changes @@ -1,3 +1,42 @@ +1.25 -- Sat Mar 24 13:10:13 UTC 2012 + + * Restore back-compat. to perl 5.6 (thanks to Zefram) + +1.24 -- Thu Mar 22 18:10:10 UTC 2012 + + * Update to 1.24 release version (no other changes since 1.23_04). + +1.23_04 -- Sat Mar 10 00:16:16 UTC 2012 + + * RT#72700 Fix off-by-two on string literal length + +1.23_03 -- Tue Sep 14 10:09:59 CDT 2010 + + * Min perl version supported for build is not 5.008 + * Dropped the pure-Perl implementation of both Scalar::- and List::Util. + * RT#61118 Fix assumption in sum() that once magic, always magic + +1.23_02 -- Tue Mar 30 11:09:15 CDT 2010 + + * Fix first() and reduce() to check the callback first; &first(1) is now illigal. [gfx] + * Fix reduce() to allow XSUB callbacks [gfx] + * Fix first() to allow XSUB callbacks [gfx] + * Resolve RT #55763: tainted() doesn't do SvGETMAGIC(sv) [gfx] + * define CvISXSUB so older perl versions will still compile + +1.23_01 -- Mon Mar 22 08:24:11 CDT 2010 + + * Add failing tests; SVt_RV is not directly SvROK [gfx] + * Implement openhandle() in XS (with extra tests) [gfx] + * Modernize *.pm [gfx] + * Modernize ListUtil.xs [gfx] + * Add ppport.h [gfx] + * Fix an overloading issue on sum(), and add tests for overloading [gfx] + * Small tweaks for minstr()/maxstr() [gfx] + * Optimize dualvar() [gfx] + * Use sv_copypv() instead of SvPV() and sv_setpv() [gfx] + * avoid non-portable warnings + 1.23 -- Wed Mar 10 20:50:00 CST 2010 * Add a test file to ensure 'GETMAGIC' called once [gfx] diff --git a/cpan/List-Util/ListUtil.xs b/cpan/List-Util/ListUtil.xs index 7da9b959d1..be4b68c2cb 100644 --- a/cpan/List-Util/ListUtil.xs +++ b/cpan/List-Util/ListUtil.xs @@ -7,31 +7,23 @@ #include <perl.h> #include <XSUB.h> -#ifndef PERL_VERSION -# include <patchlevel.h> -# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) -# include <could_not_find_Perl_patchlevel.h> -# endif -# define PERL_REVISION 5 -# define PERL_VERSION PATCHLEVEL -# define PERL_SUBVERSION SUBVERSION -#endif +#define NEED_sv_2pv_flags 1 +#include "ppport.h" -#if PERL_VERSION >= 6 +#if PERL_BCDVERSION >= 0x5006000 # include "multicall.h" #endif -#ifndef aTHX -# define aTHX -# define pTHX +#ifndef CvISXSUB +# define CvISXSUB(cv) CvXSUB(cv) #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 */ -#if PERL_VERSION < 7 +#if PERL_BCDVERSION < 0x5007000 /* Not in 5.6.1. */ -# define SvUOK(sv) SvIOK_UV(sv) # ifdef cxinc # undef cxinc # endif @@ -40,13 +32,24 @@ static I32 my_cxinc(pTHX) { cxstack_max = cxstack_max * 3 / 2; - Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */ + Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */ return cxstack_ix + 1; } #endif -#if PERL_VERSION < 6 -# define NV double +#ifndef sv_copypv +#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b) +static void +my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) +{ + STRLEN len; + const char * const s = SvPV_const(ssv,len); + sv_setpvn(dsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(dsv); + else + SvUTF8_off(dsv); +} #endif #ifdef SVf_IVisUV @@ -55,81 +58,6 @@ my_cxinc(pTHX) # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) #endif -#ifndef Drand01 -# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) -#endif - -#if PERL_VERSION < 5 -# ifndef gv_stashpvn -# define gv_stashpvn(n,l,c) gv_stashpv(n,c) -# endif -# ifndef SvTAINTED - -static bool -sv_tainted(pTHX_ SV *sv) -{ - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, 't'); - if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) - return TRUE; - } - return FALSE; -} - -# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0) -# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(aTHX_ sv)) -# endif -# define PL_defgv defgv -# define PL_op op -# define PL_curpad curpad -# define CALLRUNOPS runops -# define PL_curpm curpm -# define PL_sv_undef sv_undef -# define PERL_CONTEXT struct context -#endif -#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50) -# ifndef PL_tainting -# define PL_tainting tainting -# endif -# ifndef PL_stack_base -# define PL_stack_base stack_base -# endif -# ifndef PL_stack_sp -# define PL_stack_sp stack_sp -# endif -# ifndef PL_ppaddr -# define PL_ppaddr ppaddr -# endif -#endif - -#ifndef PTR2UV -# define PTR2UV(ptr) (UV)(ptr) -#endif - -#ifndef SvUV_set -# define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val)) -#endif - -#ifndef PERL_UNUSED_DECL -# ifdef HASATTRIBUTE -# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) -# define PERL_UNUSED_DECL -# else -# define PERL_UNUSED_DECL __attribute__((unused)) -# endif -# else -# define PERL_UNUSED_DECL -# endif -#endif - -#ifndef dNOOP -#define dNOOP extern int Perl___notused PERL_UNUSED_DECL -#endif - -#ifndef GvSVn -# define GvSVn GvSV -#endif - MODULE=List::Util PACKAGE=List::Util void @@ -187,51 +115,71 @@ sum(...) PROTOTYPE: @ CODE: { + dXSTARG; SV *sv; SV *retsv = NULL; int index; NV retval = 0; + int magic; if(!items) { XSRETURN_UNDEF; } - sv = ST(0); - if (SvAMAGIC(sv)) { - retsv = sv_newmortal(); + sv = ST(0); + magic = SvAMAGIC(sv); + if (magic) { + retsv = TARG; sv_setsv(retsv, sv); } else { retval = slu_sv_value(sv); } for(index = 1 ; index < items ; index++) { - sv = ST(index); - if (retsv || SvAMAGIC(sv)) { - if (!retsv) { - retsv = sv_newmortal(); - sv_setnv(retsv,retval); + sv = ST(index); + if(!magic && SvAMAGIC(sv)){ + magic = TRUE; + if (!retsv) + retsv = TARG; + sv_setnv(retsv,retval); + } + if (magic) { + SV* const tmpsv = amagic_call(retsv, sv, add_amg, SvAMAGIC(retsv) ? AMGf_assign : 0); + if(tmpsv) { + magic = SvAMAGIC(tmpsv); + if (!magic) { + retval = slu_sv_value(tmpsv); + } + else { + retsv = tmpsv; + } } - if (!amagic_call(retsv, sv, add_amg, AMGf_assign)) { - sv_setnv(retsv, SvNV(retsv) + SvNV(sv)); + else { + /* fall back to default */ + magic = FALSE; + retval = SvNV(retsv) + SvNV(sv); } } else { retval += slu_sv_value(sv); } } - if (!retsv) { - retsv = sv_newmortal(); + if (!magic) { + if (!retsv) + retsv = TARG; sv_setnv(retsv,retval); } ST(0) = retsv; XSRETURN(1); } +#define SLU_CMP_LARGER 1 +#define SLU_CMP_SMALLER -1 void minstr(...) PROTOTYPE: @ ALIAS: - minstr = 2 - maxstr = 0 + minstr = SLU_CMP_LARGER + maxstr = SLU_CMP_SMALLER CODE: { SV *left; @@ -239,12 +187,6 @@ CODE: if(!items) { XSRETURN_UNDEF; } - /* - sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt - so we set ix to the value we are looking for - xsubpp does not allow -ve values, so we start with 0,2 and subtract 1 - */ - ix -= 1; left = ST(0); #ifdef OPpLOCALE if(MAXARG & OPpLOCALE) { @@ -278,35 +220,52 @@ reduce(block,...) PROTOTYPE: &@ CODE: { - dMULTICALL; SV *ret = sv_newmortal(); int index; GV *agv,*bgv,*gv; HV *stash; - I32 gimme = G_SCALAR; SV **args = &PL_stack_base[ax]; - CV *cv; + CV* cv = sv_2cv(block, &stash, &gv, 0); - if(items <= 1) { - XSRETURN_UNDEF; - } - cv = sv_2cv(block, &stash, &gv, 0); if (cv == Nullcv) { croak("Not a subroutine reference"); } - PUSH_MULTICALL(cv); - agv = gv_fetchpv("a", TRUE, SVt_PV); - bgv = gv_fetchpv("b", TRUE, SVt_PV); + + if(items <= 1) { + XSRETURN_UNDEF; + } + + agv = gv_fetchpv("a", GV_ADD, SVt_PV); + bgv = gv_fetchpv("b", GV_ADD, SVt_PV); SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); GvSV(agv) = ret; SvSetSV(ret, args[1]); - for(index = 2 ; index < items ; index++) { - GvSV(bgv) = args[index]; - MULTICALL; - SvSetSV(ret, *PL_stack_sp); + + if(!CvISXSUB(cv)) { + dMULTICALL; + I32 gimme = G_SCALAR; + + PUSH_MULTICALL(cv); + for(index = 2 ; index < items ; index++) { + GvSV(bgv) = args[index]; + MULTICALL; + SvSetSV(ret, *PL_stack_sp); + } + POP_MULTICALL; } - POP_MULTICALL; + else { + for(index = 2 ; index < items ; index++) { + dSP; + GvSV(bgv) = args[index]; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + + SvSetSV(ret, *PL_stack_sp); + } + } + ST(0) = ret; XSRETURN(1); } @@ -317,34 +276,50 @@ first(block,...) PROTOTYPE: &@ CODE: { - dMULTICALL; int index; GV *gv; HV *stash; - I32 gimme = G_SCALAR; SV **args = &PL_stack_base[ax]; - CV *cv; + CV *cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("Not a subroutine reference"); + } if(items <= 1) { XSRETURN_UNDEF; } - cv = sv_2cv(block, &stash, &gv, 0); - if (cv == Nullcv) { - croak("Not a subroutine reference"); - } - PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); - for(index = 1 ; index < items ; index++) { - GvSV(PL_defgv) = args[index]; - MULTICALL; - if (SvTRUE(*PL_stack_sp)) { - POP_MULTICALL; - ST(0) = ST(index); - XSRETURN(1); - } + if(!CvISXSUB(cv)) { + dMULTICALL; + I32 gimme = G_SCALAR; + PUSH_MULTICALL(cv); + + for(index = 1 ; index < items ; index++) { + GvSV(PL_defgv) = args[index]; + MULTICALL; + if (SvTRUEx(*PL_stack_sp)) { + POP_MULTICALL; + ST(0) = ST(index); + XSRETURN(1); + } + } + POP_MULTICALL; + } + else { + for(index = 1 ; index < items ; index++) { + dSP; + GvSV(PL_defgv) = args[index]; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + if (SvTRUEx(*PL_stack_sp)) { + ST(0) = ST(index); + XSRETURN(1); + } + } } - POP_MULTICALL; XSRETURN_UNDEF; } @@ -398,30 +373,27 @@ dualvar(num,str) PROTOTYPE: $$ CODE: { - STRLEN len; - char *ptr = SvPV(str,len); - ST(0) = sv_newmortal(); - (void)SvUPGRADE(ST(0),SVt_PVNV); - sv_setpvn(ST(0),ptr,len); - if (SvUTF8(str)) - SvUTF8_on(ST(0)); + dXSTARG; + (void)SvUPGRADE(TARG, SVt_PVNV); + sv_copypv(TARG,str); if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { - SvNV_set(ST(0), SvNV(num)); - SvNOK_on(ST(0)); + SvNV_set(TARG, SvNV(num)); + SvNOK_on(TARG); } #ifdef SVf_IVisUV else if (SvUOK(num)) { - SvUV_set(ST(0), SvUV(num)); - SvIOK_on(ST(0)); - SvIsUV_on(ST(0)); + SvUV_set(TARG, SvUV(num)); + SvIOK_on(TARG); + SvIsUV_on(TARG); } #endif else { - SvIV_set(ST(0), SvIV(num)); - SvIOK_on(ST(0)); + SvIV_set(TARG, SvIV(num)); + SvIOK_on(TARG); } if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) - SvTAINTED_on(ST(0)); + SvTAINTED_on(TARG); + ST(0) = TARG; XSRETURN(1); } @@ -431,8 +403,7 @@ blessed(sv) PROTOTYPE: $ CODE: { - if (SvMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) { XSRETURN_UNDEF; } @@ -447,8 +418,7 @@ reftype(sv) PROTOTYPE: $ CODE: { - if (SvMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if(!SvROK(sv)) { XSRETURN_UNDEF; } @@ -463,8 +433,7 @@ refaddr(sv) PROTOTYPE: $ CODE: { - if (SvMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if(!SvROK(sv)) { XSRETURN_UNDEF; } @@ -501,6 +470,7 @@ readonly(sv) SV *sv PROTOTYPE: $ CODE: + SvGETMAGIC(sv); RETVAL = SvREADONLY(sv); OUTPUT: RETVAL @@ -510,6 +480,7 @@ tainted(sv) SV *sv PROTOTYPE: $ CODE: + SvGETMAGIC(sv); RETVAL = SvTAINTED(sv); OUTPUT: RETVAL @@ -520,6 +491,7 @@ isvstring(sv) PROTOTYPE: $ CODE: #ifdef SvVOK + SvGETMAGIC(sv); ST(0) = boolSV(SvVOK(sv)); XSRETURN(1); #else @@ -532,13 +504,11 @@ looks_like_number(sv) PROTOTYPE: $ CODE: SV *tempsv; + SvGETMAGIC(sv); if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) { sv = tempsv; } - else if (SvMAGICAL(sv)) { - SvGETMAGIC(sv); - } -#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5) +#if PERL_BCDVERSION < 0x5008005 if (SvPOK(sv) || SvPOKp(sv)) { RETVAL = looks_like_number(sv); } @@ -566,9 +536,7 @@ CODE: } if (SvPOK(proto)) { /* set the prototype */ - STRLEN len; - char *ptr = SvPV(proto, len); - sv_setpvn(sv, ptr, len); + sv_copypv(sv, proto); } else { /* delete the prototype */ @@ -581,6 +549,35 @@ CODE: XSRETURN(1); } +void +openhandle(SV* sv) +PROTOTYPE: $ +CODE: +{ + IO* io = NULL; + SvGETMAGIC(sv); + if(SvROK(sv)){ + /* deref first */ + sv = SvRV(sv); + } + + /* must be GLOB or IO */ + if(isGV(sv)){ + io = GvIO((GV*)sv); + } + else if(SvTYPE(sv) == SVt_PVIO){ + io = (IO*)sv; + } + + if(io){ + /* real or tied filehandle? */ + if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){ + XSRETURN(1); + } + } + XSRETURN_UNDEF; +} + BOOT: { HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); @@ -595,7 +592,7 @@ BOOT: varav = GvAVn(vargv); #endif if (SvTYPE(rmcgv) != SVt_PVGV) - gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE); + gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE); rmcsv = GvSVn(rmcgv); #ifndef SvWEAKREF av_push(varav, newSVpv("weaken",6)); diff --git a/cpan/List-Util/Makefile.PL b/cpan/List-Util/Makefile.PL index 1cba5abdaa..40f91670e5 100644 --- a/cpan/List-Util/Makefile.PL +++ b/cpan/List-Util/Makefile.PL @@ -1,5 +1,5 @@ # -*- perl -*- -BEGIN { require 5.006; } # allow CPAN testers to get the point +BEGIN { require 5.006; } use strict; use warnings; use Config; @@ -7,13 +7,6 @@ use File::Spec; use ExtUtils::MakeMaker; my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV; -my $do_xs = $PERL_CORE || can_cc(); - -for (@ARGV) { - /^-pm/ and $do_xs = 0; - /^-xs/ and $do_xs = 1; -} - WriteMakefile( NAME => q[List::Util], ABSTRACT => q[Common Scalar and List utility subroutines], @@ -38,11 +31,10 @@ WriteMakefile( INSTALLDIRS => q[perl], PREREQ_PM => {'Test::More' => 0,}, (eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()), - ($do_xs ? () : (XS => {}, C => [], OBJECT => '')), ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { resources => { ## - repository => 'http://github.com/gbarr/Scalar-List-Utils', + repository => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils', }, } ) @@ -52,35 +44,3 @@ WriteMakefile( ), ); - -sub can_cc { - - foreach my $cmd (split(/ /, $Config::Config{cc})) { - my $_cmd = $cmd; - return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); - - for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { - my $abs = File::Spec->catfile($dir, $_[1]); - return $abs if (-x $abs or $abs = MM->maybe_command($abs)); - } - } - - return; -} - -package MY; - -sub init_PM { - my $self = shift; - - $self->SUPER::init_PM(@_); - - return if $do_xs; - - my $pm = $self->{PM}; - my $pm_file = File::Spec->catfile(qw(lib List Util XS.pm)); - - # When installing pure perl, install XS.pp as XS.pm - $self->{PM}{'XS.pp'} = delete $self->{PM}{$pm_file}; -} - diff --git a/cpan/List-Util/XS.pp b/cpan/List-Util/XS.pp deleted file mode 100644 index 6521f632cd..0000000000 --- a/cpan/List-Util/XS.pp +++ /dev/null @@ -1,45 +0,0 @@ -package List::Util::XS; -use strict; -use vars qw($VERSION); - -$VERSION = undef; - -sub VERSION { - require Carp; - Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled") - if defined $_[1]; - $VERSION; -} - -1; -__END__ - -=head1 NAME - -List::Util::XS - Indicate if List::Util was compiled with a C compiler - -=head1 SYNOPSIS - - use List::Util::XS 1.20; - -=head1 DESCRIPTION - -B<*** This instalation does not have XS installed ***> - -C<List::Util::XS> can be used as a dependency to ensure List::Util was -installed using a C compiler and that the XS version is installed. - -During installation C<$List::Util::XS::VERSION> will be set to -C<undef> if the XS was not compiled. - -=head1 SEE ALSO - -L<Scalar::Util>, L<List::Util>, L<List::MoreUtils> - -=head1 COPYRIGHT - -Copyright (c) 2008 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/cpan/List-Util/lib/List/Util.pm b/cpan/List-Util/lib/List/Util.pm index aced6b15b5..033ef505c0 100644 --- a/cpan/List-Util/lib/List/Util.pm +++ b/cpan/List-Util/lib/List/Util.pm @@ -9,35 +9,16 @@ package List::Util; use strict; -use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); require Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.23"; -$XS_VERSION = $VERSION; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +our $VERSION = "1.25"; +our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; -eval { - # PERL_DL_NONLAZY must be false, or any errors in loading will just - # cause the perl code to be tested - local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; - eval { - require XSLoader; - XSLoader::load('List::Util', $XS_VERSION); - 1; - } or do { - require DynaLoader; - local @ISA = qw(DynaLoader); - bootstrap List::Util $XS_VERSION; - }; -} unless $TESTING_PERL_ONLY; - - -if (!defined &sum) { - require List::Util::PP; - List::Util::PP->import; -} +require XSLoader; +XSLoader::load('List::Util', $XS_VERSION); 1; diff --git a/cpan/List-Util/lib/List/Util/PP.pm b/cpan/List-Util/lib/List/Util/PP.pm deleted file mode 100644 index 2771329b56..0000000000 --- a/cpan/List-Util/lib/List/Util/PP.pm +++ /dev/null @@ -1,83 +0,0 @@ -# List::Util::PP.pm -# -# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package List::Util::PP; - -use strict; -use warnings; -use vars qw(@ISA @EXPORT $VERSION $a $b); -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.23"; -$VERSION = eval $VERSION; - -sub reduce (&@) { - my $code = shift; - require Scalar::Util; - my $type = Scalar::Util::reftype($code); - unless($type and $type eq 'CODE') { - require Carp; - Carp::croak("Not a subroutine reference"); - } - no strict 'refs'; - - return shift unless @_ > 1; - - use vars qw($a $b); - - my $caller = caller; - local(*{$caller."::a"}) = \my $a; - local(*{$caller."::b"}) = \my $b; - - $a = shift; - foreach (@_) { - $b = $_; - $a = &{$code}(); - } - - $a; -} - -sub first (&@) { - my $code = shift; - require Scalar::Util; - my $type = Scalar::Util::reftype($code); - unless($type and $type eq 'CODE') { - require Carp; - Carp::croak("Not a subroutine reference"); - } - - foreach (@_) { - return $_ if &{$code}(); - } - - undef; -} - - -sub sum (@) { reduce { $a + $b } @_ } - -sub min (@) { reduce { $a < $b ? $a : $b } @_ } - -sub max (@) { reduce { $a > $b ? $a : $b } @_ } - -sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } - -sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } - -sub shuffle (@) { - my @a=\(@_); - my $n; - my $i=@_; - map { - $n = rand($i--); - (${$a[$n]}, $a[$n] = $a[$i])[0]; - } @_; -} - -1; diff --git a/cpan/List-Util/lib/List/Util/XS.pm b/cpan/List-Util/lib/List/Util/XS.pm index 2dcb03a28e..d46853ca23 100644 --- a/cpan/List-Util/lib/List/Util/XS.pm +++ b/cpan/List-Util/lib/List/Util/XS.pm @@ -1,18 +1,10 @@ package List::Util::XS; use strict; -use vars qw($VERSION); use List::Util; -$VERSION = "1.23"; # FIXUP +our $VERSION = "1.25"; # FIXUP $VERSION = eval $VERSION; # FIXUP -sub _VERSION { # FIXUP - require Carp; - Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled") - if defined $_[1]; - $VERSION; -} - 1; __END__ @@ -32,6 +24,10 @@ installed using a C compiler and that the XS version is installed. During installation C<$List::Util::XS::VERSION> will be set to C<undef> if the XS was not compiled. +Starting with release 1.23_03, Scalar-List-Util is B<always> using +the XS implementation, but for backwards compatibility, we still +ship the C<List::Util::XS> module which just loads C<List::Util>. + =head1 SEE ALSO L<Scalar::Util>, L<List::Util>, L<List::MoreUtils> diff --git a/cpan/List-Util/lib/Scalar/Util.pm b/cpan/List-Util/lib/Scalar/Util.pm index 24138ca4d8..ab97fe5446 100644 --- a/cpan/List-Util/lib/Scalar/Util.pm +++ b/cpan/List-Util/lib/Scalar/Util.pm @@ -7,37 +7,33 @@ package Scalar::Util; use strict; -use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL); require Exporter; require List::Util; # List::Util loads the XS -@ISA = qw(Exporter); -@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); -$VERSION = "1.23"; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +our $VERSION = "1.25"; $VERSION = eval $VERSION; -unless (defined &dualvar) { - # Load Pure Perl version if XS not loaded - require Scalar::Util::PP; - Scalar::Util::PP->import; - push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); +our @EXPORT_FAIL; + +unless (defined &weaken) { + push @EXPORT_FAIL, qw(weaken); +} +unless (defined &isweak) { + push @EXPORT_FAIL, qw(isweak isvstring); +} +unless (defined &isvstring) { + push @EXPORT_FAIL, qw(isvstring); } sub export_fail { - if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded - my $pat = join("|", @EXPORT_FAIL); - if (my ($err) = grep { /^($pat)$/ } @_ ) { - require Carp; - Carp::croak("$err is only available with the XS version of Scalar::Util"); - } - } - - if (grep { /^(weaken|isweak)$/ } @_ ) { + if (grep { /^(?:weaken|isweak)$/ } @_ ) { require Carp; Carp::croak("Weak references are not implemented in the version of perl"); } - if (grep { /^(isvstring)$/ } @_ ) { + if (grep { /^isvstring$/ } @_ ) { require Carp; Carp::croak("Vstrings are not implemented in the version of perl"); } @@ -45,24 +41,6 @@ sub export_fail { @_; } -sub openhandle ($) { - my $fh = shift; - my $rt = reftype($fh) || ''; - - return defined(fileno($fh)) ? $fh : undef - if $rt eq 'IO'; - - if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) - $fh = \(my $tmp=$fh); - } - elsif ($rt ne 'GLOB') { - return undef; - } - - (tied(*$fh) or defined(fileno($fh))) - ? $fh : undef; -} - 1; __END__ diff --git a/cpan/List-Util/lib/Scalar/Util/PP.pm b/cpan/List-Util/lib/Scalar/Util/PP.pm deleted file mode 100644 index 7850e1b812..0000000000 --- a/cpan/List-Util/lib/Scalar/Util/PP.pm +++ /dev/null @@ -1,108 +0,0 @@ -# Scalar::Util::PP.pm -# -# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# This module is normally only loaded if the XS module is not available - -package Scalar::Util::PP; - -use strict; -use warnings; -use vars qw(@ISA @EXPORT $VERSION $recurse); -require Exporter; -use B qw(svref_2object); - -@ISA = qw(Exporter); -@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number); -$VERSION = "1.23"; -$VERSION = eval $VERSION; - -sub blessed ($) { - return undef unless length(ref($_[0])); - my $b = svref_2object($_[0]); - return undef unless $b->isa('B::PVMG'); - my $s = $b->SvSTASH; - return $s->isa('B::HV') ? $s->NAME : undef; -} - -sub refaddr($) { - return undef unless length(ref($_[0])); - - my $addr; - if(defined(my $pkg = blessed($_[0]))) { - $addr .= bless $_[0], 'Scalar::Util::Fake'; - bless $_[0], $pkg; - } - else { - $addr .= $_[0] - } - - $addr =~ /0x(\w+)/; - local $^W; - no warnings 'portable'; - hex($1); -} - -{ - my %tmap = qw( - B::NULL SCALAR - - B::HV HASH - B::AV ARRAY - B::CV CODE - B::IO IO - B::GV GLOB - B::REGEXP REGEXP - ); - - sub reftype ($) { - my $r = shift; - - return undef unless length(ref($r)); - - my $t = ref(svref_2object($r)); - - return - exists $tmap{$t} ? $tmap{$t} - : length(ref($$r)) ? 'REF' - : 'SCALAR'; - } -} - -sub tainted { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - local $^W = 0; - no warnings; - eval { kill 0 * $_[0] }; - $@ =~ /^Insecure/; -} - -sub readonly { - return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); - - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $tmp = $_[0]; - - !eval { $_[0] = $tmp; 1 }; -} - -sub looks_like_number { - local $_ = shift; - - # checks from perlfaq4 - return 0 if !defined($_); - if (ref($_)) { - require overload; - return overload::Overloaded($_) ? defined(0 + $_) : 0; - } - return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer - return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float - return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); - - 0; -} - - -1; diff --git a/cpan/List-Util/t/expfail.t b/cpan/List-Util/t/expfail.t deleted file mode 100644 index 02fc192f14..0000000000 --- a/cpan/List-Util/t/expfail.t +++ /dev/null @@ -1,29 +0,0 @@ -#!./perl - -BEGIN { - unless (-d 'blib') { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - keys %Config; # Silence warning - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } - } -} - -use Test::More tests => 3; -use strict; - -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; -require Scalar::Util; - -for my $func (qw(dualvar set_prototype weaken)) { - eval { Scalar::Util->import($func); }; - like( - $@, - qr/$func is only available with the XS/, - "no pure perl $func: error raised", - ); -} diff --git a/cpan/List-Util/t/first.t b/cpan/List-Util/t/first.t index 1378c39044..497cdd5188 100644 --- a/cpan/List-Util/t/first.t +++ b/cpan/List-Util/t/first.t @@ -15,7 +15,7 @@ BEGIN { use List::Util qw(first); use Test::More; -plan tests => 19 + ($::PERL_ONLY ? 0 : 2); +plan tests => 22 + ($::PERL_ONLY ? 0 : 2); my $v; ok(defined &first, 'defined'); @@ -114,6 +114,15 @@ if (!$::PERL_ONLY) { SKIP: { } } +use constant XSUBC_TRUE => 1; +use constant XSUBC_FALSE => 0; + +is first(\&XSUBC_TRUE, 42, 1, 2, 3), 42, 'XSUB callbacks'; +is first(\&XSUBC_FALSE, 42, 1, 2, 3), undef, 'XSUB callbacks'; + + +eval { &first(1) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); eval { &first(1,2) }; ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); eval { &first(qw(a b)) }; diff --git a/cpan/List-Util/t/getmagic-once.t b/cpan/List-Util/t/getmagic-once.t new file mode 100644 index 0000000000..00b3490783 --- /dev/null +++ b/cpan/List-Util/t/getmagic-once.t @@ -0,0 +1,47 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} +use strict; +use Scalar::Util qw(blessed reftype refaddr); +use Test::More tests => 6; + +my $getmagic_count; + +{ + package T; + use Tie::Scalar; + use base qw(Tie::StdScalar); + + sub FETCH { + $getmagic_count++; + my($self) = @_; + return $self->SUPER::FETCH; + } +} + +tie my $var, 'T'; + +$var = bless {}; + +$getmagic_count = 0; +ok blessed($var); +is $getmagic_count, 1, 'blessed'; + +$getmagic_count = 0; +ok reftype($var); +is $getmagic_count, 1, 'reftype'; + +$getmagic_count = 0; +ok refaddr($var); +is $getmagic_count, 1, 'refaddr'; diff --git a/cpan/List-Util/t/max.t b/cpan/List-Util/t/max.t index aff916658f..9607015d83 100644 --- a/cpan/List-Util/t/max.t +++ b/cpan/List-Util/t/max.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 8; +use Test::More tests => 10; use List::Util qw(max); my $v; @@ -45,6 +45,7 @@ is($v, 3, 'overload'); $v = max($thr,$two,$one); is($v, 3, 'overload'); + { package Foo; use overload @@ -59,12 +60,17 @@ use overload } } -SKIP: { - eval { require bignum; } or skip("Need bignum for testing overloading",1); +use Math::BigInt; + +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +my $v3 = $v2 - 1; +$v = max($v1,$v2,$v1,$v3,$v1); +is($v, $v1, 'bigint'); + +$v = max($v1, 1, 2, 3); +is($v, $v1, 'bigint and normal int'); + +$v = max(1, 2, $v1, 3); +is($v, $v1, 'bigint and normal int'); - my $v1 = 2**65; - my $v2 = $v1 - 1; - my $v3 = $v2 - 1; - $v = max($v1,$v2,$v1,$v3,$v1); - is($v, $v1, 'bigint'); -} diff --git a/cpan/List-Util/t/min.t b/cpan/List-Util/t/min.t index 13d1116a6c..8d5be5e153 100644 --- a/cpan/List-Util/t/min.t +++ b/cpan/List-Util/t/min.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 8; +use Test::More tests => 10; use List::Util qw(min); my $v; @@ -59,12 +59,17 @@ use overload } } -SKIP: { - eval { require bignum; } or skip("Need bignum for testing overloading",1); +use Math::BigInt; + +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +my $v3 = $v2 - 1; +$v = min($v1,$v2,$v1,$v3,$v1); +is($v, $v3, 'bigint'); + +$v = min($v1, 1, 2, 3); +is($v, 1, 'bigint and normal int'); + +$v = min(1, 2, $v1, 3); +is($v, 1, 'bigint and normal int'); - my $v1 = 2**65; - my $v2 = $v1 - 1; - my $v3 = $v2 - 1; - $v = min($v1,$v2,$v1,$v3,$v1); - is($v, $v3, 'bigint'); -} diff --git a/cpan/List-Util/t/openhan.t b/cpan/List-Util/t/openhan.t index bf4e6c16f8..e0dffb6f53 100644 --- a/cpan/List-Util/t/openhan.t +++ b/cpan/List-Util/t/openhan.t @@ -15,7 +15,7 @@ BEGIN { use strict; -use Test::More tests => 14; +use Test::More tests => 21; use Scalar::Util qw(openhandle); ok(defined &openhandle, 'defined'); @@ -36,16 +36,20 @@ SKIP: { skip "3-arg open only on 5.6 or later", 1 if $]<5.006; open my $fh, "<", $0; - skip "could not open $0 for reading: $!", 1 unless $fh; + skip "could not open $0 for reading: $!", 2 unless $fh; is(openhandle($fh), $fh, "works with indirect filehandles"); + close($fh); + is(openhandle($fh), undef, "works with indirect filehandles"); } SKIP: { - skip "in-memory files only on 5.8 or later", 1 if $]<5.008; + skip "in-memory files only on 5.8 or later", 2 if $]<5.008; open my $fh, "<", \"in-memory file"; - skip "could not open in-memory file: $!", 1 unless $fh; + skip "could not open in-memory file: $!", 2 unless $fh; is(openhandle($fh), $fh, "works with in-memory files"); + close($fh); + is(openhandle($fh), undef, "works with in-memory files"); } ok(openhandle(\*DATA), "works for \*DATA"); @@ -55,7 +59,7 @@ ok(openhandle(*DATA{IO}), "works for *DATA{IO}"); { require IO::Handle; my $fh = IO::Handle->new_from_fd(fileno(*STDERR), 'w'); - skip "new_from_fd(fileno(*STDERR)) failed", 1 unless $fh; + skip "new_from_fd(fileno(*STDERR)) failed", 2 unless $fh; ok(openhandle($fh), "works for IO::Handle objects"); ok(!openhandle(IO::Handle->new), "unopened IO::Handle"); @@ -65,14 +69,16 @@ ok(openhandle(*DATA{IO}), "works for *DATA{IO}"); require IO::File; my $fh = IO::File->new; $fh->open("< $0") - or skip "could not open $0: $!", 1; + or skip "could not open $0: $!", 3; ok(openhandle($fh), "works for IO::File objects"); + close($fh); + ok(!openhandle($fh), "works for IO::File objects"); ok(!openhandle(IO::File->new), "unopened IO::File" ); } SKIP: { - skip( "Tied handles only on 5.8 or later", 1) if $]<5.008; + skip( "Tied handles only on 5.8 or later", 2) if $]<5.008; use vars qw(*H); @@ -84,6 +90,12 @@ SKIP: { package main; tie *H, 'My::Tie'; ok(openhandle(*H), "tied handles are always ok"); + ok(openhandle(\*H), "tied handle refs are always ok"); } +ok !openhandle(undef), "undef is not a filehandle"; +ok !openhandle("STDIN"), "strings are not filehandles"; +ok !openhandle(0), "integers are not filehandles"; + + __DATA__ diff --git a/cpan/List-Util/t/p_00version.t b/cpan/List-Util/t/p_00version.t deleted file mode 100644 index 0b64f9eef3..0000000000 --- a/cpan/List-Util/t/p_00version.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -BEGIN { - unless (-d 'blib') { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - keys %Config; # Silence warning - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } - } -} - -use Test::More tests => 2; - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -require Scalar::Util; -require List::Util; - -is( $Scalar::Util::PP::VERSION, $List::Util::VERSION, "VERSION mismatch"); -is( $List::Util::PP::VERSION, $List::Util::VERSION, "VERSION mismatch"); - diff --git a/cpan/List-Util/t/p_blessed.t b/cpan/List-Util/t/p_blessed.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_blessed.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_first.t b/cpan/List-Util/t/p_first.t deleted file mode 100644 index cd39ec44be..0000000000 --- a/cpan/List-Util/t/p_first.t +++ /dev/null @@ -1,8 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_lln.t b/cpan/List-Util/t/p_lln.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_lln.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_max.t b/cpan/List-Util/t/p_max.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_max.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_maxstr.t b/cpan/List-Util/t/p_maxstr.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_maxstr.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_min.t b/cpan/List-Util/t/p_min.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_min.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_minstr.t b/cpan/List-Util/t/p_minstr.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_minstr.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_openhan.t b/cpan/List-Util/t/p_openhan.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_openhan.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_readonly.t b/cpan/List-Util/t/p_readonly.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_readonly.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_reduce.t b/cpan/List-Util/t/p_reduce.t deleted file mode 100644 index cd39ec44be..0000000000 --- a/cpan/List-Util/t/p_reduce.t +++ /dev/null @@ -1,8 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_refaddr.t b/cpan/List-Util/t/p_refaddr.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_refaddr.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_reftype.t b/cpan/List-Util/t/p_reftype.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_reftype.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_shuffle.t b/cpan/List-Util/t/p_shuffle.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_shuffle.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_sum.t b/cpan/List-Util/t/p_sum.t deleted file mode 100644 index 48e7ef7dcd..0000000000 --- a/cpan/List-Util/t/p_sum.t +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -do $f; die $@ if $@; diff --git a/cpan/List-Util/t/p_tainted.t b/cpan/List-Util/t/p_tainted.t deleted file mode 100644 index 6a4cd22242..0000000000 --- a/cpan/List-Util/t/p_tainted.t +++ /dev/null @@ -1,12 +0,0 @@ -#!./perl -T - -use File::Spec; - -# force perl-only version to be tested -$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; - -(my $f = __FILE__) =~ s/p_//; -my $filename = ($^O eq 'MSWin32' || $^O eq 'VMS') - ? File::Spec->rel2abs(File::Spec->catfile(".", $f)) - : File::Spec->catfile(".", $f); -do $filename; die $@ if $@; diff --git a/cpan/List-Util/t/reduce.t b/cpan/List-Util/t/reduce.t index 2e1257521c..4468ab8611 100644 --- a/cpan/List-Util/t/reduce.t +++ b/cpan/List-Util/t/reduce.t @@ -16,7 +16,7 @@ BEGIN { use List::Util qw(reduce min); use Test::More; -plan tests => 27 + ($::PERL_ONLY ? 0 : 2); +plan tests => 29 + ($::PERL_ONLY ? 0 : 2); my $v = reduce {}; @@ -151,6 +151,13 @@ if (!$::PERL_ONLY) { SKIP: { } } +# XSUB callback +use constant XSUBC => 42; + +is reduce(\&XSUBC, 1, 2, 3), 42, "xsub callbacks"; + +eval { &reduce(1) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); eval { &reduce(1,2) }; ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); eval { &reduce(qw(a b)) }; diff --git a/cpan/List-Util/t/reftype.t b/cpan/List-Util/t/reftype.t index a7adafb996..31a5d3b841 100644 --- a/cpan/List-Util/t/reftype.t +++ b/cpan/List-Util/t/reftype.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 29; +use Test::More tests => 32; use Scalar::Util qw(reftype); use vars qw($t $y $x *F); @@ -23,12 +23,16 @@ use Symbol qw(gensym); tie *F, 'MyTie'; my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP'; +my $s = []; # SvTYPE($s) is SVt_RV, and SvROK($s) is true +$s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false + @test = ( [ undef, 1, 'number' ], [ undef, 'A', 'string' ], [ HASH => {}, 'HASH ref' ], [ ARRAY => [], 'ARRAY ref' ], [ SCALAR => \$t, 'SCALAR ref' ], + [ SCALAR => \$s, 'SCALAR ref (but SVt_RV)' ], [ REF => \(\$t), 'REF ref' ], [ GLOB => \*F, 'tied GLOB ref' ], [ GLOB => gensym, 'GLOB ref' ], diff --git a/cpan/List-Util/t/sum.t b/cpan/List-Util/t/sum.t index ef484f96c5..3615b4ab41 100644 --- a/cpan/List-Util/t/sum.t +++ b/cpan/List-Util/t/sum.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 8; +use Test::More tests => 13; use List::Util qw(sum); @@ -58,12 +58,40 @@ use overload } } -SKIP: { - eval { require bignum; } or skip("Need bignum for testing overloading",1); +use Math::BigInt; +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +$v = sum($v1,$v2); +is($v, $v1 + $v2, 'bigint'); - my $v1 = 2**65; - my $v2 = 2**65; - my $v3 = $v1 + $v2; - $v = sum($v1,$v2); - is($v, $v3, 'bignum'); +$v = sum(42, $v1); +is($v, $v1 + 42, 'bigint + builtin int'); + +$v = sum(42, $v1, 2); +is($v, $v1 + 42 + 2, 'bigint + builtin int'); + +{ package example; + + use overload + '0+' => sub { $_[0][0] }, + '""' => sub { my $r = "$_[0][0]"; $r = "+$r" unless $r =~ m/^\-/; $r .= " [$_[0][1]]"; $r }, + fallback => 1; + + sub new { + my $class = shift; + + my $this = bless [@_], $class; + + return $this; + } +} + +{ + my $e1 = example->new(7, "test"); + $t = sum($e1, 7, 7); + is($t, 21, 'overload returning non-overload'); + $t = sum(8, $e1, 8); + is($t, 23, 'overload returning non-overload'); + $t = sum(9, 9, $e1); + is($t, 25, 'overload returning non-overload'); } diff --git a/cpan/List-Util/t/tainted.t b/cpan/List-Util/t/tainted.t index 09ad330684..ab40aa69fe 100644 --- a/cpan/List-Util/t/tainted.t +++ b/cpan/List-Util/t/tainted.t @@ -16,7 +16,7 @@ BEGIN { } } -use Test::More tests => 4; +use Test::More tests => 5; use Scalar::Util qw(tainted); @@ -32,3 +32,12 @@ ok( tainted($ENV{$key}), 'environment variable'); $var = $ENV{$key}; ok( tainted($var), 'copy of environment variable'); + +{ + package Tainted; + sub TIESCALAR { bless {} } + sub FETCH { $^X } +} + +tie my $tiedvar, 'Tainted'; +ok( tainted($tiedvar), 'for magic variables'); |