From: Graham Barr <gbarr@pobox.com>
Date: Mon, 3 Sep 2001 20:00:00 +0000 (+0000)
Subject: Update to Scalar-List-Utils 1.03
X-Git-Tag: perl-5.7.3~2676
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/1bfb547737cc66dfee963cd7a652aa76bf6e5c18

Update to Scalar-List-Utils 1.03

p4raw-id: //depot/perl@11853
---

diff --git a/MANIFEST b/MANIFEST
index 8f39648..95845fe 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -387,6 +387,7 @@ ext/List/Util/t/minstr.t	List::Util
 ext/List/Util/t/readonly.t	Scalar::Util
 ext/List/Util/t/reduce.t	List::Util
 ext/List/Util/t/reftype.t	Scalar::Util
+ext/List/Util/t/shuffle.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 --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog
index bd9814ca..eaad55b 100644
--- a/ext/List/Util/ChangeLog
+++ b/ext/List/Util/ChangeLog
@@ -1,3 +1,35 @@
+Change 636 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+	More changes to help merging with core dist
+
+Change 635 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+	Added List::Util::shuffle() similar to that described in
+	the perl FAQ except it returns a shuffled list instead of
+	modifying an array passed by reference
+
+Change 632 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+	Handle tied variables passed for the number to dualvar()
+	Preserve number type (IV/UV/NV) in dualvar()
+
+Change 631 on 2001/08/31 by <gbarr@pobox.com> (Graham Barr)
+
+	Handle eval{} inside of the code blocks for first and reduce
+
+Change 629 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
+
+	perl5.004 does not like exit from within a BEGIN, it core dumps
+
+Change 628 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
+
+	Fix stack problem in first() and reduce()
+	Align with core dist
+
+Change 483 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
+
+	Release 1.02
+
 Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
 
 	Check for SvMAGICAL on argument for reftype and blessed
diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index 0ea2e54..07d703f 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -14,6 +14,18 @@
 #    define PERL_SUBVERSION	SUBVERSION
 #endif
 
+#ifndef aTHX
+#  define aTHX
+#endif
+
+#if PERL_VERSION < 6
+#    define NV double
+#endif
+
+#ifndef Drand01
+#    define Drand01()		((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
+#endif
+
 #if PERL_VERSION < 5
 #  ifndef gv_stashpvn
 #    define gv_stashpvn(n,l,c) gv_stashpv(n,c)
@@ -163,6 +175,11 @@ CODE:
     HV *stash;
     CV *cv;
     OP *reducecop;
+    PERL_CONTEXT *cx;
+    SV** newsp;
+    I32 gimme = G_SCALAR;
+    bool oldcatch = CATCH_GET;
+
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
@@ -179,6 +196,8 @@ CODE:
     SAVETMPS;
     SAVESPTR(PL_op);
     ret = ST(1);
+    CATCH_SET(TRUE);
+    PUSHBLOCK(cx, CXt_SUB, SP);
     for(index = 2 ; index < items ; index++) {
 	GvSV(agv) = ret;
 	GvSV(bgv) = ST(index);
@@ -186,7 +205,9 @@ CODE:
 	CALLRUNOPS(aTHX);
 	ret = *PL_stack_sp;
     }
-    ST(0) = ret;
+    ST(0) = sv_mortalcopy(ret);
+    POPBLOCK(cx,PL_curpm);
+    CATCH_SET(oldcatch);
     XSRETURN(1);
 }
 
@@ -201,6 +222,11 @@ CODE:
     HV *stash;
     CV *cv;
     OP *reducecop;
+    PERL_CONTEXT *cx;
+    SV** newsp;
+    I32 gimme = G_SCALAR;
+    bool oldcatch = CATCH_GET;
+
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
@@ -213,18 +239,56 @@ CODE:
     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
     SAVETMPS;
     SAVESPTR(PL_op);
