- remove PREREQ_FATAL from Makefile.PL's processed by miniperl - update to latest Scalar-List-Utils (#507378) - perl-skip-prereq.patch: skip more prereq declarations in Makefile.PL files
1521 lines
40 KiB
Diff
1521 lines
40 KiB
Diff
Scalar-List-Utils-1.21
|
|
|
|
Makefile.PL patched to build Util.so instead of ListUtil.so
|
|
|
|
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
|
|
--- perl-5.10.0.orig/MANIFEST 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/MANIFEST 2009-07-10 12:34:47.000000000 +0200
|
|
@@ -842,6 +842,7 @@
|
|
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 Scalar::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
|
|
@@ -850,6 +851,7 @@
|
|
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
|
|
@@ -871,6 +873,7 @@
|
|
ext/List/Util/t/refaddr.t Scalar::Util
|
|
ext/List/Util/t/reftype.t Scalar::Util
|
|
ext/List/Util/t/shuffle.t List::Util
|
|
+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
|
|
diff -urN perl-5.10.0.orig/ext/List/Util/Changes perl-5.10.0/ext/List/Util/Changes
|
|
--- perl-5.10.0.orig/ext/List/Util/Changes 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/Changes 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -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 -urN perl-5.10.0.orig/ext/List/Util/Makefile.PL perl-5.10.0/ext/List/Util/Makefile.PL
|
|
--- perl-5.10.0.orig/ext/List/Util/Makefile.PL 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/Makefile.PL 2009-05-15 04:54:09.000000000 +0200
|
|
@@ -1,47 +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",
|
|
- MAN3PODS => {}, # Pods will be built by installman.
|
|
- NAME => "List::Util",
|
|
- DEFINE => "-DPERL_EXT",
|
|
+ NAME => q[List::Util],
|
|
+ ABSTRACT => q[Common Scalar and List utility subroutines],
|
|
+ AUTHOR => q[Graham Barr <gbarr@cpan.org>],
|
|
+ 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 => {'Util.xs' => 'Util.c'},
|
|
+ OBJECT => 'Util$(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 {
|
|
+
|
|
+ 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));
|
|
+ }
|
|
+ }
|
|
|
|
-sub xs_o {
|
|
- my($self) = shift;
|
|
- return '' unless $self->needs_linking();
|
|
-'
|
|
-
|
|
-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 -urN perl-5.10.0.orig/ext/List/Util/Util.xs perl-5.10.0/ext/List/Util/Util.xs
|
|
--- perl-5.10.0.orig/ext/List/Util/Util.xs 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/Util.xs 2009-05-13 23:59:43.000000000 +0200
|
|
@@ -147,18 +147,38 @@
|
|
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 @@
|
|
|
|
|
|
|
|
-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 @@
|
|
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 @@
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/lib/List/Util/PP.pm perl-5.10.0/ext/List/Util/lib/List/Util/PP.pm
|
|
--- perl-5.10.0.orig/ext/List/Util/lib/List/Util/PP.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/lib/List/Util/PP.pm 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -0,0 +1,75 @@
|
|
+# 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.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 -urN perl-5.10.0.orig/ext/List/Util/lib/List/Util/XS.pm perl-5.10.0/ext/List/Util/lib/List/Util/XS.pm
|
|
--- perl-5.10.0.orig/ext/List/Util/lib/List/Util/XS.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/lib/List/Util/XS.pm 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -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<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 -urN perl-5.10.0.orig/ext/List/Util/lib/List/Util.pm perl-5.10.0/ext/List/Util/lib/List/Util.pm
|
|
--- perl-5.10.0.orig/ext/List/Util/lib/List/Util.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/lib/List/Util.pm 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -1,8 +1,10 @@
|
|
# List::Util.pm
|
|
#
|
|
-# Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
+# 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 List::Util;
|
|
|
|
@@ -12,7 +14,7 @@
|
|
|
|
@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 @@
|
|
} 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 @@
|
|
$foo = reduce { $a + $b } 1 .. 10 # sum
|
|
$foo = reduce { $a . $b } @bar # concat
|
|
|
|
+If your algorithm requires that C<reduce> produce an identity value, then
|
|
+make sure that you always pass that identity value as the first argument to prevent
|
|
+C<undef> 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 @@
|
|
|
|
$foo = reduce { $a + $b } 1..10
|
|
|
|
+If your algorithm requires that C<sum> produce an identity of 0, then
|
|
+make sure that you always pass C<0> as the first argument to prevent
|
|
+C<undef> being returned
|
|
+
|
|
+ $foo = sum 0, @values;
|
|
+
|
|
=back
|
|
|
|
=head1 KNOWN BUGS
|
|
@@ -274,7 +226,7 @@
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
-Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
+Copyright (c) 1997-2007 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.
|
|
|
|
diff -urN perl-5.10.0.orig/ext/List/Util/lib/Scalar/Util/PP.pm perl-5.10.0/ext/List/Util/lib/Scalar/Util/PP.pm
|
|
--- perl-5.10.0.orig/ext/List/Util/lib/Scalar/Util/PP.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/lib/Scalar/Util/PP.pm 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -0,0 +1,109 @@
|
|
+# 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.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 -urN perl-5.10.0.orig/ext/List/Util/lib/Scalar/Util.pm perl-5.10.0/ext/List/Util/lib/Scalar/Util.pm
|
|
--- perl-5.10.0.orig/ext/List/Util/lib/Scalar/Util.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/lib/Scalar/Util.pm 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -1,34 +1,46 @@
|
|
# Scalar::Util.pm
|
|
#
|
|
-# Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
+# Copyright (c) 1997-2007 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 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 @@
|
|
? $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 @@
|
|
|
|
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 @@
|
|
B<NOTE>: 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 @@
|
|
|
|
=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<isweak> or C<weaken> 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<isvstring> you will need to use a newer release of perl.
|
|
+
|
|
+=item C<NAME> is only available with the XS version of Scalar::Util
|
|
+
|
|
+C<Scalar::Util> 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 @@
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
-Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
+Copyright (c) 1997-2007 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.
|
|
|
|
@@ -331,11 +280,4 @@
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the same terms as perl itself.
|
|
|
|
-=head1 BLATANT PLUG
|
|
-
|
|
-The weaken and isweak subroutines in this module and the patch to the core Perl
|
|
-were written in connection with the APress book `Tuomas J. Lukka's Definitive
|
|
-Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
|
|
-things would have to be done in cumbersome ways.
|
|
-
|
|
=cut
|
|
diff -urN perl-5.10.0.orig/ext/List/Util/t/00version.t perl-5.10.0/ext/List/Util/t/00version.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/00version.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/00version.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -15,8 +15,11 @@
|
|
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/blessed.t perl-5.10.0/ext/List/Util/t/blessed.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/blessed.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/blessed.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -13,7 +13,7 @@
|
|
}
|
|
}
|
|
|
|
-use Test::More tests => 8;
|
|
+use Test::More tests => 11;
|
|
use Scalar::Util qw(blessed);
|
|
use vars qw($t $x);
|
|
|
|
@@ -29,3 +29,26 @@
|
|
|
|
$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 -urN perl-5.10.0.orig/ext/List/Util/t/dualvar.t perl-5.10.0/ext/List/Util/t/dualvar.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/dualvar.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/dualvar.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -42,9 +42,12 @@
|
|
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/expfail.t perl-5.10.0/ext/List/Util/t/expfail.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/expfail.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/expfail.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -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 -urN perl-5.10.0.orig/ext/List/Util/t/lln.t perl-5.10.0/ext/List/Util/t/lln.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/lln.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/lln.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -14,7 +14,7 @@
|
|
}
|
|
|
|
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 @@
|
|
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/max.t perl-5.10.0/ext/List/Util/t/max.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/max.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/max.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -14,7 +14,7 @@
|
|
}
|
|
|
|
use strict;
|
|
-use Test::More tests => 5;
|
|
+use Test::More tests => 8;
|
|
use List::Util qw(max);
|
|
|
|
my $v;
|
|
@@ -34,3 +34,36 @@
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/min.t perl-5.10.0/ext/List/Util/t/min.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/min.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/min.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -14,7 +14,7 @@
|
|
}
|
|
|
|
use strict;
|
|
-use Test::More tests => 5;
|
|
+use Test::More tests => 8;
|
|
use List::Util qw(min);
|
|
|
|
my $v;
|
|
@@ -34,3 +34,36 @@
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/openhan.t perl-5.10.0/ext/List/Util/t/openhan.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/openhan.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/openhan.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -14,16 +14,76 @@
|
|
}
|
|
|
|
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");
|
|
+}
|
|
|
|
-is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
|
|
+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(openhandle(*CLOSED), undef, 'closed');
|
|
+ok(openhandle(\*DATA), "works for \*DATA");
|
|
+ok(openhandle(*DATA), "works for *DATA");
|
|
+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;
|
|
+ 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 -urN perl-5.10.0.orig/ext/List/Util/t/p_00version.t perl-5.10.0/ext/List/Util/t/p_00version.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/p_00version.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/p_00version.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -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 -urN perl-5.10.0.orig/ext/List/Util/t/p_tainted.t perl-5.10.0/ext/List/Util/t/p_tainted.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/p_tainted.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/p_tainted.t 2009-07-08 17:24:47.000000000 +0200
|
|
@@ -6,5 +6,7 @@
|
|
$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 -urN perl-5.10.0.orig/ext/List/Util/t/reduce.t perl-5.10.0/ext/List/Util/t/reduce.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/reduce.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/reduce.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -16,7 +16,7 @@
|
|
|
|
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 @@
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/refaddr.t perl-5.10.0/ext/List/Util/t/refaddr.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/refaddr.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/refaddr.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -14,7 +14,7 @@
|
|
}
|
|
|
|
|
|
-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 @@
|
|
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 -urN perl-5.10.0.orig/ext/List/Util/t/reftype.t perl-5.10.0/ext/List/Util/t/reftype.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/reftype.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/reftype.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -13,7 +13,7 @@
|
|
}
|
|
}
|
|
|
|
-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 @@
|
|
|
|
# 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 @@
|
|
[ 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 -urN perl-5.10.0.orig/ext/List/Util/t/stack-corruption.t perl-5.10.0/ext/List/Util/t/stack-corruption.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/stack-corruption.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/stack-corruption.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -0,0 +1,30 @@
|
|
+#!./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;
|
|
+ }
|
|
+ }
|
|
+ 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);
|
|
+use Test::More tests => 1;
|
|
+
|
|
+my $ret = "original";
|
|
+$ret = $ret . broken();
|
|
+is($ret, "originalreturn");
|
|
+
|
|
+sub broken {
|
|
+ reduce { return "bogus"; } qw/some thing/;
|
|
+ return "return";
|
|
+}
|
|
diff -urN perl-5.10.0.orig/ext/List/Util/t/sum.t perl-5.10.0/ext/List/Util/t/sum.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/sum.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/sum.t 2009-07-08 17:22:59.000000000 +0200
|
|
@@ -13,7 +13,7 @@
|
|
}
|
|
}
|
|
|
|
-use Test::More tests => 6;
|
|
+use Test::More tests => 8;
|
|
|
|
use List::Util qw(sum);
|
|
|
|
@@ -37,3 +37,33 @@
|
|
$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 -urN perl-5.10.0.orig/ext/List/Util/t/weak.t perl-5.10.0/ext/List/Util/t/weak.t
|
|
--- perl-5.10.0.orig/ext/List/Util/t/weak.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/ext/List/Util/t/weak.t 2009-07-08 17:23:27.000000000 +0200
|
|
@@ -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 @@
|
|
}
|
|
|
|
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 @@
|
|
# 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 @@
|
|
|
|
$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 @@
|
|
# Case 5: deleting a weakref before the other one
|
|
#
|
|
|
|
+my ($y,$z);
|
|
{
|
|
my $x = "foo";
|
|
$y = \$x;
|
|
@@ -170,7 +172,7 @@
|
|
$b = \$a;
|
|
ok(!isweak($b));
|
|
|
|
-$x = {};
|
|
+my $x = {};
|
|
weaken($x->{Y} = \$a);
|
|
ok(isweak($x->{Y}));
|
|
ok(!isweak($x->{Z}));
|