diff options
| -rw-r--r-- | feature.h | 117 | ||||
| -rw-r--r-- | gv.c | 4 | ||||
| -rw-r--r-- | lib/feature.pm | 25 | ||||
| -rw-r--r-- | mg.c | 13 | ||||
| -rw-r--r-- | pod/perlvar.pod | 10 | ||||
| -rwxr-xr-x | regen/feature.pl | 71 | ||||
| -rw-r--r-- | t/lib/feature/bits | 3 |
7 files changed, 183 insertions, 60 deletions
@@ -190,6 +190,123 @@ S_enable_feature_bundle(pTHX_ SV *ver) } #endif /* PERL_IN_OP_C */ +#ifdef PERL_IN_MG_C + +#define magic_sethint_feature(keysv, keypv, keylen, valsv, valbool) \ + S_magic_sethint_feature(aTHX_ (keysv), (keypv), (keylen), (valsv), (valbool)) +PERL_STATIC_INLINE void +S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, + SV *valsv, bool valbool) { + if (keysv) + keypv = SvPV_const(keysv, keylen); + + if (memBEGINs(keypv, keylen, "feature_")) { + const char *subf = keypv + (sizeof("feature_")-1); + U32 mask = 0; + switch (*subf) { + case '_': + if (keylen == sizeof("feature___SUB__")-1 + && memcmp(subf+1, "_SUB__", keylen - sizeof("feature_")) == 0) { + mask = FEATURE___SUB___BIT; + break; + } + return; + + case 'b': + if (keylen == sizeof("feature_bitwise")-1 + && memcmp(subf+1, "itwise", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_BITWISE_BIT; + break; + } + return; + + case 'e': + if (keylen == sizeof("feature_evalbytes")-1 + && memcmp(subf+1, "valbytes", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_EVALBYTES_BIT; + break; + } + return; + + case 'f': + if (keylen == sizeof("feature_fc")-1 + && memcmp(subf+1, "c", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_FC_BIT; + break; + } + return; + + case 'm': + if (keylen == sizeof("feature_myref")-1 + && memcmp(subf+1, "yref", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_MYREF_BIT; + break; + } + return; + + case 'p': + if (keylen == sizeof("feature_postderef_qq")-1 + && memcmp(subf+1, "ostderef_qq", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_POSTDEREF_QQ_BIT; + break; + } + return; + + case 'r': + if (keylen == sizeof("feature_refaliasing")-1 + && memcmp(subf+1, "efaliasing", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_REFALIASING_BIT; + break; + } + return; + + case 's': + if (keylen == sizeof("feature_say")-1 + && memcmp(subf+1, "ay", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_SAY_BIT; + break; + } + else if (keylen == sizeof("feature_signatures")-1 + && memcmp(subf+1, "ignatures", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_SIGNATURES_BIT; + break; + } + else if (keylen == sizeof("feature_state")-1 + && memcmp(subf+1, "tate", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_STATE_BIT; + break; + } + else if (keylen == sizeof("feature_switch")-1 + && memcmp(subf+1, "witch", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_SWITCH_BIT; + break; + } + return; + + case 'u': + if (keylen == sizeof("feature_unicode")-1 + && memcmp(subf+1, "nicode", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_UNICODE_BIT; + break; + } + else if (keylen == sizeof("feature_unieval")-1 + && memcmp(subf+1, "nieval", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_UNIEVAL_BIT; + break; + } + return; + + default: + return; + } + if (valsv ? SvTRUE(valsv) : valbool) + PL_compiling.cop_features |= mask; + else + PL_compiling.cop_features &= ~mask; + } +} +#endif /* PERL_IN_MG_C */ + #endif /* PERL_FEATURE_H_ */ /* ex: set ro: */ @@ -2069,10 +2069,6 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (memEQs(name, len, "\005NCODING")) goto magicalize; break; - case '\006': - if (memEQs(name, len, "\006EATURE_BITS")) - goto magicalize; - break; case '\007': /* $^GLOBAL_PHASE */ if (memEQs(name, len, "\007LOBAL_PHASE")) goto ro_magicalize; diff --git a/lib/feature.pm b/lib/feature.pm index 607ec11002..c81a35fb3b 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -5,7 +5,7 @@ package feature; -our $VERSION = '1.56'; +our $VERSION = '1.57'; our %feature = ( fc => 'feature_fc', @@ -23,23 +23,6 @@ our %feature = ( unicode_strings => 'feature_unicode', ); - -my %feature_bits = ( - bitwise => 0x0001, - current_sub => 0x0002, - declared_refs => 0x0004, - evalbytes => 0x0008, - fc => 0x0010, - postderef_qq => 0x0020, - refaliasing => 0x0040, - say => 0x0080, - signatures => 0x0100, - state => 0x0200, - switch => 0x0400, - unicode_eval => 0x0800, - unicode_strings => 0x1000, -); - our %feature_bundle = ( "5.10" => [qw(say state switch)], "5.11" => [qw(say state switch unicode_strings)], @@ -503,16 +486,13 @@ sub __common { my $bundle_number = $^H & $hint_mask; my $features = $bundle_number != $hint_mask && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; - my $bits = ${^FEATURE_BITS}; if ($features) { # Features are enabled implicitly via bundle hints. # Delete any keys that may be left over from last time. delete @^H{ values(%feature) }; - $bits = 0; $^H |= $hint_mask; for (@$features) { $^H{$feature{$_}} = 1; - $bits |= $feature_bits{$_}; $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; } } @@ -540,15 +520,12 @@ sub __common { } if ($import) { $^H{$feature{$name}} = 1; - $bits |= $feature_bits{$name}; $^H |= $hint_uni8bit if $name eq 'unicode_strings'; } else { delete $^H{$feature{$name}}; - $bits &= ~$feature_bits{$name}; $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; } } - ${^FEATURE_BITS} = $bits; } sub unknown_feature { @@ -41,6 +41,7 @@ tie. #include "EXTERN.h" #define PERL_IN_MG_C #include "perl.h" +#include "feature.h" #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) # ifdef I_GRP @@ -1029,9 +1030,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (nextchar == '\0') { sv_setiv(sv, (IV)PL_maxsysfd); } - else if (strEQ(remaining, "EATURE_BITS")) { - sv_setuv(sv, PL_compiling.cop_features); - } break; case '\007': /* ^GLOBAL_PHASE */ if (strEQ(remaining, "LOBAL_PHASE")) { @@ -2886,9 +2884,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (mg->mg_ptr[1] == '\0') { PL_maxsysfd = SvIV(sv); } - else if (strEQ(mg->mg_ptr + 1, "EATURE_BITS")) { - PL_compiling.cop_features = SvUV(sv); - } break; case '\010': /* ^H */ { @@ -3680,6 +3675,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); + magic_sethint_feature(key, NULL, 0, sv, 0); return 0; } @@ -3704,6 +3700,10 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) MUTABLE_SV(mg->mg_ptr), 0, 0) : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), mg->mg_ptr, mg->mg_len, 0, 0)); + if (mg->mg_len == HEf_SVKEY) + magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); + else + magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE); return 0; } @@ -3722,6 +3722,7 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); cophh_free(CopHINTHASH_get(&PL_compiling)); CopHINTHASH_set(&PL_compiling, cophh_new_empty()); + CLEARFEATUREBITS(); return 0; } diff --git a/pod/perlvar.pod b/pod/perlvar.pod index dd73343a22..930b823857 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -2068,16 +2068,6 @@ function. This variable was added in Perl 5.8.2 and removed in 5.26.0. Setting it to anything other than C<undef> was made fatal in Perl 5.28.0. -=item ${^FEATURE_BITS} -X<${^FEATURE_BITS}> - -The current set of features enabled by the C<use feature> pragma. It -has the same scoping as the C<$^H> and C<%^H> variables. The exact -values are considered internal to the L<feature> pragma and may change -between versions of Perl. - -This variable was added in Perl v5.32.0. - =item ${^GLOBAL_PHASE} X<${^GLOBAL_PHASE}> diff --git a/regen/feature.pl b/regen/feature.pl index 1fcebb3f0b..efecebbee8 100755 --- a/regen/feature.pl +++ b/regen/feature.pl @@ -189,12 +189,6 @@ for(sort { length $a <=> length $b || $a cmp $b } keys %feature) { } print $pm ");\n\n"; -print $pm "\nmy %feature_bits = (\n"; -for (sort keys %feature_bits) { - printf $pm " %-*s => %#06x,\n", $width, $_, $feature_bits{$_}; -} -print $pm ");\n\n"; - print $pm "our %feature_bundle = (\n"; my $bund_width = length longest values %UniqueBundles; for( sort { $UniqueBundles{$a} cmp $UniqueBundles{$b} } @@ -404,6 +398,63 @@ print $h <<EOJ; } #endif /* PERL_IN_OP_C */ +#ifdef PERL_IN_MG_C + +#define magic_sethint_feature(keysv, keypv, keylen, valsv, valbool) \\ + S_magic_sethint_feature(aTHX_ (keysv), (keypv), (keylen), (valsv), (valbool)) +PERL_STATIC_INLINE void +S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, + SV *valsv, bool valbool) { + if (keysv) + keypv = SvPV_const(keysv, keylen); + + if (memBEGINs(keypv, keylen, "feature_")) { + const char *subf = keypv + (sizeof("feature_")-1); + U32 mask = 0; + switch (*subf) { +EOJ + +my %pref; +for my $key (sort values %feature) { + push @{$pref{substr($key, 0, 1)}}, $key; +} + +for my $pref (sort keys %pref) { + print $h <<EOS; + case '$pref': +EOS + my $first = 1; + for my $subkey (@{$pref{$pref}}) { + my $rest = substr($subkey, 1); + my $if = $first ? "if" : "else if"; + print $h <<EOJ; + $if (keylen == sizeof("feature_$subkey")-1 + && memcmp(subf+1, "$rest", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_\U${subkey}\E_BIT; + break; + } +EOJ + + $first = 0; + } + print $h <<EOS; + return; + +EOS +} + +print $h <<EOJ; + default: + return; + } + if (valsv ? SvTRUE(valsv) : valbool) + PL_compiling.cop_features |= mask; + else + PL_compiling.cop_features &= ~mask; + } +} +#endif /* PERL_IN_MG_C */ + #endif /* PERL_FEATURE_H_ */ EOJ @@ -416,7 +467,7 @@ read_only_bottom_close_and_rename($h); __END__ package feature; -our $VERSION = '1.56'; +our $VERSION = '1.57'; FEATURES @@ -798,16 +849,13 @@ sub __common { my $bundle_number = $^H & $hint_mask; my $features = $bundle_number != $hint_mask && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; - my $bits = ${^FEATURE_BITS}; if ($features) { # Features are enabled implicitly via bundle hints. # Delete any keys that may be left over from last time. delete @^H{ values(%feature) }; - $bits = 0; $^H |= $hint_mask; for (@$features) { $^H{$feature{$_}} = 1; - $bits |= $feature_bits{$_}; $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; } } @@ -835,15 +883,12 @@ sub __common { } if ($import) { $^H{$feature{$name}} = 1; - $bits |= $feature_bits{$name}; $^H |= $hint_uni8bit if $name eq 'unicode_strings'; } else { delete $^H{$feature{$name}}; - $bits &= ~$feature_bits{$name}; $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; } } - ${^FEATURE_BITS} = $bits; } sub unknown_feature { diff --git a/t/lib/feature/bits b/t/lib/feature/bits index 3be679f7f0..227f852c2c 100644 --- a/t/lib/feature/bits +++ b/t/lib/feature/bits @@ -2,7 +2,6 @@ Test specifically for things that cop_features broke __END__ # NAME check clearing $^H clears the bits -# TODO this is broken use feature 'say'; BEGIN { %^H = () } say "Fail"; @@ -13,7 +12,6 @@ syntax error at - line 3, near "say "Fail"" Execution of - aborted due to compilation errors. ######## # NAME check copying $^H restores the bits -# TODO this isn't fixed yet use feature 'say'; say "Hello"; BEGIN { our %work = %^H; } @@ -36,7 +34,6 @@ syntax error at - line 4, near "say "Goodbye"" Execution of - aborted due to compilation errors. ######## # NAME check deleting entries (bypass feature.pm) clears the bits -# TODO this doesn't work yet use feature 'say'; say "Hello"; BEGIN { delete $^H{feature_say}; } |