+    CATCH_SET(TRUE);
+    PUSHBLOCK(cx, CXt_SUB, SP);
     for(index = 1 ; index < items ; index++) {
 	GvSV(PL_defgv) = ST(index);
 	PL_op = reducecop;
 	CALLRUNOPS(aTHX);
 	if (SvTRUE(*PL_stack_sp)) {
 	  ST(0) = ST(index);
+	  POPBLOCK(cx,PL_curpm);
+	  CATCH_SET(oldcatch);
 	  XSRETURN(1);
 	}
     }
+    POPBLOCK(cx,PL_curpm);
+    CATCH_SET(oldcatch);
     XSRETURN_UNDEF;
 }
 
+void
+shuffle(...)
+PROTOTYPE: @
+CODE:
+{
+    int index;
+    struct op dmy_op;
+    struct op *old_op = PL_op;
+    SV *my_pad[2];
+    SV **old_curpad = PL_curpad;
+
+    /* We call pp_rand here so that Drand01 get initialized if rand()
+       or srand() has not already been called
+    */
+    my_pad[1] = sv_newmortal();
+    memzero((char*)(&dmy_op), sizeof(struct op));
+    dmy_op.op_targ = 1;
+    PL_op = &dmy_op;
+    PL_curpad = (SV **)&my_pad;
+    pp_rand();
+    PL_op = old_op;
+    PL_curpad = old_curpad;
+    for (index = items ; index > 1 ; ) {
+	int swap = (int)(Drand01() * (double)(index--));
+	SV *tmp = ST(swap);
+	ST(swap) = ST(index);
+	ST(index) = tmp;
+    }
+    XSRETURN(items);
+}
+
+
 MODULE=List::Util	PACKAGE=Scalar::Util
 
 void
@@ -239,10 +303,17 @@ CODE:
     ST(0) = sv_newmortal();
     (void)SvUPGRADE(ST(0),SVt_PVNV);
     sv_setpvn(ST(0),ptr,len);
-    if(SvNOKp(num) || !SvIOKp(num)) {
+    if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 	SvNVX(ST(0)) = SvNV(num);
 	SvNOK_on(ST(0));
     }
+#ifdef SVf_IVisUV
+    else if (SvUOK(num)) {
+	SvUVX(ST(0)) = SvUV(num);
+	SvIOK_on(ST(0));
+	SvIsUV_on(ST(0));
+    }
+#endif
     else {
 	SvIVX(ST(0)) = SvIV(num);
 	SvIOK_on(ST(0));
diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm
index cb64584..818f5d7 100644
--- a/ext/List/Util/lib/List/Util.pm
+++ b/ext/List/Util/lib/List/Util.pm
@@ -10,8 +10,8 @@ require Exporter;
 require DynaLoader;
 
 our @ISA       = qw(Exporter DynaLoader);
-our @EXPORT_OK = qw(first min max minstr maxstr reduce sum);
-our $VERSION   = "1.02_00";
+our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
+our $VERSION   = "1.03_00";
 
 bootstrap List::Util $VERSION;
 
@@ -128,6 +128,10 @@ element is returned and BLOCK is not executed.
     $foo = reduce { $a + $b } 1 .. 10               # sum
     $foo = reduce { $a . $b } @bar                  # concat
 
+=item shuffle LIST
+
+Returns the elements of LIST in a random order
+
 =item sum LIST
 
 Returns the sum of all the elements in LIST.
diff --git a/ext/List/Util/t/blessed.t b/ext/List/Util/t/blessed.t
index 89a740a..84e29da 100755
--- a/ext/List/Util/t/blessed.t
+++ b/ext/List/Util/t/blessed.t
@@ -1,11 +1,16 @@
+#!./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 Scalar::Util qw(blessed);
diff --git a/ext/List/Util/t/dualvar.t b/ext/List/Util/t/dualvar.t
index 5bf4fe9..4b17354 100755
--- a/ext/List/Util/t/dualvar.t
+++ b/ext/List/Util/t/dualvar.t
@@ -1,25 +1,33 @@
+#!./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 vars qw($skip);
+
 BEGIN {
   require Scalar::Util;
 
   if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
     print "1..0\n";
-    exit;
+    $skip=1;
   }
 }
 
