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.

diff --git a/embed.fnc b/embed.fnc
index e96e660..3b81d3f 100644 (file)
--- 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 861b322..936e29a 100644 (file)
--- 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 2af41a8..37a1bd9 100644 (file)
--- 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 a89bc8b..fb6c3d2 100644 (file)
--- 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 c55ca63..3432dfe 100644 (file)
--- 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 313087d..812ece2 100644 (file)
--- 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 e203dfe..ef3d4ef 100644 (file)
--- 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 92befda..eec052f 100644 (file)
--- 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 05708e5..7e1479f 100644 (file)
--- 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 e2ae95a..010ce8c 100644 (file)
--- 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 34404d4..a276240 100644 (file)
--- 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 be39cf9..b38c393 100644 (file)
--- 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 2c29c58..2f395d4 100644 (file)
--- 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;
 }
 
 /*