Update to Scalar-List-Utils 1.12

p4raw-id: //depot/perl@20700

5 files changed, 223 insertions, 19 deletions

diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog
index 3157e92086..ddc392360b 100644
--- a/ext/List/Util/ChangeLog
+++ b/ext/List/Util/ChangeLog
@@ -1,3 +1,25 @@
+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
diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index de0da94cec..98c375889c 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 09beda67ef..be59dbae64 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 <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;
 
@@ -187,7 +250,7 @@ to add due to them being very simple to implement in perl
 
 =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.
 
diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm
index ca60dfd3e1..5dc566c2f6 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 <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.
 
@@ -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 <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.
 
diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t
index 4af711de9d..d6128f6460 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";
+
+