+eval <<'EOT' unless $skip;
 use Scalar::Util qw(dualvar);
 
-print "1..6\n";
+print "1..11\n";
 
 $var = dualvar 2.2,"string";
 
@@ -44,3 +52,30 @@ print "ok 5\n";
 
 print "not " unless $var2 eq "string";
 print "ok 6\n";
+
+my $numstr = "10.2";
+my $numtmp = sprintf("%d", $numstr);
+$var = dualvar $numstr, "";
+print "not " unless $var == $numstr;
+print "ok 7\n";
+
+$var = dualvar 1<<31, "";
+print "not " unless $var == 1<<31;
+print "ok 8\n";
+print "not " unless $var > 0;
+print "ok 9\n";
+
+tie my $tied, 'Tied';
+$var = dualvar $tied, "ok";
+print "not " unless $var == 7.5;
+print "ok 10\n";
+print "not " unless $var eq "ok";
+print "ok 11\n";
+
+EOT
+
+package Tied;
+
+sub TIESCALAR { bless {} }
+sub FETCH { 7.5 }
+
diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t
index 6a35948..ee22780 100755
--- a/ext/List/Util/t/first.t
+++ b/ext/List/Util/t/first.t
@@ -1,16 +1,21 @@
+#!./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 List::Util qw(first);
 
-print "1..4\n";
+print "1..7\n";
 
 print "not " unless defined &first;
 print "ok 1\n";
@@ -23,3 +28,16 @@ print "ok 3\n";
 
 print "not " if defined(first { 0 });
 print "ok 4\n";
+
+my $foo = first { $_->[1] le "e" and "e" le $_->[2] }
+		[qw(a b c)], [qw(d e f)], [qw(g h i)];
+print "not " unless $foo->[0] eq 'd';
+print "ok 5\n";
+
+# Check that eval{} inside the block works correctly
+my $i = 0;
+print "not " unless 5 == first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
+print "ok 6\n";
+
+print "not " if defined eval { first { die if $_ } 0,0,1 };
+print "ok 7\n";
diff --git a/ext/List/Util/t/max.t b/ext/List/Util/t/max.t
index 911003b..2e0193a 100755
--- a/ext/List/Util/t/max.t
+++ b/ext/List/Util/t/max.t
@@ -1,13 +1,19 @@
+#!./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 List::Util qw(max);
 
 print "1..5\n";
diff --git a/ext/List/Util/t/maxstr.t b/ext/List/Util/t/maxstr.t
index 0ec35ca..c2725a2 100755
--- a/ext/List/Util/t/maxstr.t
+++ b/ext/List/Util/t/maxstr.t
@@ -1,13 +1,19 @@
+#!./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 List::Util qw(maxstr);
 
 print "1..5\n";
diff --git a/ext/List/Util/t/min.t b/ext/List/Util/t/min.t
index a51ced4..6f2d0e8 100755
--- a/ext/List/Util/t/min.t
+++ b/ext/List/Util/t/min.t
@@ -1,13 +1,19 @@
+#!./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 List::Util qw(min);
 
 print "1..5\n";
diff --git a/ext/List/Util/t/minstr.t b/ext/List/Util/t/minstr.t
index c000e78..31f69a9 100755
--- a/ext/List/Util/t/minstr.t
+++ b/ext/List/Util/t/minstr.t
@@ -1,13 +1,19 @@
+#!./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 List::Util qw(minstr);
 
 print "1..5\n";
diff --git a/ext/List/Util/t/readonly.t b/ext/List/Util/t/readonly.t
index 864e1f1..a72d788 100644
--- a/ext/List/Util/t/readonly.t
+++ b/ext/List/Util/t/readonly.t
@@ -1,15 +1,21 @@
+#!./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 Scalar::Util qw(readonly);
 
+
 print "1..9\n";
 
 print "not " unless readonly(1);
diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t
index 063e0b7..2721d15 100755
--- a/ext/List/Util/t/reduce.t
+++ b/ext/List/Util/t/reduce.t
@@ -1,16 +1,22 @@
+#!./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 List::Util qw(reduce min);
 
