From: Graham Barr Date: Thu, 14 Aug 2003 14:12:45 +0000 (+0000) Subject: Update to Scalar-List-Utils 1.12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09c2a9b8ffd642eb76914fe4644328fdda59c63c;p=p5sagit%2Fp5-mst-13.2.git Update to Scalar-List-Utils 1.12 p4raw-id: //depot/perl@20700 --- diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog index 3157e92..ddc3923 100644 --- a/ext/List/Util/ChangeLog +++ b/ext/List/Util/ChangeLog @@ -1,3 +1,25 @@ +Change 825 on 2003/08/14 by (Graham Barr) + + Release 1.12 + +Change 824 on 2003/08/14 by (Graham Barr) + + Don't directly use the SV returned as $a in the next iteration, + take a copy instead. Fixes problem if the code block result was from + an eval or sub call + +Change 823 on 2003/08/14 by (Graham Barr) + + Install into the 'perl' installdirs for >= 5.008 + +Change 822 on 2003/08/14 by (Graham Barr) + + Fix test for EBCDIC portability + +Change 771 on 2003/03/03 by (Graham Barr) + + Get path for make from $Config + Change 770 on 2003/02/14 by (Graham Barr) Release 1.11 diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index de0da94..98c3758 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -206,7 +206,7 @@ reduce(block,...) PROTOTYPE: &@ CODE: { - SV *ret; + SV *ret = sv_newmortal(); int index; GV *agv,*bgv,*gv; HV *stash; @@ -225,6 +225,7 @@ CODE: bgv = gv_fetchpv("b", TRUE, SVt_PV); SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); + GvSV(agv) = ret; cv = sv_2cv(block, &stash, &gv, 0); reducecop = CvSTART(cv); SAVESPTR(CvROOT(cv)->op_ppaddr); @@ -237,20 +238,19 @@ CODE: #endif SAVETMPS; SAVESPTR(PL_op); - ret = ST(1); + SvSetSV(ret, ST(1)); CATCH_SET(TRUE); PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB(cx); if (!CvDEPTH(cv)) (void)SvREFCNT_inc(cv); for(index = 2 ; index < items ; index++) { - GvSV(agv) = ret; GvSV(bgv) = ST(index); PL_op = reducecop; CALLRUNOPS(aTHX); - ret = *PL_stack_sp; + SvSetSV(ret, *PL_stack_sp); } - ST(0) = sv_mortalcopy(ret); + ST(0) = ret; POPBLOCK(cx,PL_curpm); CATCH_SET(oldcatch); XSRETURN(1); diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm index 09beda6..be59dba 100644 --- a/ext/List/Util/lib/List/Util.pm +++ b/ext/List/Util/lib/List/Util.pm @@ -1,21 +1,84 @@ # List::Util.pm # -# Copyright (c) 1997-2001 Graham Barr . All rights reserved. +# Copyright (c) 1997-2003 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; require Exporter; -require DynaLoader; -our @ISA = qw(Exporter DynaLoader); -our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -our $VERSION = "1.11_00"; -our $XS_VERSION = $VERSION; +@ISA = qw(Exporter); +@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +$VERSION = "1.12"; +$XS_VERSION = $VERSION; $VERSION = eval $VERSION; -bootstrap List::Util $XS_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}; + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + 1 +}; + +eval <<'ESQ' unless defined &reduce; + +# This code is only compiled if the XS did not load + +use vars qw($a $b); + +sub reduce (&@) { + my $code = shift; + + return shift unless @_ > 1; + + my $caller = caller; + local(*{$caller."::a"}) = \my $a; + local(*{$caller."::b"}) = \my $b; + + $a = shift; + foreach (@_) { + $b = $_; + $a = &{$code}(); + } + + $a; +} + +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 first (&@) { + my $code = shift; + + foreach (@_) { + return $_ if &{$code}(); + } + + undef; +} + +sub shuffle (@) { + my @a=\(@_); + my $n; + my $i=@_; + map { + $n = rand($i--); + (${$a[$n]}, $a[$n] = $a[$i])[0]; + } @_; +} + +ESQ 1; @@ -187,7 +250,7 @@ to add due to them being very simple to implement in perl =head1 COPYRIGHT -Copyright (c) 1997-2001 Graham Barr . All rights reserved. +Copyright (c) 1997-2003 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.pm b/ext/List/Util/lib/Scalar/Util.pm index ca60dfd..5dc566c 100644 --- a/ext/List/Util/lib/Scalar/Util.pm +++ b/ext/List/Util/lib/Scalar/Util.pm @@ -1,6 +1,6 @@ # Scalar::Util.pm # -# Copyright (c) 1997-2001 Graham Barr . All rights reserved. +# Copyright (c) 1997-2003 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. @@ -9,9 +9,27 @@ package Scalar::Util; require Exporter; require List::Util; # List::Util loads the XS -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 = $List::Util::VERSION; +@ISA = qw(Exporter); +@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +$VERSION = "1.12"; +$VERSION = eval $VERSION; + +sub export_fail { + 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"); + } + + @_; +} sub openhandle ($) { my $fh = shift; @@ -31,6 +49,89 @@ sub openhandle ($) { ? $fh : undef; } +eval <<'ESQ' unless defined &dualvar; + +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; + bless $_[0], 'Scalar::Util::Fake'; + my $i = int($_[0]); + bless $_[0], $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 1 unless defined; + 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__ @@ -182,7 +283,7 @@ show up as tests 8 and 9 of dualvar.t failing =head1 COPYRIGHT -Copyright (c) 1997-2001 Graham Barr . All rights reserved. +Copyright (c) 1997-2003 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/t/reduce.t b/ext/List/Util/t/reduce.t index 4af711d..d6128f6 100755 --- 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); -print "1..9\n"; +print "1..13\n"; print "not " if defined reduce {}; print "ok 1\n"; @@ -56,3 +56,21 @@ print "${x}ok 9\n"; sub foobar { reduce { (defined(wantarray) && !wantarray) ? '' : 'not ' } 0,1,2,3 } +sub add2 { $a + $b } + +print "not " unless 6 == reduce \&add2, 1,2,3; +print "ok 10\n"; + +print "not " unless 6 == reduce { add2() } 1,2,3; +print "ok 11\n"; + + +print "not " unless 6 == reduce { eval "$a + $b" } 1,2,3; +print "ok 12\n"; + +$a = $b = 9; +reduce { $a * $b } 1,2,3; +print "not " unless $a == 9 and $b == 9; +print "ok 13\n"; + +