From e4a57a577b746f91fca47676996280f5a3818efa Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 23 Aug 2023 14:52:20 +1000 Subject: [PATCH 1/2] features: populate cop_features from a hints hash the hard way I originally optimised populating cop_features for eval by storing the hints mask in "feature/bits" and then fetching that when re-populating the hints for eval. But that has turned out to be too fragile, so iterate over the possible feature keys and populate cop_features from that. I could perhaps have avoided this cost by ensuring "feature/bits" was set where else it was needed, but this code already iterates to build the hints hash, iterating again doesn't increase the scale of the work we're doing. --- feature.h | 172 ++++++++++++++++++++++++++++++++++++++++++++--- op.c | 1 - regen/feature.pl | 54 ++++++++++++--- 3 files changed, 208 insertions(+), 19 deletions(-) diff --git a/feature.h b/feature.h index c862864a063e..2e1d83f6d7ea 100644 --- a/feature.h +++ b/feature.h @@ -227,14 +227,7 @@ #define CLEARFEATUREBITS() (PL_compiling.cop_features = 0) -#define STOREFEATUREBITSHH(hh) \ - (hv_stores((hh), "feature/bits", newSVuv(PL_compiling.cop_features))) - -#define FETCHFEATUREBITSHH(hh) \ - STMT_START { \ - SV **fbsv = hv_fetchs((hh), "feature/bits", FALSE); \ - PL_compiling.cop_features = fbsv ? SvUV(*fbsv) : 0; \ - } STMT_END +#define FETCHFEATUREBITSHH(hh) S_fetch_feature_bits_hh(aTHX_ (hh)) #endif /* PERL_CORE or PERL_EXT */ @@ -275,7 +268,7 @@ S_enable_feature_bundle(pTHX_ SV *ver) } #endif /* PERL_IN_OP_C */ -#ifdef PERL_IN_MG_C +#if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_CTL_C) #define magic_sethint_feature(keysv, keypv, keylen, valsv, valbool) \ S_magic_sethint_feature(aTHX_ (keysv), (keypv), (keylen), (valsv), (valbool)) @@ -449,6 +442,167 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, } #endif /* PERL_IN_MG_C */ +/* subject to change */ +struct perl_feature_bit { + const char *name; + STRLEN namelen; + U32 mask; +}; + +#ifdef PERL_IN_PP_CTL_C + +static const struct perl_feature_bit +PL_feature_bits[] = { + { + /* feature bareword_filehandles */ + "feature_bareword_filehandles", + STRLENs("feature_bareword_filehandles"), + FEATURE_BAREWORD_FILEHANDLES_BIT + }, + { + /* feature bitwise */ + "feature_bitwise", + STRLENs("feature_bitwise"), + FEATURE_BITWISE_BIT + }, + { + /* feature class */ + "feature_class", + STRLENs("feature_class"), + FEATURE_CLASS_BIT + }, + { + /* feature current_sub */ + "feature___SUB__", + STRLENs("feature___SUB__"), + FEATURE___SUB___BIT + }, + { + /* feature declared_refs */ + "feature_myref", + STRLENs("feature_myref"), + FEATURE_MYREF_BIT + }, + { + /* feature defer */ + "feature_defer", + STRLENs("feature_defer"), + FEATURE_DEFER_BIT + }, + { + /* feature evalbytes */ + "feature_evalbytes", + STRLENs("feature_evalbytes"), + FEATURE_EVALBYTES_BIT + }, + { + /* feature extra_paired_delimiters */ + "feature_more_delims", + STRLENs("feature_more_delims"), + FEATURE_MORE_DELIMS_BIT + }, + { + /* feature fc */ + "feature_fc", + STRLENs("feature_fc"), + FEATURE_FC_BIT + }, + { + /* feature indirect */ + "feature_indirect", + STRLENs("feature_indirect"), + FEATURE_INDIRECT_BIT + }, + { + /* feature isa */ + "feature_isa", + STRLENs("feature_isa"), + FEATURE_ISA_BIT + }, + { + /* feature module_true */ + "feature_module_true", + STRLENs("feature_module_true"), + FEATURE_MODULE_TRUE_BIT + }, + { + /* feature multidimensional */ + "feature_multidimensional", + STRLENs("feature_multidimensional"), + FEATURE_MULTIDIMENSIONAL_BIT + }, + { + /* feature postderef_qq */ + "feature_postderef_qq", + STRLENs("feature_postderef_qq"), + FEATURE_POSTDEREF_QQ_BIT + }, + { + /* feature refaliasing */ + "feature_refaliasing", + STRLENs("feature_refaliasing"), + FEATURE_REFALIASING_BIT + }, + { + /* feature say */ + "feature_say", + STRLENs("feature_say"), + FEATURE_SAY_BIT + }, + { + /* feature signatures */ + "feature_signatures", + STRLENs("feature_signatures"), + FEATURE_SIGNATURES_BIT + }, + { + /* feature state */ + "feature_state", + STRLENs("feature_state"), + FEATURE_STATE_BIT + }, + { + /* feature switch */ + "feature_switch", + STRLENs("feature_switch"), + FEATURE_SWITCH_BIT + }, + { + /* feature try */ + "feature_try", + STRLENs("feature_try"), + FEATURE_TRY_BIT + }, + { + /* feature unicode_eval */ + "feature_unieval", + STRLENs("feature_unieval"), + FEATURE_UNIEVAL_BIT + }, + { + /* feature unicode_strings */ + "feature_unicode", + STRLENs("feature_unicode"), + FEATURE_UNICODE_BIT + }, + { NULL, 0, 0U } +}; + +PERL_STATIC_INLINE void +S_fetch_feature_bits_hh(pTHX_ HV *hh) { + PL_compiling.cop_features = 0; + + const struct perl_feature_bit *fb = PL_feature_bits; + while (fb->name) { + SV **svp = hv_fetch(hh, fb->name, (I32)fb->namelen, 0); + if (svp && SvTRUE(*svp)) + PL_compiling.cop_features |= fb->mask; + ++fb; + } +} + +#endif + #endif /* PERL_FEATURE_H_ */ /* ex: set ro ft=c: */ diff --git a/op.c b/op.c index 05c2b54c88da..f2e27f3902f7 100644 --- a/op.c +++ b/op.c @@ -12227,7 +12227,6 @@ Perl_ck_eval(pTHX_ OP *o) /* Store a copy of %^H that pp_entereval can pick up. */ HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv)); OP *hhop; - STOREFEATUREBITSHH(hh); hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh)); /* append hhop to only child */ op_sibling_splice(o, cUNOPo->op_first, 0, hhop); diff --git a/regen/feature.pl b/regen/feature.pl index 218c43b7a159..791cfb9c31d5 100755 --- a/regen/feature.pl +++ b/regen/feature.pl @@ -392,14 +392,7 @@ sub longest { #define CLEARFEATUREBITS() (PL_compiling.cop_features = 0) -#define STOREFEATUREBITSHH(hh) \\ - (hv_stores((hh), "feature/bits", newSVuv(PL_compiling.cop_features))) - -#define FETCHFEATUREBITSHH(hh) \\ - STMT_START { \\ - SV **fbsv = hv_fetchs((hh), "feature/bits", FALSE); \\ - PL_compiling.cop_features = fbsv ? SvUV(*fbsv) : 0; \\ - } STMT_END +#define FETCHFEATUREBITSHH(hh) S_fetch_feature_bits_hh(aTHX_ (hh)) #endif /* PERL_CORE or PERL_EXT */ @@ -434,7 +427,7 @@ sub longest { } #endif /* PERL_IN_OP_C */ -#ifdef PERL_IN_MG_C +#if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_CTL_C) #define magic_sethint_feature(keysv, keypv, keylen, valsv, valbool) \\ S_magic_sethint_feature(aTHX_ (keysv), (keypv), (keylen), (valsv), (valbool)) @@ -491,6 +484,49 @@ sub longest { } #endif /* PERL_IN_MG_C */ +/* subject to change */ +struct perl_feature_bit { + const char *name; + STRLEN namelen; + U32 mask; +}; + +#ifdef PERL_IN_PP_CTL_C + +static const struct perl_feature_bit +PL_feature_bits[] = { +EOJ +for my $key (sort keys %feature) { + my $val = $feature{$key}; + print $h <name) { + SV **svp = hv_fetch(hh, fb->name, (I32)fb->namelen, 0); + if (svp && SvTRUE(*svp)) + PL_compiling.cop_features |= fb->mask; + ++fb; + } +} + +#endif + #endif /* PERL_FEATURE_H_ */ EOJ From 346e58f10813a73932bdf03c95f06c6510e74188 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 23 Aug 2023 14:53:12 +1000 Subject: [PATCH 2/2] eval_sv: add a G_USEHINTS flag Fixes #21415 --- cop.h | 1 + ext/XS-APItest/Makefile.PL | 2 +- ext/XS-APItest/t/call.t | 19 +++++++++++++++++-- perl.c | 8 ++++++++ 4 files changed, 27 insertions(+), 3 deletions(-) diff --git a/cop.h b/cop.h index 015eb39c51b6..8f73277dd1c4 100644 --- a/cop.h +++ b/cop.h @@ -1219,6 +1219,7 @@ struct context { #define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */ #define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */ #define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */ +#define G_USEHINTS 0x4000 /* eval_sv(): use current hints/features */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index b666a3d13721..bbf9fdf2718c 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -24,7 +24,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV G_SCALAR G_LIST G_VOID G_DISCARD G_EVAL G_NOARGS G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_RETHROW - GV_NOADD_NOINIT + GV_NOADD_NOINIT G_USEHINTS SV_GMAGIC SV_SKIP_OVERLOAD IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index 1116f286fb2e..af9aa08257e1 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -7,11 +7,11 @@ use warnings; use strict; # Test::More doesn't have fresh_perl_is() yet -# use Test::More tests => 342; +# use Test::More tests => 344; BEGIN { require '../../t/test.pl'; - plan(538); + plan(542); use_ok('XS::APItest') }; use Config; @@ -340,6 +340,21 @@ for my $fn_type (qw(eval_pv eval_sv call_sv)) { } } +{ + use feature "fc"; + use strict; + # the XS eval_sv() returns the count of results + is(eval_sv('fc("A") eq fc("a"); 1', G_LIST), 0, + "don't inherit hints by default (so the eval fails)"); + is(eval_sv('fc("A") eq fc("a"); 1', G_LIST | G_USEHINTS), 1, + "inherit hints when requested (so the eval succeeds)") + or diag($@); + is(eval_sv('$x = 1', G_LIST), 1, + "don't inherit hints (strict) by default, so the eval succeeds"); + is(eval_sv('$x = 1', G_LIST | G_USEHINTS), 0, + "inherit hints (strict) when requested, so the evail fails"); +} + # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up # a new jump level but before pushing an eval context, leading to # stack corruption diff --git a/perl.c b/perl.c index faad8fa98ec3..269f7669ed0d 100644 --- a/perl.c +++ b/perl.c @@ -3229,7 +3229,12 @@ as C, with the obvious exception of C. See L. The C flag can be used if you only need eval_sv() to execute code specified by a string, but not catch any errors. +By default the code is compiled and executed with the default hints, +such as strict and features. Set C in flags to use the +current hints from C. + =for apidoc Amnh||G_RETHROW +=for apidoc Amnh||G_USEHINTS =cut */ @@ -3277,6 +3282,9 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) if (flags & G_RE_REPARSING) myop.op_private |= (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); + if (flags & G_USEHINTS) + myop.op_private |= OPpEVAL_COPHH; + /* fail now; otherwise we could fail after the JMPENV_PUSH but * before a cx_pusheval(), which corrupts the stack after a croak */ TAINT_PROPER("eval_sv()");