From: Graham Barr Date: Thu, 14 May 2009 00:55:30 +0000 (-0500) Subject: Update to Scalar-List-Utils-1.21 from CPAN X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ff286160a117d4e93cd92474de1931baa671032;p=p5sagit%2Fp5-mst-13.2.git Update to Scalar-List-Utils-1.21 from CPAN --- diff --git a/MANIFEST b/MANIFEST index cd942f0..e839825 100644 --- a/MANIFEST +++ b/MANIFEST @@ -916,13 +916,18 @@ ext/IPC-SysV/t/shm.t IPC::SysV test file ext/IPC-SysV/typemap IPC::SysV typemap ext/List-Util/Changes Util extension ext/List-Util/lib/List/Util.pm List::Util +ext/List-Util/lib/List/Util/PP.pm List::Util +ext/List-Util/lib/List/Util/XS.pm List::Util ext/List-Util/lib/Scalar/Util.pm Scalar::Util +ext/List-Util/lib/Scalar/Util/PP.pm Scalar::Util +ext/List-Util/ListUtil.xs Util extension ext/List-Util/Makefile.PL Util extension ext/List-Util/multicall.h Util extension ext/List-Util/README Util extension ext/List-Util/t/00version.t Scalar::Util ext/List-Util/t/blessed.t Scalar::Util ext/List-Util/t/dualvar.t Scalar::Util +ext/List-Util/t/expfail.t List::Util ext/List-Util/t/first.t List::Util ext/List-Util/t/isvstring.t Scalar::Util ext/List-Util/t/lln.t Scalar::Util @@ -931,6 +936,7 @@ ext/List-Util/t/max.t List::Util ext/List-Util/t/minstr.t List::Util ext/List-Util/t/min.t List::Util ext/List-Util/t/openhan.t Scalar::Util +ext/List-Util/t/p_00version.t Scalar::Util ext/List-Util/t/p_blessed.t Scalar::Util ext/List-Util/t/p_first.t List::Util ext/List-Util/t/p_lln.t Scalar::Util @@ -956,7 +962,7 @@ ext/List-Util/t/stack-corruption.t List::Util ext/List-Util/t/sum.t List::Util ext/List-Util/t/tainted.t Scalar::Util ext/List-Util/t/weak.t Scalar::Util -ext/List-Util/Util.xs Util extension +ext/List-Util/XS.pp List::Util ext/Math-BigInt-FastCalc/FastCalc.pm Math::BigInt::FastCalc extension ext/Math-BigInt-FastCalc/FastCalc.xs Math::BigInt::FastCalc extension ext/Math-BigInt-FastCalc/t/bigintfc.t Math::BigInt::FastCalc extension diff --git a/ext/List-Util/Changes b/ext/List-Util/Changes index 74c0f85..737b94d 100644 --- a/ext/List-Util/Changes +++ b/ext/List-Util/Changes @@ -1,3 +1,25 @@ +1.21 -- Mon May 18 10:32:14 CDT 2009 + + * Change build system for perl-only install not to need to modify blib + * When building inside perl, tests for weaken should be always run (Alexandr Ciornii) + +1.20 -- Wed May 13 16:42:53 CDT 2009 + +*** NOTE*** +This distribution now requires perl 5.6 or greater + +Bug Fixes + * Fixed stack pop issue in POP_MULTICALL + * Fixed error reporting in import when XS not compiled + * Check first argument to reduce is a CODE reference to avoid segfault + * Handle overloaded and tied values + * Fix tainted test to run on Win32 + +Enhancements + * Added List::Util::XS so authors can depend on XS version + * Removed need for dummy methods in UNIVERSAL for perl-only code + + 1.19 -- Sun Dec 10 09:58:03 CST 2006 Bug Fixes diff --git a/ext/List-Util/Util.xs b/ext/List-Util/ListUtil.xs similarity index 85% rename from ext/List-Util/Util.xs rename to ext/List-Util/ListUtil.xs index 585225c..c2f69a6 100644 --- a/ext/List-Util/Util.xs +++ b/ext/List-Util/ListUtil.xs @@ -147,18 +147,38 @@ CODE: int index; NV retval; SV *retsv; + int magic; if(!items) { XSRETURN_UNDEF; } retsv = ST(0); - retval = slu_sv_value(retsv); + magic = SvAMAGIC(retsv); + if (!magic) { + retval = slu_sv_value(retsv); + } for(index = 1 ; index < items ; index++) { SV *stacksv = ST(index); - NV val = slu_sv_value(stacksv); - if(val < retval ? !ix : ix) { - retsv = stacksv; - retval = val; - } + SV *tmpsv; + if ((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) { + if (SvTRUE(tmpsv) ? !ix : ix) { + retsv = stacksv; + magic = SvAMAGIC(retsv); + if (!magic) { + retval = slu_sv_value(retsv); + } + } + } + else { + NV val = slu_sv_value(stacksv); + if (magic) { + retval = slu_sv_value(retsv); + magic = 0; + } + if(val < retval ? !ix : ix) { + retsv = stacksv; + retval = val; + } + } } ST(0) = retsv; XSRETURN(1); @@ -166,25 +186,49 @@ CODE: -NV +void sum(...) PROTOTYPE: @ CODE: { SV *sv; + SV *retsv = NULL; int index; + int magic; + NV retval = 0; if(!items) { XSRETURN_UNDEF; } sv = ST(0); - RETVAL = slu_sv_value(sv); + if (SvAMAGIC(sv)) { + retsv = sv_newmortal(); + sv_setsv(retsv, sv); + } + else { + retval = slu_sv_value(sv); + } for(index = 1 ; index < items ; index++) { sv = ST(index); - RETVAL += slu_sv_value(sv); + if (retsv || SvAMAGIC(sv)) { + if (!retsv) { + retsv = sv_newmortal(); + sv_setnv(retsv,retval); + } + if (!amagic_call(retsv, sv, add_amg, AMGf_assign)) { + sv_setnv(retsv, SvNV(retsv) + SvNV(sv)); + } + } + else { + retval += slu_sv_value(sv); + } + } + if (!retsv) { + retsv = sv_newmortal(); + sv_setnv(retsv,retval); } + ST(0) = retsv; + XSRETURN(1); } -OUTPUT: - RETVAL void @@ -252,6 +296,9 @@ CODE: 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); @@ -485,6 +532,13 @@ looks_like_number(sv) SV *sv PROTOTYPE: $ CODE: + SV *tempsv; + 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 (SvPOK(sv) || SvPOKp(sv)) { RETVAL = looks_like_number(sv); diff --git a/ext/List-Util/Makefile.PL b/ext/List-Util/Makefile.PL index 9bc1c5a..1cba5ab 100644 --- a/ext/List-Util/Makefile.PL +++ b/ext/List-Util/Makefile.PL @@ -1,46 +1,86 @@ +# -*- perl -*- +BEGIN { require 5.006; } # allow CPAN testers to get the point +use strict; +use warnings; +use Config; +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( - VERSION_FROM => "lib/List/Util.pm", - NAME => "List::Util", - DEFINE => "-DPERL_EXT", + NAME => q[List::Util], + ABSTRACT => q[Common Scalar and List utility subroutines], + AUTHOR => q[Graham Barr ], + DEFINE => q[-DPERL_EXT], + DISTNAME => q[Scalar-List-Utils], + VERSION_FROM => 'lib/List/Util.pm', + + # We go through the ListUtil.xs trickery to foil platforms + # that have the feature combination of + # (1) static builds + # (2) allowing only one object by the same name in the static library + # (3) the object name matching being case-blind + # This means that we can't have the top-level util.o + # and the extension-level Util.o in the same build. + # One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform. + XS => {'ListUtil.xs' => 'ListUtil.c'}, + OBJECT => 'ListUtil$(OBJ_EXT)', + ( $PERL_CORE + ? () + : ( + 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', + }, + } + ) + : () + ), + ) + ), ); -package MY; -# We go through the ListUtil.c trickery to foil platforms -# that have the feature combination of -# (1) static builds -# (2) allowing only one object by the same name in the static library -# (3) the object name matching being case-blind -# This means that we can't have the top-level util.o -# and the extension-level Util.o in the same build. -# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform. - -BEGIN { - use Config; - unless (defined $Config{usedl}) { - eval <<'__EOMM__'; -sub xs_c { - my($self) = shift; - return '' unless $self->needs_linking(); -' -ListUtil.c: Util.xs - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > ListUtil.xsc && $(MV) ListUtil.xsc ListUtil.c -'; -} +sub can_cc { -sub xs_o { - my($self) = shift; - return '' unless $self->needs_linking(); -' + 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)); + } + } -Util$(OBJ_EXT): ListUtil.c - $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) ListUtil.c - $(MV) ListUtil$(OBJ_EXT) Util$(OBJ_EXT) -'; + return; } -__EOMM__ - } +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/ext/List-Util/XS.pp b/ext/List-Util/XS.pp new file mode 100644 index 0000000..6521f63 --- /dev/null +++ b/ext/List-Util/XS.pp @@ -0,0 +1,45 @@ +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 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 if the XS was not compiled. + +=head1 SEE ALSO + +L, L, L + +=head1 COPYRIGHT + +Copyright (c) 2008 Graham Barr . 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/ext/List-Util/lib/List/Util.pm b/ext/List-Util/lib/List/Util.pm index 829148c..426a7a3 100644 --- a/ext/List-Util/lib/List/Util.pm +++ b/ext/List-Util/lib/List/Util.pm @@ -1,8 +1,10 @@ # List::Util.pm # -# Copyright (c) 1997-2006 Graham Barr . All rights reserved. +# Copyright (c) 1997-2009 Graham Barr . 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 List::Util; @@ -12,7 +14,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.19"; +$VERSION = "1.21"; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -32,73 +34,11 @@ eval { } unless $TESTING_PERL_ONLY; -# This code is only compiled if the XS did not load -# of for perl < 5.6.0 - -if (!defined &reduce) { -eval <<'ESQ' - -sub reduce (&@) { - my $code = shift; - 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; - - foreach (@_) { - return $_ if &{$code}(); - } - - undef; -} - -ESQ -} - -# This code is only compiled if the XS did not load -eval <<'ESQ' if !defined ∑ - -use vars qw($a $b); - -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]; - } @_; +if (!defined &sum) { + require List::Util::PP; + List::Util::PP->import; } -ESQ - 1; __END__ @@ -212,6 +152,12 @@ element is returned and BLOCK is not executed. $foo = reduce { $a + $b } 1 .. 10 # sum $foo = reduce { $a . $b } @bar # concat +If your algorithm requires that C produce an identity value, then +make sure that you always pass that identity value as the first argument to prevent +C being returned + + $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value + =item shuffle LIST Returns the elements of LIST in a random order @@ -231,6 +177,12 @@ This function could be implemented using C like this $foo = reduce { $a + $b } 1..10 +If your algorithm requires that C produce an identity of 0, then +make sure that you always pass C<0> as the first argument to prevent +C being returned + + $foo = sum 0, @values; + =back =head1 KNOWN BUGS @@ -274,7 +226,7 @@ L, L =head1 COPYRIGHT -Copyright (c) 1997-2006 Graham Barr . All rights reserved. +Copyright (c) 1997-2007 Graham Barr . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/ext/List-Util/lib/List/Util/PP.pm b/ext/List-Util/lib/List/Util/PP.pm new file mode 100644 index 0000000..7fa2a55 --- /dev/null +++ b/ext/List-Util/lib/List/Util/PP.pm @@ -0,0 +1,75 @@ +# List::Util::PP.pm +# +# Copyright (c) 1997-2009 Graham Barr . 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.21"; +$VERSION = eval $VERSION; + +sub reduce (&@) { + my $code = shift; + unless(ref($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; + + 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/ext/List-Util/lib/List/Util/XS.pm b/ext/List-Util/lib/List/Util/XS.pm new file mode 100644 index 0000000..01ad27a --- /dev/null +++ b/ext/List-Util/lib/List/Util/XS.pm @@ -0,0 +1,45 @@ +package List::Util::XS; +use strict; +use vars qw($VERSION); +use List::Util; + +$VERSION = "1.21"; # 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__ + +=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 + +C 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 if the XS was not compiled. + +=head1 SEE ALSO + +L, L, L + +=head1 COPYRIGHT + +Copyright (c) 2008 Graham Barr . 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/ext/List-Util/lib/Scalar/Util.pm b/ext/List-Util/lib/Scalar/Util.pm index f947f74..db7b20c 100644 --- a/ext/List-Util/lib/Scalar/Util.pm +++ b/ext/List-Util/lib/Scalar/Util.pm @@ -1,34 +1,46 @@ # Scalar::Util.pm # -# Copyright (c) 1997-2006 Graham Barr . All rights reserved. +# Copyright (c) 1997-2007 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package Scalar::Util; use strict; -use vars qw(@ISA @EXPORT_OK $VERSION); +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.19"; +$VERSION = "1.21"; $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); +} + 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)$/ } @_ ) { require Carp; Carp::croak("Weak references are not implemented in the version of perl"); } + if (grep { /^(isvstring)$/ } @_ ) { require Carp; Carp::croak("Vstrings are not implemented in the version of perl"); } - if (grep { /^(dualvar|set_prototype)$/ } @_ ) { - require Carp; - Carp::croak("$1 is only avaliable with the XS version"); - } @_; } @@ -51,96 +63,6 @@ sub openhandle ($) { ? $fh : undef; } -eval <<'ESQ' unless defined &dualvar; - -use vars qw(@EXPORT_FAIL); -push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); - -# The code beyond here is only used if the XS is not installed - -# Hope nobody defines a sub by this name -sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } - -sub blessed ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - length(ref($_[0])) - ? eval { $_[0]->a_sub_not_likely_to_be_here } - : undef -} - -sub refaddr($) { - my $pkg = ref($_[0]) or return undef; - if (blessed($_[0])) { - bless $_[0], 'Scalar::Util::Fake'; - } - else { - $pkg = undef; - } - "$_[0]" =~ /0x(\w+)/; - my $i = do { local $^W; hex $1 }; - bless $_[0], $pkg if defined $pkg; - $i; -} - -sub reftype ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $r = shift; - my $t; - - length($t = ref($r)) or return undef; - - # This eval will fail if the reference is not blessed - eval { $r->a_sub_not_likely_to_be_here; 1 } - ? do { - $t = eval { - # we have a GLOB or an IO. Stringify a GLOB gives it's name - my $q = *$r; - $q =~ /^\*/ ? "GLOB" : "IO"; - } - or do { - # OK, if we don't have a GLOB what parts of - # a glob will it populate. - # NOTE: A glob always has a SCALAR - local *glob = $r; - defined *glob{ARRAY} && "ARRAY" - or defined *glob{HASH} && "HASH" - or defined *glob{CODE} && "CODE" - or length(ref(${$r})) ? "REF" : "SCALAR"; - } - } - : $t -} - -sub tainted { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - local $^W = 0; - 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($_) or ref($_); - return 1 if (/^[+-]?\d+$/); # is a +/- integer - return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float - return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); - - 0; -} - -ESQ - 1; __END__ @@ -153,6 +75,7 @@ Scalar::Util - A selection of general-utility scalar subroutines use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype); + # and other useful utils appearing below =head1 DESCRIPTION @@ -209,7 +132,7 @@ If EXPR is a scalar which is a weak reference the result is true. B: Copying a weak reference creates a normal, strong, reference. $copy = $ref; - $weak = isweak($ref); # false + $weak = isweak($copy); # false =item looks_like_number EXPR @@ -310,6 +233,32 @@ be destroyed because there is now always a strong reference to them in the =back +=head1 DIAGNOSTICS + +Module use may give one of the following errors during import. + +=over + +=item Weak references are not implemented in the version of perl + +The version of perl that you are using does not implement weak references, to use +C or C you will need to use a newer release of perl. + +=item Vstrings are not implemented in the version of perl + +The version of perl that you are using does not implement Vstrings, to use +C you will need to use a newer release of perl. + +=item C is only available with the XS version of Scalar::Util + +C contains both perl and C implementations of many of its functions +so that those without access to a C compiler may still use it. However some of the functions +are only available when a C compiler was available to compile the XS version of the extension. + +At present that list is: weaken, isweak, dualvar, isvstring, set_prototype + +=back + =head1 KNOWN BUGS There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will @@ -321,7 +270,7 @@ L =head1 COPYRIGHT -Copyright (c) 1997-2006 Graham Barr . All rights reserved. +Copyright (c) 1997-2007 Graham Barr . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/ext/List-Util/lib/Scalar/Util/PP.pm b/ext/List-Util/lib/Scalar/Util/PP.pm new file mode 100644 index 0000000..0b7f799 --- /dev/null +++ b/ext/List-Util/lib/Scalar/Util/PP.pm @@ -0,0 +1,109 @@ +# Scalar::Util::PP.pm +# +# Copyright (c) 1997-2009 Graham Barr . 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.21"; +$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; + hex($1); +} + +{ + my %tmap = qw( + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::NULL SCALAR + B::NV SCALAR + B::PV SCALAR + B::GV GLOB + B::RV REF + 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 (/^[+-]?\d+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} + + +1; diff --git a/ext/List-Util/t/00version.t b/ext/List-Util/t/00version.t index fad6e0f..d475de4 100644 --- a/ext/List-Util/t/00version.t +++ b/ext/List-Util/t/00version.t @@ -15,8 +15,11 @@ BEGIN { use Scalar::Util (); use List::Util (); -use Test::More tests => 1; +use List::Util::XS (); +use Test::More tests => 2; is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch"); - +my $has_xs = eval { Scalar::Util->import('dualvar'); 1 }; +my $xs_version = $has_xs ? $List::Util::VERSION : undef; +is( $List::Util::XS::VERSION, $xs_version, "XS VERSION"); diff --git a/ext/List-Util/t/blessed.t b/ext/List-Util/t/blessed.t index 8002404..f0a4c19 100644 --- a/ext/List-Util/t/blessed.t +++ b/ext/List-Util/t/blessed.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 8; +use Test::More tests => 11; use Scalar::Util qw(blessed); use vars qw($t $x); @@ -29,3 +29,26 @@ is(blessed($x), "ABC", 'blessed ARRAY-ref'); $x = bless {}, "DEF"; is(blessed($x), "DEF", 'blessed HASH-ref'); + +$x = bless {}, "0"; +cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); + +{ + my $depth; + { + no warnings 'redefine'; + *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) }; + } + $x = bless {}, "DEF"; + is(blessed($x), "DEF", 'recursion of UNIVERSAL::can'); +} + +{ + package Broken; + sub isa { die }; + sub can { die }; + + my $obj = bless [], __PACKAGE__; + ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" ); +} + diff --git a/ext/List-Util/t/dualvar.t b/ext/List-Util/t/dualvar.t index 652f22e..fab3691 100644 --- a/ext/List-Util/t/dualvar.t +++ b/ext/List-Util/t/dualvar.t @@ -42,9 +42,12 @@ $var = dualvar($numstr, ""); ok( $var == $numstr, 'NV'); -$var = dualvar(1<<31, ""); -ok( $var == (1<<31), 'UV 1'); -ok( $var > 0, 'UV 2'); +SKIP: { + skip("dualvar with UV value known to fail with $]",2) if $] < 5.006_001; + $var = dualvar(1<<31, ""); + ok( $var == (1<<31), 'UV 1'); + ok( $var > 0, 'UV 2'); +} tie my $tied, 'Tied'; $var = dualvar($tied, "ok"); diff --git a/ext/List-Util/t/expfail.t b/ext/List-Util/t/expfail.t new file mode 100644 index 0000000..02fc192 --- /dev/null +++ b/ext/List-Util/t/expfail.t @@ -0,0 +1,29 @@ +#!./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/ext/List-Util/t/lln.t b/ext/List-Util/t/lln.t index 4ec7719..d31633b 100644 --- a/ext/List-Util/t/lln.t +++ b/ext/List-Util/t/lln.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 16; +use Test::More tests => 18; use Scalar::Util qw(looks_like_number); foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) { @@ -31,7 +31,16 @@ is(!!looks_like_number([]), '', 'ARRAY Ref'); use Math::BigInt; my $bi = Math::BigInt->new('1234567890'); -is(!!looks_like_number($bi), '', 'Math::BigInt'); +is(!!looks_like_number($bi), 1, 'Math::BigInt'); is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt'); +{ package Foo; +sub TIEHASH { bless {} } +sub FETCH { $_[1] } +} +my %foo; +tie %foo, 'Foo'; +is(!!looks_like_number($foo{'abc'}), '', 'Tied'); +is(!!looks_like_number($foo{'123'}), 1, 'Tied'); + # We should copy some of perl core tests like t/base/num.t here diff --git a/ext/List-Util/t/max.t b/ext/List-Util/t/max.t index dd25a13..a982198 100644 --- a/ext/List-Util/t/max.t +++ b/ext/List-Util/t/max.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 5; +use Test::More tests => 8; use List::Util qw(max); my $v; @@ -34,3 +34,36 @@ my @a = map { rand() } 1 .. 20; my @b = sort { $a <=> $b } @a; $v = max(@a); is($v, $b[-1], '20-arg random order'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = max($one,$two,$thr); +is($v, 3, 'overload'); + +$v = max($thr,$two,$one); +is($v, 3, 'overload'); + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +SKIP: { + eval { require bignum; } or skip("Need bignum for testing overloading",1); + + 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/ext/List-Util/t/min.t b/ext/List-Util/t/min.t index 5e8c234..eb8c1b9 100644 --- a/ext/List-Util/t/min.t +++ b/ext/List-Util/t/min.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 5; +use Test::More tests => 8; use List::Util qw(min); my $v; @@ -34,3 +34,36 @@ my @a = map { rand() } 1 .. 20; my @b = sort { $a <=> $b } @a; $v = min(@a); is($v, $b[0], '20-arg random order'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = min($one,$two,$thr); +is($v, 1, 'overload'); + +$v = min($thr,$two,$one); +is($v, 1, 'overload'); + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +SKIP: { + eval { require bignum; } or skip("Need bignum for testing overloading",1); + + 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/ext/List-Util/t/openhan.t b/ext/List-Util/t/openhan.t index 0c84074..bf4e6c1 100644 --- a/ext/List-Util/t/openhan.t +++ b/ext/List-Util/t/openhan.t @@ -14,16 +14,76 @@ BEGIN { } use strict; -use vars qw(*CLOSED); -use Test::More tests => 4; + +use Test::More tests => 14; use Scalar::Util qw(openhandle); ok(defined &openhandle, 'defined'); -my $fh = \*STDERR; -is(openhandle($fh), $fh, 'STDERR'); +{ + my $fh = \*STDERR; + is(openhandle($fh), $fh, 'STDERR'); + + is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)'); +} + +{ + use vars qw(*CLOSED); + is(openhandle(*CLOSED), undef, 'closed'); +} + +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; + is(openhandle($fh), $fh, "works with indirect filehandles"); +} + +SKIP: { + skip "in-memory files only on 5.8 or later", 1 if $]<5.008; + + open my $fh, "<", \"in-memory file"; + skip "could not open in-memory file: $!", 1 unless $fh; + is(openhandle($fh), $fh, "works with in-memory files"); +} -is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)'); +ok(openhandle(\*DATA), "works for \*DATA"); +ok(openhandle(*DATA), "works for *DATA"); +ok(openhandle(*DATA{IO}), "works for *DATA{IO}"); -is(openhandle(*CLOSED), undef, 'closed'); +{ + require IO::Handle; + my $fh = IO::Handle->new_from_fd(fileno(*STDERR), 'w'); + skip "new_from_fd(fileno(*STDERR)) failed", 1 unless $fh; + ok(openhandle($fh), "works for IO::Handle objects"); + + ok(!openhandle(IO::Handle->new), "unopened IO::Handle"); +} + +{ + require IO::File; + my $fh = IO::File->new; + $fh->open("< $0") + or skip "could not open $0: $!", 1; + 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; + + use vars qw(*H); + + package My::Tie; + require Tie::Handle; + @My::Tie::ISA = qw(Tie::Handle); + sub TIEHANDLE { bless {} } + + package main; + tie *H, 'My::Tie'; + ok(openhandle(*H), "tied handles are always ok"); +} +__DATA__ diff --git a/ext/List-Util/t/p_00version.t b/ext/List-Util/t/p_00version.t new file mode 100644 index 0000000..0b64f9e --- /dev/null +++ b/ext/List-Util/t/p_00version.t @@ -0,0 +1,26 @@ +#!./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/ext/List-Util/t/p_tainted.t b/ext/List-Util/t/p_tainted.t index 5123a9f..eda5929 100644 --- a/ext/List-Util/t/p_tainted.t +++ b/ext/List-Util/t/p_tainted.t @@ -6,5 +6,7 @@ use File::Spec; $List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; (my $f = __FILE__) =~ s/p_//; -my $filename = File::Spec->catfile(".", $f); +my $filename = $^O eq 'MSWin32' + ? File::Spec->rel2abs(File::Spec->catfile(".", $f)) + : File::Spec->catfile(".", $f); do $filename; die $@ if $@; diff --git a/ext/List-Util/t/reduce.t b/ext/List-Util/t/reduce.t index d82580d..5d6e3d9 100644 --- a/ext/List-Util/t/reduce.t +++ b/ext/List-Util/t/reduce.t @@ -16,7 +16,7 @@ BEGIN { use List::Util qw(reduce min); use Test::More; -plan tests => ($::PERL_ONLY ? 21 : 23); +plan tests => ($::PERL_ONLY ? 23 : 25); my $v = reduce {}; @@ -122,6 +122,16 @@ SKIP: { is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged"); } +{ + my $ok = 'failed'; + local $SIG{__DIE__} = sub { $ok = $_[0] =~ /Not a (subroutine|CODE) reference/ ? '' : $_[0] }; + eval { &reduce('foo',1,2) }; + is($ok, '', 'Not a subroutine reference'); + $ok = 'failed'; + eval { &reduce({},1,2) }; + is($ok, '', 'Not a subroutine reference'); +} + # The remainder of the tests are only relevant for the XS # implementation. The Perl-only implementation behaves differently # (and more flexibly) in a way that we can't emulate from XS. diff --git a/ext/List-Util/t/refaddr.t b/ext/List-Util/t/refaddr.t index 61a33d3..35ad40f 100644 --- a/ext/List-Util/t/refaddr.t +++ b/ext/List-Util/t/refaddr.t @@ -14,7 +14,7 @@ BEGIN { } -use Test::More tests => 29; +use Test::More tests => 32; use Scalar::Util qw(refaddr); use vars qw($t $y $x *F $v $r); @@ -58,11 +58,22 @@ foreach $r ({}, \$t, [], \*F, sub {}) { ok(refaddr($x{$y})); ok(refaddr($x{$b})); } +{ + my $z = bless {}, '0'; + ok(refaddr($z)); + @{"0::ISA"} = qw(FooBar); + my $a = {}; + my $r = refaddr($a); + $z = bless $a, '0'; + ok(refaddr($z) > 10); + is(refaddr($z),$r,"foo"); +} package FooBar; use overload '0+' => sub { 10 }, - '+' => sub { 10 + $_[1] }; + '+' => sub { 10 + $_[1] }, + '"' => sub { "10" }; package MyTie; diff --git a/ext/List-Util/t/reftype.t b/ext/List-Util/t/reftype.t index 6cbc6d0..a7adafb 100644 --- a/ext/List-Util/t/reftype.t +++ b/ext/List-Util/t/reftype.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 23; +use Test::More tests => 29; use Scalar::Util qw(reftype); use vars qw($t $y $x *F); @@ -21,6 +21,7 @@ use Symbol qw(gensym); # Ensure we do not trigger and tied methods tie *F, 'MyTie'; +my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP'; @test = ( [ undef, 1, 'number' ], @@ -32,7 +33,8 @@ tie *F, 'MyTie'; [ GLOB => \*F, 'tied GLOB ref' ], [ GLOB => gensym, 'GLOB ref' ], [ CODE => sub {}, 'CODE ref' ], -# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN + [ IO => *STDIN{IO},'IO ref' ], + [ $RE => qr/x/, 'REGEEXP' ], ); foreach $test (@test) { diff --git a/ext/List-Util/t/stack-corruption.t b/ext/List-Util/t/stack-corruption.t index 8acbb0f..dff5af0 100644 --- a/ext/List-Util/t/stack-corruption.t +++ b/ext/List-Util/t/stack-corruption.t @@ -11,6 +11,10 @@ BEGIN { exit 0; } } + if ($] eq "5.008009" or $] eq "5.010000" or $] le "5.006002") { + print "1..0 # Skip: known to fail on $]\n"; + exit 0; + } } use List::Util qw(reduce); diff --git a/ext/List-Util/t/sum.t b/ext/List-Util/t/sum.t index 4860eeb..ef484f9 100644 --- a/ext/List-Util/t/sum.t +++ b/ext/List-Util/t/sum.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 6; +use Test::More tests => 8; use List::Util qw(sum); @@ -37,3 +37,33 @@ is( $v, 0, 'variable arg'); $v = sum(-3.5,3); is( $v, -0.5, 'real numbers'); +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = sum($one,$two,$thr); +is($v, 6, 'overload'); + + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +SKIP: { + eval { require bignum; } or skip("Need bignum for testing overloading",1); + + my $v1 = 2**65; + my $v2 = 2**65; + my $v3 = $v1 + $v2; + $v = sum($v1,$v2); + is($v, $v3, 'bignum'); +} diff --git a/ext/List-Util/t/weak.t b/ext/List-Util/t/weak.t index d0c3dff..f014113 100644 --- a/ext/List-Util/t/weak.t +++ b/ext/List-Util/t/weak.t @@ -1,10 +1,11 @@ #!./perl +use strict; +use Config; 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"; @@ -14,7 +15,7 @@ BEGIN { } use Scalar::Util (); -use Test::More (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) +use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE}) ? (skip_all => 'weaken requires XS version') : (tests => 22); @@ -94,9 +95,9 @@ print "# EXITBLOCK\n"; # Case 3: a circular structure # -$flag = 0; +my $flag = 0; { - my $y = bless {}, Dest; + my $y = bless {}, 'Dest'; Dump($y); print "# 1: $y\n"; $y->{Self} = $y; @@ -126,8 +127,8 @@ print "# FLAGU\n"; $flag = 0; { - my $y = bless {}, Dest; - my $x = bless {}, Dest; + my $y = bless {}, 'Dest'; + my $x = bless {}, 'Dest'; $x->{Ref} = $y; $y->{Ref} = $x; $x->{Flag} = \$flag; @@ -140,6 +141,7 @@ ok( $flag == 2 ); # Case 5: deleting a weakref before the other one # +my ($y,$z); { my $x = "foo"; $y = \$x; @@ -170,7 +172,7 @@ ok(isweak($b)); $b = \$a; ok(!isweak($b)); -$x = {}; +my $x = {}; weaken($x->{Y} = \$a); ok(isweak($x->{Y})); ok(!isweak($x->{Z}));