Disable $[ under 5.16

This adds the array_base feature to feature.pm

Perl_feature_is_enabled has been modified to use PL_curcop, rather
than PL_hintgv, so it can work with run-time hints as well.
(PL_curcop holds the current state op at run time, and &PL_compiling
at compile time, so it works for both.)  The hints in $^H are not
stored in the same place at compile time and run time, so the FEATURE_IS_ENABLED macro has been modified to check first whether
PL_curop == &PL_compiling.

Since array_base is on by default with no hint for it in %^H, it is
a ‘negative’ feature, whose entry in %^H turns it off.  feature.pm
has been modified to support such negative features.  The new FEATURE_IS_ENABLED_d can check whether such default features
are enabled.

This does make things less efficient, as every version declaration
now loads feature.pm to disable all features (including turning off
array_base, which entails adding an entry to %^H) before loading the
new bundle.  I have plans to make this more efficient.

13 files changed, 165 insertions, 47 deletions

diff --git a/embed.fnc b/embed.fnc
index e96e660864..3b81d3fc28 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2572,6 +2572,7 @@ Anop	|void	|clone_params_del|NN CLONE_PARAMS *param
 op	|void	|populate_isa	|NN const char *name|STRLEN len|...
 
 : Used in keywords.c and toke.c
-op	|bool	|feature_is_enabled|NN const char *const name|STRLEN namelen
+Xop	|bool	|feature_is_enabled|NN const char *const name \
+		|STRLEN namelen|bool negate
 
 : ex: set ts=8 sts=4 sw=4 noet:
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
index 861b322380..936e29a426 100644
--- a/ext/arybase/arybase.xs
+++ b/ext/arybase/arybase.xs
@@ -1,4 +1,5 @@
 #define PERL_NO_GET_CONTEXT     /* we want efficiency */
+#define PERL_EXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
@@ -102,9 +103,11 @@ STATIC SV * ab_hint(pTHX_ const bool create) {
  return *val;
 }
 
+/* current base at compile time */
 STATIC IV current_base(pTHX) {
 #define current_base() current_base(aTHX)
  SV *hsv = ab_hint(0);
+ assert(FEATURE_IS_ENABLED_d("$["));
  if (!hsv || !SvOK(hsv)) return 0;
  return SvIV(hsv);
 }
@@ -170,7 +173,7 @@ STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) {
 
 STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
  o = (*ab_old_ck_sassign)(aTHX_ o);
- if (o->op_type == OP_SASSIGN) {
+ if (o->op_type == OP_SASSIGN && FEATURE_IS_ENABLED_d("$[")) {
   OP *right = cBINOPx(o)->op_first;
   OP *left = right->op_sibling;
   if (left) ab_process_assignment(left, right);
@@ -180,7 +183,7 @@ STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
 
 STATIC OP *ab_ck_aassign(pTHX_ OP *o) {
  o = (*ab_old_ck_aassign)(aTHX_ o);
- if (o->op_type == OP_AASSIGN) {
+ if (o->op_type == OP_AASSIGN && FEATURE_IS_ENABLED_d("$[")) {
   OP *right = cBINOPx(o)->op_first;
   OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
   right = cBINOPx(right)->op_first->op_sibling;
@@ -349,6 +352,7 @@ static OP *ab_ck_base(pTHX_ OP *o)
       PL_op->op_type);
  }
  o = (*old_ck)(aTHX_ o);
+ if (!FEATURE_IS_ENABLED_d("$[")) return o;
  /* We need two switch blocks, as the type may have changed. */
  switch (o->op_type) {
  case OP_AELEM    :
@@ -392,6 +396,7 @@ PROTOTYPES: DISABLE
 BOOT:
 {
     GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
+    sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */
     tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
 
     if (!ab_initialized++) {
@@ -420,18 +425,24 @@ BOOT:
 void
 FETCH(...)
     PREINIT:
-	SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
+	SV *ret = FEATURE_IS_ENABLED_d("$[")
+		   ? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
+		   : 0;
     PPCODE:
-	if (!SvOK(ret)) mXPUSHi(0);
+	if (!ret || !SvOK(ret)) mXPUSHi(0);
 	else XPUSHs(ret);
 
 void
 STORE(SV *sv, IV newbase)
-    PREINIT:
-	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
     CODE:
+      if (FEATURE_IS_ENABLED_d("$[")) {
+	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
+	Perl_sv_dump(aTHX_ cop_hints_fetch_pvs(PL_curcop, "feature_no$[",0));
 	if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
 	Perl_croak(aTHX_ "That use of $[ is unsupported");
+      }
+      else if (newbase)
+	Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
 
 
 MODULE = arybase	PACKAGE = arybase::mg
@@ -443,11 +454,13 @@ FETCH(SV *sv)
 	if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
 	    Perl_croak(aTHX_ "Not a SCALAR reference");
 	{
-	    SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
+	    SV *base = FEATURE_IS_ENABLED_d("$[")
+			 ? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
+			 : 0;
 	    SvGETMAGIC(SvRV(sv));
 	    if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
 	    mXPUSHi(adjust_index_r(
-		SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
+		SvIV_nomg(SvRV(sv)), base&&SvOK(base)?SvIV(base):0
 	    ));
 	}
 
@@ -457,12 +470,16 @@ STORE(SV *sv, SV *newbase)
 	if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
 	    Perl_croak(aTHX_ "Not a SCALAR reference");
 	{
-	    SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
+	    SV *base = FEATURE_IS_ENABLED_d("$[")
+			? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
+			: 0;
 	    SvGETMAGIC(newbase);
 	    if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
 	    else 
 		sv_setiv_mg(
 		   SvRV(sv),
-		   adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
+		   adjust_index(
+		      SvIV_nomg(newbase), base&&SvOK(base)?SvIV(base):0
+		   )
 		);
 	}
diff --git a/gv.c b/gv.c
index 2af41a87c4..37a1bd9510 100644
--- a/gv.c
+++ b/gv.c
@@ -1939,11 +1939,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    }
 	    goto magicalize;
 	case '[':		/* $[ */
-	    if (sv_type == SVt_PV || sv_type == SVt_PVGV) {
+	    if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+	     && FEATURE_IS_ENABLED_d("$[")) {
 		if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
 		require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
 		addmg = 0;
 	    }
+	    else goto magicalize;
             break;
 	case '\023':	/* $^S */
 	ro_magicalize:
diff --git a/lib/feature.pm b/lib/feature.pm
index a89bc8b066..fb6c3d2ed7 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -13,6 +13,11 @@ my %feature = (
     unicode_strings => 'feature_unicode',
 );
 
+# These work backwards--the presence of the hint elem disables the feature:
+my %default_feature = (
+    array_base      => 'feature_no$[',
+);
+
 # This gets set (for now) in $^H as well as in %^H,
 # for runtime speed of the uc/lc/ucfirst/lcfirst functions.
 # See HINT_UNI_8_BIT in perl.h.
@@ -21,9 +26,9 @@ our $hint_uni8bit = 0x00000800;
 # NB. the latest bundle must be loaded by the -E switch (see toke.c)
 
 our %feature_bundle = (
-    "default" => [],
-    "5.10" => [qw(say state switch)],
-    "5.11" => [qw(say state switch unicode_strings)],
+    "default" => [keys %default_feature],
+    "5.10" => [qw(say state switch array_base)],
+    "5.11" => [qw(say state switch unicode_strings array_base)],
     "5.15" => [qw(say state switch unicode_strings unicode_eval
                   evalbytes current_sub)],
 );
@@ -294,7 +299,10 @@ sub import {
             next;
         }
         if (!exists $feature{$name}) {
+	  if (!exists $default_feature{$name}) {
             unknown_feature($name);
+	  }
+	  delete $^H{$default_feature{$name}}; next;
         }
         $^H{$feature{$name}} = 1;
         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
@@ -308,6 +316,7 @@ sub unimport {
     if (!@_) {
         delete @^H{ values(%feature) };
         $^H &= ~ $hint_uni8bit;
+	@^H{ values(%default_feature) } = (1) x keys %default_feature;
         return;
     }
 
@@ -325,7 +334,10 @@ sub unimport {
             next;
         }
         if (!exists($feature{$name})) {
+	  if (!exists $default_feature{$name}) {
             unknown_feature($name);
+	  }
+	  $^H{$default_feature{$name}} = 1; next;
         }
         else {
             delete $^H{$feature{$name}};
diff --git a/mg.c b/mg.c
index c55ca63a58..3432dfe5c4 100644
--- a/mg.c
+++ b/mg.c
@@ -2749,6 +2749,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    PL_ors_sv = NULL;
 	}
 	break;
+    case '[':
+	if (SvIV(sv) != 0)
+	    Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
+	break;
     case '?':
 #ifdef COMPLEX_STATUS
 	if (PL_localizing == 2) {
diff --git a/op.c b/op.c
index 313087d34a..812ece2bb1 100644
--- a/op.c
+++ b/op.c
@@ -4672,17 +4672,13 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
     if (use_version) {
 	HV * const hinthv = GvHV(PL_hintgv);
 	const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
+	SV *importsv;
 
 	/* Turn features off */
-	if (hhoff)
-	    /* avoid loading feature.pm */
-	    PL_hints &= ~HINT_UNI_8_BIT;
-	else {
-	    ENTER_with_name("load_feature");
-	    Perl_load_module(aTHX_
+	ENTER_with_name("load_feature");
+	Perl_load_module(aTHX_
 		PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL
-	    );
-	}
+	);
 
 	/* If we request a version >= 5.9.5, load feature.pm with the
 	 * feature bundle that corresponds to the required version. */
@@ -4690,13 +4686,12 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 
 	if (vcmp(use_version,
 		 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
-	    SV *const importsv = vnormal(use_version);
-	    if (hhoff) ENTER_with_name("load_feature");
+	    importsv = vnormal(use_version);
 	    *SvPVX_mutable(importsv) = ':';
-	    Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
-	    LEAVE_with_name("load_feature");
 	}
-	else if (!hhoff) LEAVE_with_name("load_feature");
+	else importsv = newSVpvs(":default");
+	Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+	LEAVE_with_name("load_feature");
 	/* If a version >= 5.11.0 is requested, strictures are on by default! */
 	if (vcmp(use_version,
 		 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
diff --git a/perl.h b/perl.h
index e203dfe194..ef3d4efec6 100644
--- a/perl.h
+++ b/perl.h
@@ -5745,10 +5745,15 @@ extern void moncontrol(int);
 #define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII
 
-#ifdef PERL_CORE
+#if defined(PERL_CORE) || defined(PERL_EXT)
 #  define FEATURE_IS_ENABLED(name)				        \
-	((0 != (PL_hints & HINT_LOCALIZE_HH))				\
-	    && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
+	(((PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints) \
+	   & HINT_LOCALIZE_HH)						\
+	    && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name), 0))
+#  define FEATURE_IS_ENABLED_d(name)				        \
+	(!((PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints) \
+	    & HINT_LOCALIZE_HH)						\
+	    || Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name), 1))
 /* The longest string we pass in.  */
 #  define MAX_FEATURE_LEN (sizeof("unicode_strings")-1)
 #endif
diff --git a/proto.h b/proto.h
index 92befdac8a..eec052f413 100644
--- a/proto.h
+++ b/proto.h
@@ -990,7 +990,7 @@ PERL_CALLCONV char*	Perl_fbm_instr(pTHX_ unsigned char* big, unsigned char* bige
 #define PERL_ARGS_ASSERT_FBM_INSTR	\
 	assert(big); assert(bigend); assert(littlestr)
 
-PERL_CALLCONV bool	Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
+PERL_CALLCONV bool	Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen, bool negate)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_FEATURE_IS_ENABLED	\
 	assert(name)
diff --git a/t/lib/feature/bundle b/t/lib/feature/bundle
index 05708e538e..7e1479f4e3 100644
--- a/t/lib/feature/bundle
+++ b/t/lib/feature/bundle
@@ -78,3 +78,22 @@ EXPECT
 custom sub
 custom sub
 custom sub
+########
+# :default and $[
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+no feature;
+use feature ":default";
+$[ = 1;
+print qw[a b c][2], "\n";
+use feature ":5.16"; # should not disable anything; no feature does that
+print qw[a b c][2], "\n";
+no feature;
+print qw[a b c][2], "\n";
+use feature ":5.16";
+print qw[a b c][2], "\n";
+EXPECT
+Use of assignment to $[ is deprecated at - line 4.
+b
+b
+c
+c
diff --git a/t/lib/feature/implicit b/t/lib/feature/implicit
index e2ae95a19d..010ce8c628 100644
--- a/t/lib/feature/implicit
+++ b/t/lib/feature/implicit
@@ -25,11 +25,12 @@ say defined $INC{"feature.pm"} ? "Helloworld" : "Good bye";
 EXPECT
 Helloworld
 ########
-# VERSION requirement, doesn't call feature->import for < 5.9.5
+# VERSION requirement, imports :default feature for < 5.9.5
 BEGIN { ++$INC{"feature.pm"} }
-sub feature::import { print "improting\n" }
+sub feature::import { print $_[1], "\n" }
 use 5.8.8;
 EXPECT
+:default
 ########
 # VERSION requirement, doesn't load anything with require
 require 5.9.5;
@@ -78,3 +79,35 @@ EXPECT
 yes
 evalbytes sub
 say sub
+########
+# No $[ under 5.15
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use v5.14;
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+use v5.15;
+print qw[a b c][2], "\n";
+EXPECT
+b
+c
+########
+# $[ under < 5.10
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use feature 'say'; # make sure it is loaded and modifies %^H; we are test-
+use v5.8.8;        # ing to make sure it does not disable $[
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+b
+########
+# $[ under < 5.10 after use v5.15
+# SKIP ? not defined DynaLoader::boot_DynaLoader
+use v5.15;
+use v5.8.8;
+no warnings 'deprecated';
+$[ = 1;
+print qw[a b c][2], "\n";
+EXPECT
+b
diff --git a/t/op/array_base.t b/t/op/array_base.t
index 34404d491f..a276240c37 100644
--- a/t/op/array_base.t
+++ b/t/op/array_base.t
@@ -1,17 +1,40 @@
 #!perl -w
 use strict;
-no warnings 'deprecated';
 
 BEGIN {
  require './test.pl';
- skip_all_if_miniperl();
+
+ plan (tests => my $tests = 11);
+
+ # Run these at BEGIN time, before arybase loads
+ use v5.15;
+ is(eval('$[ = 1; 123'), undef);
+ like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/);
+
+ if (is_miniperl()) {
+   # skip the rest
+   SKIP: { skip ("no arybase.xs on miniperl", $tests-2) }
+   exit;
+ }
 }
 
-plan (tests => 4);
+no warnings 'deprecated';
 
 is(eval('$['), 0);
 is(eval('$[ = 0; 123'), 123);
 is(eval('$[ = 1; 123'), 123);
+$[ = 1;
 ok $INC{'arybase.pm'};
 
+use v5.15;
+is(eval('$[ = 1; 123'), undef);
+like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/);
+is $[, 0, '$[ is 0 under 5.16';
+$_ = "hello";
+/l/g;
+my $pos = \pos;
+is $$pos, 3;
+$$pos = 1;
+is $$pos, 1;
+
 1;
diff --git a/t/op/override.t b/t/op/override.t
index be39cf9330..b38c3938a1 100644
--- a/t/op/override.t
+++ b/t/op/override.t
@@ -49,13 +49,12 @@ is( $r, "Foo.pm" );
 eval "use Foo::Bar";
 is( $r, join($dirsep, "Foo", "Bar.pm") );
 
-# Under PERL_UNICODE, %^H is set, causing Perl_utilize to require
-# feature.pm after 5.006, in order to turn off features.  Stop that
-# from interfering with this test by unsetting HINT_LOCALIZE_HH.
+# use VERSION also loads feature.pm.
 {
-    BEGIN { $^H &= ~0x00020000 } # HINT_LOCALIZE_HH
+    my @r;
+    local *CORE::GLOBAL::require = sub { push @r, shift; 1; };
     eval "use 5.006";
-    is( $r, "5.006" );
+    like( " @r ", qr " 5\.006 " );
 }
 
 {
diff --git a/toke.c b/toke.c
index 2c29c582e2..2f395d458d 100644
--- a/toke.c
+++ b/toke.c
@@ -599,19 +599,27 @@ S_missingterm(pTHX_ char *s)
  * Check whether the named feature is enabled.
  */
 bool
-Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
+Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen,
+			      bool negate)
 {
     dVAR;
-    HV * const hinthv = GvHV(PL_hintgv);
     char he_name[8 + MAX_FEATURE_LEN] = "feature_";
 
     PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
 
     if (namelen > MAX_FEATURE_LEN)
 	return FALSE;
-    memcpy(&he_name[8], name, namelen);
-
-    return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
+    if (negate) he_name[8] = 'n', he_name[9] = 'o';
+    memcpy(&he_name[8 + 2*negate], name, namelen);
+
+    return
+	(
+	    cop_hints_fetch_pvn(
+		PL_curcop, he_name, 8 + 2*negate + namelen, 0, 0
+	    )
+	    != &PL_sv_placeholder
+	)
+	!= negate;
 }
 
 /*