+Change 825 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.12
+
+Change 824 on 2003/08/14 by <gbarr@pobox.com> (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 <gbarr@pobox.com> (Graham Barr)
+
+ Install into the 'perl' installdirs for >= 5.008
+
+Change 822 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix test for EBCDIC portability
+
+Change 771 on 2003/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Get path for make from $Config
+
Change 770 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
Release 1.11
PROTOTYPE: &@
CODE:
{
- SV *ret;
+ SV *ret = sv_newmortal();
int index;
GV *agv,*bgv,*gv;
HV *stash;
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);
#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);
# List::Util.pm
#
-# Copyright (c) 1997-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2003 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;
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;
=head1 COPYRIGHT
-Copyright (c) 1997-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2003 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.
# Scalar::Util.pm
#
-# Copyright (c) 1997-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2003 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.
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;
? $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__
=head1 COPYRIGHT
-Copyright (c) 1997-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2003 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.
use List::Util qw(reduce min);
-print "1..9\n";
+print "1..13\n";
print "not " if defined reduce {};
print "ok 1\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";
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff