Allow stash elems to be array refs

These turn into CVs that return the contents of the array.  Future
commits will make constant.pm use these and also make them inlinable.

Even without inlining, these subs are faster, because they are XSUBs:

$ time ./perl -Ilib -e 'my @a=1..1000000; sub foo { @a } () = foo for 1..10'

real	0m3.725s
user	0m3.407s
sys	0m0.227s
$ time ./perl -Ilib -e 'my @a=1..1000000; BEGIN { $::{foo} = \@a } () = foo for 1..10'

real	0m2.153s
user	0m1.949s
sys	0m0.121s

diff --git a/gv.c b/gv.c
index 8449047..067847c 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -154,7 +154,7 @@ Perl_gv_const_sv(pTHX_ GV *gv)
 
     if (SvTYPE(gv) == SVt_PVGV)
        return cv_const_sv(GvCVu(gv));
-    return SvROK(gv) ? SvRV(gv) : NULL;
+    return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
 }
 
 GP *
@@ -346,7 +346,6 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     if (has_constant) {
        /* The constant has to be a simple scalar type.  */
        switch (SvTYPE(has_constant)) {
-       case SVt_PVAV:
        case SVt_PVHV:
        case SVt_PVCV:
        case SVt_PVFM:

diff --git a/op.c b/op.c
index cfbe11c..f9ca03f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6845,6 +6845,7 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
 }
 
 static void const_sv_xsub(pTHX_ CV* cv);
+static void const_av_xsub(pTHX_ CV* cv);
 
 /*
 
@@ -6863,12 +6864,15 @@ L<perlsub/"Constant Functions">.
 SV *
 Perl_cv_const_sv(pTHX_ const CV *const cv)
 {
+    SV *sv;
     PERL_UNUSED_CONTEXT;
     if (!cv)
        return NULL;
     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
        return NULL;
-    return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
+    sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
+    if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
+    return sv;
 }
 
 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
@@ -7850,7 +7854,11 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
        and so doesn't get free()d.  (It's expected to be from the C pre-
        processor __FILE__ directive). But we need a dynamically allocated one,
        and we need it to get freed.  */
-    cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+    cv = newXS_len_flags(name, len,
+                        sv && SvTYPE(sv) == SVt_PVAV
+                            ? const_av_xsub
+                            : const_sv_xsub,
+                        file ? file : "", "",
                         &sv, XS_DYNAMIC_FILENAME | flags);
     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
     CvCONST_on(cv);
@@ -11966,6 +11974,31 @@ const_sv_xsub(pTHX_ CV* cv)
     XSRETURN(1);
 }
 
+static void
+const_av_xsub(pTHX_ CV* cv)
+{
+    dVAR;
+    dXSARGS;
+    AV * const av = MUTABLE_AV(XSANY.any_ptr);
+    SP -= items;
+    assert(av);
+#ifndef DEBUGGING
+    if (!av) {
+       XSRETURN(0);
+    }
+#endif
+    if (SvRMAGICAL(av))
+       Perl_croak(aTHX_ "Magical list constants are not supported");
+    if (GIMME_V != G_ARRAY) {
+       EXTEND(SP, 1);
+       ST(0) = newSViv((IV)AvFILLp(av)+1);
+       XSRETURN(1);
+    }
+    EXTEND(SP, AvFILLp(av)+1);
+    Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
+    XSRETURN(AvFILLp(av)+1);
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 5165599..e48a556 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2804,6 +2804,12 @@ foo :lvalue;> declaration before the definition.
 
 See also L<attributes.pm|attributes>.
 
+=item Magical list constants are not supported
+
+(F) You assigned a magical array to a stash element, and then tried
+to use the subroutine from the same slot.  You are asking Perl to do
+something it cannot do, details subject to change between Perl versions.
+
 =item Malformed integer in [] in pack
 
 (F) Between the brackets enclosing a numeric repeat count only digits

diff --git a/t/op/gv.t b/t/op/gv.t
index 2358392..deb92f3 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 245 );
+plan( tests => 250 );
 
 # type coercion on assignment
 $foo = 'foo';
@@ -494,6 +494,14 @@ is (ref \$::{oonk}, 'GLOB', "This export does affect original");
 is (eval 'biff', "Value", "Constant has correct value");
 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
 
+$::{yarrow} = [4,5,6];
+is join("-", eval "yarrow()"), '4-5-6', 'array ref as stash elem';
+is ref $::{yarrow}, "ARRAY", 'stash elem is still array ref after use';
+is join("-", eval "&yarrow"), '4-5-6', 'calling const list with &';
+is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args';
+is prototype "yarrow", "", 'const list has "" prototype';
+is eval "yarrow", 3, 'const list in scalar cx returns length';
+
 {
     use vars qw($glook $smek $foof);
     # Check reference assignment isn't affected by the SV type (bug #38439)
@@ -516,7 +524,7 @@ is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
 format =
 .
 
-foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
     # IO::Handle, which isn't what we want.
     my $type = $value;

diff --git a/t/uni/gv.t b/t/uni/gv.t
index f128ec5..90a6332 100644 (file)
--- a/t/uni/gv.t
+++ b/t/uni/gv.t
@@ -14,7 +14,7 @@ use utf8;
 use open qw( :utf8 :std );
 use warnings;
 
-plan( tests => 212 );
+plan( tests => 211 );
 
 # type coersion on assignment
 $ᕘ = 'ᕘ';
@@ -503,7 +503,7 @@ no warnings 'once';
 format =
 .
     
-    foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+    foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
         # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
         # IO::Handle, which isn't what we want.
         my $type = $value;