-print "1..5\n";
+print "1..8\n";
 
 print "not " if defined reduce {};
 print "ok 1\n";
@@ -28,3 +34,19 @@ print "ok 4\n";
 @a = map { pack("C", int(rand(256))) } 0 .. 20;
 print "not " unless join("",@a) eq reduce { $a . $b } @a;
 print "ok 5\n";
+
+sub add {
+  my($aa, $bb) = @_;
+  return $aa + $bb;
+}
+
+my $sum = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
+print "not " unless $sum == 6;
+print "ok 6\n";
+
+# Check that eval{} inside the block works correctly
+print "not " unless 10 == reduce { eval { die }; $a + $b } 0,1,2,3,4;
+print "ok 7\n";
+
+print "not " if defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
+print "ok 8\n";
diff --git a/ext/List/Util/t/reftype.t b/ext/List/Util/t/reftype.t
index ea7ea7b..470b72a 100755
--- a/ext/List/Util/t/reftype.t
+++ b/ext/List/Util/t/reftype.t
@@ -1,13 +1,19 @@
+#!./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 Scalar::Util qw(reftype);
 use vars qw($t $y $x *F);
 use Symbol qw(gensym);
diff --git a/ext/List/Util/t/shuffle.t b/ext/List/Util/t/shuffle.t
new file mode 100755
index 0000000..e416415
--- /dev/null
+++ b/ext/List/Util/t/shuffle.t
@@ -0,0 +1,40 @@
+#!./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 List::Util qw(shuffle);
+
+print "1..5\n";
+
+my @r;
+
+@r = shuffle();
+print "not " if @r;
+print "ok 1\n";
+
+@r = shuffle(9);
+print "not " unless @r == 1 and $r[0] = 9;
+print "ok 2\n";
+
+my @in = 1..100;
+@r = shuffle(@in);
+print "not " unless @r == @in;
+print "ok 3\n";
+
+print "not " if join("",@r) eq join("",@in);
+print "ok 4\n";
+
+print "not " if join("",sort { $a <=> $b } @r) ne join("",@in);
+print "ok 5\n";
diff --git a/ext/List/Util/t/sum.t b/ext/List/Util/t/sum.t
index 34fb690..6cd7ea3 100755
--- a/ext/List/Util/t/sum.t
+++ b/ext/List/Util/t/sum.t
@@ -1,13 +1,19 @@
+#!./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 List::Util qw(sum);
 
 print "1..3\n";
diff --git a/ext/List/Util/t/tainted.t b/ext/List/Util/t/tainted.t
index 5587bb7..a330b1f 100644
--- a/ext/List/Util/t/tainted.t
+++ b/ext/List/Util/t/tainted.t
@@ -1,20 +1,23 @@
 #!./perl -T
 
 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 lib qw(blib/lib blib/arch);
 use Scalar::Util qw(tainted);
 use Config;
 
-print "1..5\n";
+print "1..4\n";
 
 print "not " if tainted(1);
 print "ok 1\n";
@@ -33,6 +36,3 @@ print "ok 3\n";
 
 print "not " unless tainted($ENV{$key});
 print "ok 4\n";
-
-print "not " if @ARGV and not tainted($ARGV[0]);
-print "ok 5\n";
diff --git a/ext/List/Util/t/weak.t b/ext/List/Util/t/weak.t
index 6c7bea7..7941205 100755
--- a/ext/List/Util/t/weak.t
+++ b/ext/List/Util/t/weak.t
@@ -1,19 +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 vars qw($skip);
+
 BEGIN {
   $|=1;
   require Scalar::Util;
   if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
     print("1..0\n");
-    exit;
+    $skip=1;
   }
 
   $DEBUG = 0;
@@ -26,6 +33,7 @@ BEGIN {
   }
 }
 
+eval <<'EOT' unless $skip;
 use Scalar::Util qw(weaken isweak);
 print "1..17\n";
 
@@ -204,3 +212,4 @@ sub DESTROY {
 	print "# INCFLAG\n";
 	${$_[0]{Flag}} ++;
 }
+EOT