sort/multicall patch

Message-ID: <20051029203307.GA8869@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@25953

10 files changed, 193 insertions, 96 deletions

diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index 0c6a14dd8e..44b8122c41 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -7,6 +7,8 @@
 #include <perl.h>
 #include <XSUB.h>
 
+#include "multicall.h"
+
 #ifndef PERL_VERSION
 #    include <patchlevel.h>
 #    if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
@@ -127,6 +129,10 @@ sv_tainted(SV *sv)
 #define dVAR dNOOP
 #endif
 
+#ifndef GvSVn
+#  define GvSVn GvSV
+#endif
+
 MODULE=List::Util	PACKAGE=List::Util
 
 void
@@ -230,52 +236,32 @@ reduce(block,...)
 PROTOTYPE: &@
 CODE:
 {
-    dVAR;
+    dVAR; dMULTICALL;
     SV *ret = sv_newmortal();
     int index;
     GV *agv,*bgv,*gv;
     HV *stash;
-    CV *cv;
-    OP *reducecop;
-    PERL_CONTEXT *cx;
-    SV** newsp;
     I32 gimme = G_SCALAR;
-    U8 hasargs = 0;
-    bool oldcatch = CATCH_GET;
+    SV **args = &PL_stack_base[ax];
 
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
+    cv = sv_2cv(block, &stash, &gv, 0);
+    PUSH_MULTICALL;
     agv = gv_fetchpv("a", TRUE, SVt_PV);
     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);
-    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
-    PAD_SET_CUR(CvPADLIST(cv),1);
-#else
-    SAVESPTR(PL_curpad);
-    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
-    SAVETMPS;
-    SAVESPTR(PL_op);
-    SvSetSV(ret, ST(1));
-    CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_SUB, SP);
-    PUSHSUB(cx);
+    SvSetSV(ret, args[1]);
     for(index = 2 ; index < items ; index++) {
-	GvSV(bgv) = ST(index);
-	PL_op = reducecop;
-	CALLRUNOPS(aTHX);
+	GvSV(bgv) = args[index];
+	MULTICALL;
 	SvSetSV(ret, *PL_stack_sp);
     }
+    POP_MULTICALL;
     ST(0) = ret;
-    POPBLOCK(cx,PL_curpm);
-    CATCH_SET(oldcatch);
     XSRETURN(1);
 }
 
@@ -285,51 +271,30 @@ first(block,...)
 PROTOTYPE: &@
 CODE:
 {
-    dVAR;
+    dVAR; dMULTICALL;
     int index;
     GV *gv;
     HV *stash;
-    CV *cv;
-    OP *reducecop;
-    PERL_CONTEXT *cx;
-    SV** newsp;
     I32 gimme = G_SCALAR;
-    U8 hasargs = 0;
-    bool oldcatch = CATCH_GET;
+    SV **args = &PL_stack_base[ax];
 
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
-    SAVESPTR(GvSV(PL_defgv));
     cv = sv_2cv(block, &stash, &gv, 0);
-    reducecop = CvSTART(cv);
-    SAVESPTR(CvROOT(cv)->op_ppaddr);
-    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
-    PAD_SET_CUR(CvPADLIST(cv),1);
-#else
-    SAVESPTR(PL_curpad);
-    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
-    SAVETMPS;
-    SAVESPTR(PL_op);
-    CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_SUB, SP);
-    PUSHSUB(cx);
+    PUSH_MULTICALL;
+    SAVESPTR(GvSV(PL_defgv));
 
     for(index = 1 ; index < items ; index++) {
-	GvSV(PL_defgv) = ST(index);
-	PL_op = reducecop;
-	CALLRUNOPS(aTHX);
+	GvSV(PL_defgv) = args[index];
+	MULTICALL;
 	if (SvTRUE(*PL_stack_sp)) {
+	  POP_MULTICALL;
 	  ST(0) = ST(index);
-	  POPBLOCK(cx,PL_curpm);
-	  CATCH_SET(oldcatch);
 	  XSRETURN(1);
 	}
     }
