Update to Scalar-List-Utils 1.08

p4raw-id: //depot/perl@18076

9 files changed, 240 insertions, 16 deletions

diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog
index 934643ace1..89e33e91d9 100644
--- a/ext/List/Util/ChangeLog
+++ b/ext/List/Util/ChangeLog
@@ -1,3 +1,39 @@
+Change 757 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
+
+	Add XS_VERSION
+
+Change 756 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
+
+	Use PAD_* macros in 5.9
+	Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad
+
+Change 751 on 2002/10/18 by <gbarr@pobox.com> (Graham Barr)
+
+	Fix context so that sub for reduce/first  is always in a scalar context
+	Fix sum/min/max so that they dont upgrade thier argumetns to NVs
+	if they are IV or UV
+
+Change 750 on 2002/10/14 by <gbarr@pobox.com> (Graham Barr)
+
+	Add isvstring()
+
+Change 745 on 2002/09/23 by <gbarr@pobox.com> (Graham Barr)
+
+	Scalar::Util
+	- Add refaddr()
+
+Change 722 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
+
+	Release 1.0701
+
+Change 721 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
+
+	Add comment to README about failing tests on perl5.6.0
+
+Change 714 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
+
+	Release 1.07
+
 Change 713 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
 
 	Add Scalar::Util::openhandle()
diff --git a/ext/List/Util/README b/ext/List/Util/README
index 2e5aba9095..e384354d40 100644
--- a/ext/List/Util/README
+++ b/ext/List/Util/README
@@ -27,6 +27,12 @@ This distribution provides
   dualvar
   shuffle
 
-Copyright (c) 1997-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
+KNOWN BUGS
+
+There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
+show up as tests 8 and 9 of dualvar.t failing
+
+
+Copyright (c) 1997-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
 This library is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself.
diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index c26c484057..0b080c515f 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -43,6 +43,12 @@ my_cxinc(pTHX)
 #    define NV double
 #endif
 
+#ifdef SVf_IVisUV
+#  define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIOK_UV(sv) ? SvUVX(sv) : SvIVX(sv) : SvNV(sv))
+#else
+#  define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIVX(sv) : SvNV(sv))
+#endif
+
 #ifndef Drand01
 #    define Drand01()		((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
 #endif
@@ -90,6 +96,10 @@ sv_tainted(SV *sv)
 #  endif
 #endif
 
+#ifndef PTR2IV
+#  define PTR2IV(ptr) (IV)(ptr)
+#endif
+
 MODULE=List::Util	PACKAGE=List::Util
 
 void
@@ -107,10 +117,10 @@ CODE:
 	XSRETURN_UNDEF;
     }
     retsv = ST(0);
-    retval = SvNV(retsv);
+    retval = slu_sv_value(retsv);
     for(index = 1 ; index < items ; index++) {
 	SV *stacksv = ST(index);
-	NV val = SvNV(stacksv);
+	NV val = slu_sv_value(stacksv);
 	if(val < retval ? !ix : ix) {
 	    retsv = stacksv;
 	    retval = val;
@@ -127,13 +137,16 @@ sum(...)
 PROTOTYPE: @
 CODE:
 {
+    SV *sv;
     int index;
     if(!items) {
 	XSRETURN_UNDEF;
     }
-    RETVAL = SvNV(ST(0));
+    sv = ST(0);
+    RETVAL = slu_sv_value(sv);
     for(index = 1 ; index < items ; index++) {
-	RETVAL += SvNV(ST(index));
+	sv = ST(index);
+	RETVAL += slu_sv_value(sv);
     }
 }
 OUTPUT:
@@ -199,6 +212,7 @@ CODE:
     PERL_CONTEXT *cx;
     SV** newsp;
     I32 gimme = G_SCALAR;
+    I32 hasargs = 0;
     bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
@@ -222,7 +236,10 @@ CODE:
     SAVESPTR(PL_op);
     ret = ST(1);
     CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_NULL, SP);
+    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);
@@ -250,6 +267,7 @@ CODE:
     PERL_CONTEXT *cx;
     SV** newsp;
     I32 gimme = G_SCALAR;
