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:
#define PERL_NO_GET_CONTEXT /* we want efficiency */
+#define PERL_EXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
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);
}
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);
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;
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 :
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++) {
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
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
));
}
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
+ )
);
}
}
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:
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.
# 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)],
);
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';
if (!@_) {
delete @^H{ values(%feature) };
$^H &= ~ $hint_uni8bit;
+ @^H{ values(%default_feature) } = (1) x keys %default_feature;
return;
}
next;
}
if (!exists($feature{$name})) {
+ if (!exists $default_feature{$name}) {
unknown_feature($name);
+ }
+ $^H{$default_feature{$name}} = 1; next;
}
else {
delete $^H{$feature{$name}};
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) {
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. */
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) {
#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
#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)
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
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;
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
#!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;
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 " );
}
{
* 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;
}
/*