-    POPBLOCK(cx,PL_curpm);
-    CATCH_SET(oldcatch);
+    POP_MULTICALL;
     XSRETURN_UNDEF;
 }
 
@@ -538,14 +503,20 @@ CODE:
 
 BOOT:
 {
+    HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
+    GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
+    SV *rmcsv;
 #if !defined(SvWEAKREF) || !defined(SvVOK)
-    HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
-    GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+    HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
+    GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
     AV *varav;
     if (SvTYPE(vargv) != SVt_PVGV)
-	gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
+	gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
     varav = GvAVn(vargv);
 #endif
+    if (SvTYPE(rmcgv) != SVt_PVGV)
+	gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
+    rmcsv = GvSVn(rmcgv);
 #ifndef SvWEAKREF
     av_push(varav, newSVpv("weaken",6));
     av_push(varav, newSVpv("isweak",6));
@@ -553,4 +524,9 @@ BOOT:
 #ifndef SvVOK
     av_push(varav, newSVpv("isvstring",9));
 #endif
+#ifdef REAL_MULTICALL
+    sv_setsv(rmcsv, &PL_sv_yes);
+#else
+    sv_setsv(rmcsv, &PL_sv_no);
+#endif
 }
diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm
index 55696ad279..c73b964c00 100644
--- a/ext/List/Util/lib/List/Util.pm
+++ b/ext/List/Util/lib/List/Util.pm
@@ -10,7 +10,7 @@ require Exporter;
 
 @ISA        = qw(Exporter);
 @EXPORT_OK  = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION    = "1.17";
+$VERSION    = "1.18";
 $XS_VERSION = $VERSION;
 $VERSION    = eval $VERSION;
 
diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm
index 36476b3479..3655164eb4 100644
--- a/ext/List/Util/lib/Scalar/Util.pm
+++ b/ext/List/Util/lib/Scalar/Util.pm
@@ -11,7 +11,7 @@ require List::Util; # List::Util loads the XS
 
 @ISA       = qw(Exporter);
 @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