+    I32 hasargs = 0;
     bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
@@ -269,7 +287,11 @@ CODE:
     SAVETMPS;
     SAVESPTR(PL_op);
     CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_NULL, SP);
+    PUSHBLOCK(cx, CXt_SUB, SP);
+    PUSHSUB(cx);
+    if (!CvDEPTH(cv))
+        (void)SvREFCNT_inc(cv);
+
     for(index = 1 ; index < items ; index++) {
 	GvSV(PL_defgv) = ST(index);
 	PL_op = reducecop;
@@ -380,6 +402,20 @@ CODE:
 OUTPUT:
     RETVAL
 
+IV
+refaddr(sv)
+    SV * sv
+PROTOTYPE: $
+CODE:
+{
+    if(!SvROK(sv)) {
+	XSRETURN_UNDEF;
+    }
+    RETVAL = PTR2IV(SvRV(sv));
+}
+OUTPUT:
+    RETVAL
+
 void
 weaken(sv)
 	SV *sv
@@ -421,16 +457,34 @@ CODE:
 OUTPUT:
   RETVAL
 
+void
+isvstring(sv)
+       SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvVOK
+  ST(0) = boolSV(SvVOK(sv));
+  XSRETURN(1);
+#else
+	croak("vstrings are not implemented in this release of perl");
+#endif
+
+
 BOOT:
 {
-#ifndef SvWEAKREF
+#if !defined(SvWEAKREF) || !defined(SvVOK)
     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
     AV *varav;
     if (SvTYPE(vargv) != SVt_PVGV)
 	gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
     varav = GvAVn(vargv);
+#endif
+#ifndef SvWEAKREF
     av_push(varav, newSVpv("weaken",6));
     av_push(varav, newSVpv("isweak",6));
 #endif
+#ifndef SvVOK
+    av_push(varav, newSVpv("isvstring",9));
+#endif
 }
diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm
index 7686ffe82c..8975b10094 100644
--- a/ext/List/Util/lib/List/Util.pm
+++ b/ext/List/Util/lib/List/Util.pm
@@ -9,11 +9,11 @@ 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.07_00";
+our @ISA        = qw(Exporter DynaLoader);
+our @EXPORT_OK  = qw(first min max minstr maxstr reduce sum shuffle);
+our $VERSION    = "1.08_00";
 our $XS_VERSION = $VERSION;
-$VERSION = eval $VERSION;
+$VERSION    = eval $VERSION;
 
 bootstrap List::Util $XS_VERSION;
 
diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm
index e518a4c445..fd881ad587 100644
--- a/ext/List/Util/lib/Scalar/Util.pm
+++ b/ext/List/Util/lib/Scalar/Util.pm
@@ -10,7 +10,7 @@ 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);
+our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring);
 our $VERSION   = $List::Util::VERSION;
 
 sub openhandle ($) {
@@ -41,7 +41,7 @@ Scalar::Util - A selection of general-utility scalar subroutines
 
 =head1 SYNOPSIS
 
-    use Scalar::Util qw(blessed dualvar isweak readonly reftype tainted weaken);
+    use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken);
 
 =head1 DESCRIPTION
 
@@ -78,6 +78,14 @@ value STRING in a string context.
     $num = $foo + 2;                    # 12
     $str = $foo . " world";             # Hello world
 
+=item isvstring EXPR
+
+If EXPR is a scalar which was coded as a vstring the result is true.
+
+    $vs   = v49.46.48;
+    $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
+    printf($fmt,$vs);
+
 =item isweak EXPR
 
 If EXPR is a scalar which is a weak reference the result is true.
@@ -106,6 +114,18 @@ Returns true if SCALAR is readonly.
     $readonly = foo($bar);              # false
     $readonly = foo(0);                 # true
 