-$VERSION    = "1.17";
+$VERSION    = "1.18";
 $VERSION   = eval $VERSION;
 
 sub export_fail {
@@ -67,10 +67,15 @@ sub blessed ($) {
 
 sub refaddr($) {
   my $pkg = ref($_[0]) or return undef;
-  bless $_[0], 'Scalar::Util::Fake';
+  if (blessed($_[0])) {
+    bless $_[0], 'Scalar::Util::Fake';
+  }
+  else {
+    $pkg = undef;
+  }
   "$_[0]" =~ /0x(\w+)/;
   my $i = do { local $^W; hex $1 };
-  bless $_[0], $pkg;
+  bless $_[0], $pkg if defined $pkg;
   $i;
 }
 
diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t
index 784437cb64..a4c9261530 100755
--- a/ext/List/Util/t/first.t
+++ b/ext/List/Util/t/first.t
@@ -13,8 +13,9 @@ BEGIN {
     }
 }
 
-use Test::More tests => 8;
 use List::Util qw(first);
+use Test::More;
+plan tests => ($::PERL_ONLY ? 15 : 17);
 my $v;
 
 ok(defined &first,	'defined');
@@ -45,4 +46,69 @@ sub foobar {  first { !defined(wantarray) || wantarray } "not ","not ","not " }
 ($v) = foobar();
 is($v, undef, 'wantarray');
 
+# Can we leave the sub with 'return'?
+$v = first {return ($_>6)} 2,4,6,12;
+is($v, 12, 'return');
 
+# ... even in a loop?
+$v = first {while(1) {return ($_>6)} } 2,4,6,12;
+is($v, 12, 'return from loop');
+
+# Does it work from another package?
+{ package Foo;
+  ::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package');
+}
+
+# Can we undefine a first sub while it's running?
+sub self_immolate {undef &self_immolate; 1}
+eval { $v = first \&self_immolate, 1,2; };
+like($@, qr/^Can't undef active subroutine/, "undef active sub");
+
+# Redefining an active sub should not fail, but whether the
+# redefinition takes effect immediately depends on whether we're
+# running the Perl or XS implementation.
+
+sub self_updating { local $^W; *self_updating = sub{1} ;1}
+eval { $v = first \&self_updating, 1,2; };
+is($@, '', 'redefine self');
+
+{ my $failed = 0;
+
+    sub rec { my $n = shift;
+        if (!defined($n)) {  # No arg means we're being called by first()
+            return 1; }
+        if ($n<5) { rec($n+1); }
+        else { $v = first \&rec, 1,2; }
+        $failed = 1 if !defined $n;
+    }
+
+    rec(1);
+    ok(!$failed, 'from active sub');
+}
+
+# Calling a sub from first should leave its refcount unchanged.
+SKIP: {
+    skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
+    sub huge {$_>1E6}
+    my $refcnt = &Internals::SvREFCNT(\&huge);
+    $v = first \&huge, 1..6;
+    is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
+}
+
+# The remainder of the tests are only relevant for the XS
+# implementation. The Perl-only implementation behaves differently
+# (and more flexibly) in a way that we can't emulate from XS.
+if (!$::PERL_ONLY) { SKIP: {
+
+    skip("Poor man's MULTICALL can't cope", 2)
+      if !$List::Util::REAL_MULTICALL;
+
+    # Can we goto a label from the 'first' sub?
+    eval {()=first{goto foo} 1,2; foo: 1};
+    like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
+
+    # Can we goto a subroutine?
+    eval {()=first{goto sub{}} 1,2;};
+    like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
+
+} }
diff --git a/ext/List/Util/t/p_first.t b/ext/List/Util/t/p_first.t
index 2fd67b0a99..1928ef2a8f 100644
--- a/ext/List/Util/t/p_first.t
+++ b/ext/List/Util/t/p_first.t
@@ -4,4 +4,5 @@
 sub List::Util::bootstrap {}
 
 (my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
 do $f;
diff --git a/ext/List/Util/t/p_reduce.t b/ext/List/Util/t/p_reduce.t
index 2fd67b0a99..1928ef2a8f 100644
--- a/ext/List/Util/t/p_reduce.t
+++ b/ext/List/Util/t/p_reduce.t
@@ -4,4 +4,5 @@
 sub List::Util::bootstrap {}
 
 (my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
 do $f;
diff --git a/ext/List/Util/t/p_tainted.t b/ext/List/Util/t/p_tainted.t
index 6196729daf..7b00ebd984 100644
--- a/ext/List/Util/t/p_tainted.t
+++ b/ext/List/Util/t/p_tainted.t
@@ -3,32 +3,5 @@
 # force perl-only version to be tested
 sub List::Util::bootstrap {}
 
-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 Test::More tests => 4;
-
-use Scalar::Util qw(tainted);
-
-ok( !tainted(1), 'constant number');
-
-my $var = 2;
-
-ok( !tainted($var), 'known variable');
-
-my $key = (keys %ENV)[0];
-
-ok( tainted($ENV{$key}),	'environment variable');
-
-$var = $ENV{$key};
-ok( tainted($var),	'copy of environment variable');
+(my $f = __FILE__) =~ s/p_//;
+do "./$f";
diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t
index 689ff52120..786aaffea6 100755
--- a/ext/List/Util/t/reduce.t
+++ b/ext/List/Util/t/reduce.t
@@ -15,7 +15,8 @@ BEGIN {
 
 
 use List::Util qw(reduce min);
-use Test::More tests => 14;
+use Test::More;
+plan tests => ($::PERL_ONLY ? 21 : 23);
 
 my $v = reduce {};
 
@@ -70,3 +71,71 @@ $a = 8; $b = 9;
 $v = reduce { $a * $b } 1,2,3;
 is( $a, 8, 'restore $a');
 is( $b, 9, 'restore $b');
+
+# Can we leave the sub with 'return'?
+$v = reduce {return $a+$b} 2,4,6;
+is($v, 12, 'return');
+
+# ... even in a loop?
+$v = reduce {while(1) {return $a+$b} } 2,4,6;
+is($v, 12, 'return from loop');
+
+# Does it work from another package?
+{ package Foo;
+  $a = $b;
+  ::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package');
+}
+
+# Can we undefine a reduce sub while it's running?
+sub self_immolate {undef &self_immolate; 1}
+eval { $v = reduce \&self_immolate, 1,2; };
+like($@, qr/^Can't undef active subroutine/, "undef active sub");
+
+# Redefining an active sub should not fail, but whether the
+# redefinition takes effect immediately depends on whether we're
+# running the Perl or XS implementation.
+
+sub self_updating { local $^W; *self_updating = sub{1} ;1 }
+eval { $v = reduce \&self_updating, 1,2; };
+is($@, '', 'redefine self');
+
+{ my $failed = 0;
+
+    sub rec { my $n = shift;
+        if (!defined($n)) {  # No arg means we're being called by reduce()
+            return 1; }
+        if ($n<5) { rec($n+1); }
+        else { $v = reduce \&rec, 1,2; }
+        $failed = 1 if !defined $n;
+    }
+
+    rec(1);
+    ok(!$failed, 'from active sub');
+}
+
+# Calling a sub from reduce should leave its refcount unchanged.
+SKIP: {
+    skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
+    sub mult {$a*$b}
+    my $refcnt = &Internals::SvREFCNT(\&mult);
+    $v = reduce \&mult, 1..6;
+    is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
+}
+
+# The remainder of the tests are only relevant for the XS
+# implementation. The Perl-only implementation behaves differently
+# (and more flexibly) in a way that we can't emulate from XS.
+if (!$::PERL_ONLY) { SKIP: {
+
+    skip("Poor man's MULTICALL can't cope", 2)
+      if !$List::Util::REAL_MULTICALL;
+
+    # Can we goto a label from the reduction sub?
+    eval {()=reduce{goto foo} 1,2; foo: 1};
+    like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
+
+    # Can we goto a subroutine?
+    eval {()=reduce{goto sub{}} 1,2;};
+    like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
+
+} }
diff --git a/ext/List/Util/t/refaddr.t b/ext/List/Util/t/refaddr.t
index d4dfcd70f1..61a33d32ea 100755
--- a/ext/List/Util/t/refaddr.t
+++ b/ext/List/Util/t/refaddr.t
@@ -14,7 +14,7 @@ BEGIN {
 }
 
 
-use Test::More tests => 19;
+use Test::More tests => 29;
 
 use Scalar::Util qw(refaddr);
 use vars qw($t $y $x *F $v $r);
@@ -32,10 +32,13 @@ foreach $r ({}, \$t, [], \*F, sub {}) {
   my $n = "$r";
   $n =~ /0x(\w+)/;
   my $addr = do { local $^W; hex $1 };
+  my $before = ref($r);
   is( refaddr($r), $addr, $n);
+  is( ref($r), $before, $n);
 
   my $obj = bless $r, 'FooBar';
   is( refaddr($r), $addr, "blessed with overload $n");
+  is( ref($r), 'FooBar', $n);
 }
 
 {
diff --git a/ext/List/Util/t/tainted.t b/ext/List/Util/t/tainted.t
index 2e9c641e02..09ad330684 100644
--- a/ext/List/Util/t/tainted.t
+++ b/ext/List/Util/t/tainted.t
@@ -11,6 +11,9 @@ BEGIN {
 	    exit 0;
 	}
     }
+    elsif(!grep {/blib/} @INC) {
+      unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
+    }
 }
 
 use Test::More tests => 4;