+=item refaddr EXPR
+
+If EXPR evaluates to a reference the internal memory address of
+the referenced value is returned. Otherwise C<undef> is returned.
+
+    $addr = refaddr "string";           # undef
+    $addr = refaddr \$var;              # eg 12345678
+    $addr = refaddr [];                 # eg 23456784
+
+    $obj  = bless {}, "Foo";
+    $addr = refaddr $obj;               # eg 88123488
+
 =item reftype EXPR
 
 If EXPR evaluates to a reference the type of the variable referenced
diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t
index ee227807c8..d6a919d028 100755
--- a/ext/List/Util/t/first.t
+++ b/ext/List/Util/t/first.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use List::Util qw(first);
 
-print "1..7\n";
+print "1..8\n";
 
 print "not " unless defined &first;
 print "ok 1\n";
@@ -41,3 +41,10 @@ print "ok 6\n";
 
 print "not " if defined eval { first { die if $_ } 0,0,1 };
 print "ok 7\n";
+
+($x) = foobar();
+$x = '' unless defined $x;
+print "${x}ok 8\n";
+
+sub foobar {  first { !defined(wantarray) || wantarray } "not ","not ","not " }
+
diff --git a/ext/List/Util/t/isvstring.t b/ext/List/Util/t/isvstring.t
new file mode 100644
index 0000000000..bd70b63ebf
--- /dev/null
+++ b/ext/List/Util/t/isvstring.t
@@ -0,0 +1,41 @@
+#!./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;
+	}
+    }
+    $|=1;
+    require Scalar::Util;
+    if (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) {
+	print("1..0\n");
+	exit 0;
+    }
+}
+
+use Scalar::Util qw(isvstring);
+
+print "1..4\n";
+
+print "ok 1\n";
+
+$vs = 49.46.48;
+
+print "not " unless $vs == "1.0";
+print "ok 2\n";
+
+print "not " unless isvstring($vs);
+print "ok 3\n";
+
+$sv = "1.0";
+print "not " if isvstring($sv);
+print "ok 4\n";
+
+
+
diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t
index 2721d15fb0..4af711de9d 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..8\n";
+print "1..9\n";
 
 print "not " if defined reduce {};
 print "ok 1\n";
@@ -50,3 +50,9 @@ 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";
+
+($x) = foobar();
+print "${x}ok 9\n";
+
+sub foobar { reduce { (defined(wantarray) && !wantarray) ? '' : 'not ' } 0,1,2,3 }
+
diff --git a/ext/List/Util/t/refaddr.t b/ext/List/Util/t/refaddr.t
new file mode 100755
index 0000000000..efb962ccc1
--- /dev/null
+++ b/ext/List/Util/t/refaddr.t
@@ -0,0 +1,54 @@
+#!./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(refaddr);
+use vars qw($t $y $x *F $v $r);
+use Symbol qw(gensym);
+
+# Ensure we do not trigger and tied methods
+tie *F, 'MyTie';
+
+print "1..13\n";
+
+my $i = 1;
+foreach $v (undef, 10, 'string') {
+  print "not " if defined refaddr($v);
+  print "ok ",$i++,"\n";
+}
+
+foreach $r ({}, \$t, [], \*F, sub {}) {
+  my $addr = $r + 0;
+  print "not " unless refaddr($r) == $addr;
+  print "ok ",$i++,"\n";
+  my $obj = bless $r, 'FooBar';
+  print "not " unless refaddr($r) == $addr;
+  print "ok ",$i++,"\n";
+}
+
+package FooBar;
+
+use overload  '0+' => sub { 10 },
+		'+' => sub { 10 + $_[1] };
+
+package MyTie;
+
+sub TIEHANDLE { bless {} }
+sub DESTROY {}
+
+sub AUTOLOAD {
+  warn "$AUTOLOAD called";
+  exit 1; # May be in an eval
+}