From 0b657b1955a40e49c93ca32fe32822f4a8a5205b Mon Sep 17 00:00:00 2001 From: =?utf8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Tue, 21 Jan 2020 10:35:05 +0000 Subject: [PATCH] Add 'indirect' feature that can be turned off to disable indirect object syntax Co-authored-by: Tony Cook --- MANIFEST | 1 + feature.h | 33 +++++++--- lib/feature.pm | 51 ++++++++++----- pod/perldelta.pod | 8 +++ regen/feature.pl | 43 ++++++++----- t/lib/feature/indirect | 141 +++++++++++++++++++++++++++++++++++++++++ t/porting/known_pod_issues.dat | 1 + toke.c | 5 +- 8 files changed, 240 insertions(+), 43 deletions(-) create mode 100644 t/lib/feature/indirect diff --git a/MANIFEST b/MANIFEST index d8d62c6..88fb70d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5634,6 +5634,7 @@ t/lib/Devel/switchd_goto.pm Module for t/run/switchd.t t/lib/feature/bits Tests for feature bit handling t/lib/feature/bundle Tests for feature bundles t/lib/feature/implicit Tests for implicit loading of feature.pm +t/lib/feature/indirect Tests for enabling/disabling indirect method calls t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature t/lib/feature/removed Tests for enabling/disabling removed feature t/lib/feature/say Tests for enabling/disabling say feature diff --git a/feature.h b/feature.h index 0044b06..2f2f23c 100644 --- a/feature.h +++ b/feature.h @@ -17,15 +17,16 @@ #define FEATURE_MYREF_BIT 0x0004 #define FEATURE_EVALBYTES_BIT 0x0008 #define FEATURE_FC_BIT 0x0010 -#define FEATURE_ISA_BIT 0x0020 -#define FEATURE_POSTDEREF_QQ_BIT 0x0040 -#define FEATURE_REFALIASING_BIT 0x0080 -#define FEATURE_SAY_BIT 0x0100 -#define FEATURE_SIGNATURES_BIT 0x0200 -#define FEATURE_STATE_BIT 0x0400 -#define FEATURE_SWITCH_BIT 0x0800 -#define FEATURE_UNIEVAL_BIT 0x1000 -#define FEATURE_UNICODE_BIT 0x2000 +#define FEATURE_INDIRECT_BIT 0x0020 +#define FEATURE_ISA_BIT 0x0040 +#define FEATURE_POSTDEREF_QQ_BIT 0x0080 +#define FEATURE_REFALIASING_BIT 0x0100 +#define FEATURE_SAY_BIT 0x0200 +#define FEATURE_SIGNATURES_BIT 0x0400 +#define FEATURE_STATE_BIT 0x0800 +#define FEATURE_SWITCH_BIT 0x1000 +#define FEATURE_UNIEVAL_BIT 0x2000 +#define FEATURE_UNICODE_BIT 0x4000 #define FEATURE_BUNDLE_DEFAULT 0 #define FEATURE_BUNDLE_510 1 @@ -92,6 +93,13 @@ FEATURE_IS_ENABLED_MASK(FEATURE_BITWISE_BIT)) \ ) +#define FEATURE_INDIRECT_IS_ENABLED \ + ( \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ + || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_INDIRECT_BIT)) \ + ) + #define FEATURE_EVALBYTES_IS_ENABLED \ ( \ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ @@ -244,7 +252,12 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, return; case 'i': - if (keylen == sizeof("feature_isa")-1 + if (keylen == sizeof("feature_indirect")-1 + && memcmp(subf+1, "ndirect", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_INDIRECT_BIT; + break; + } + else if (keylen == sizeof("feature_isa")-1 && memcmp(subf+1, "sa", keylen - sizeof("feature_")) == 0) { mask = FEATURE_ISA_BIT; break; diff --git a/lib/feature.pm b/lib/feature.pm index 668b430..e6f467e 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -5,7 +5,7 @@ package feature; -our $VERSION = '1.57'; +our $VERSION = '1.58'; our %feature = ( fc => 'feature_fc', @@ -14,6 +14,7 @@ our %feature = ( state => 'feature_state', switch => 'feature_switch', bitwise => 'feature_bitwise', + indirect => 'feature_indirect', evalbytes => 'feature_evalbytes', signatures => 'feature_signatures', current_sub => 'feature___SUB__', @@ -25,13 +26,13 @@ our %feature = ( ); our %feature_bundle = ( - "5.10" => [qw(say state switch)], - "5.11" => [qw(say state switch unicode_strings)], - "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)], - "5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], - "5.27" => [qw(bitwise current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], - "all" => [qw(bitwise current_sub declared_refs evalbytes fc isa postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], - "default" => [qw()], + "5.10" => [qw(indirect say state switch)], + "5.11" => [qw(indirect say state switch unicode_strings)], + "5.15" => [qw(current_sub evalbytes fc indirect say state switch unicode_eval unicode_strings)], + "5.23" => [qw(current_sub evalbytes fc indirect postderef_qq say state switch unicode_eval unicode_strings)], + "5.27" => [qw(bitwise current_sub evalbytes fc indirect postderef_qq say state switch unicode_eval unicode_strings)], + "all" => [qw(bitwise current_sub declared_refs evalbytes fc indirect isa postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], + "default" => [qw(indirect)], ); $feature_bundle{"5.12"} = $feature_bundle{"5.11"}; @@ -359,6 +360,18 @@ right operand. See L for more details. This feature is available from Perl 5.32 onwards. +=head2 The 'indirect' feature + +This feature allows the use of L for method calls, e.g. C. It is enabled by default, but can be turned off to +disallow indirect object syntax. + +This feature is available under this name from Perl 5.32 onwards. In +previous versions, it was simply on all the time. To disallow (or +warn on) indirect object syntax on older Perls, see the L +CPAN module. + =head1 FEATURE BUNDLES It's possible to load multiple features together, using @@ -371,45 +384,49 @@ The following feature bundles are available: bundle features included --------- ----------------- - :default + :default indirect - :5.10 say state switch + :5.10 say state switch indirect - :5.12 say state switch unicode_strings + :5.12 say state switch unicode_strings indirect - :5.14 say state switch unicode_strings + :5.14 say state switch unicode_strings indirect :5.16 say state switch unicode_strings unicode_eval evalbytes current_sub fc + indirect :5.18 say state switch unicode_strings unicode_eval evalbytes current_sub fc + indirect :5.20 say state switch unicode_strings unicode_eval evalbytes current_sub fc + indirect :5.22 say state switch unicode_strings unicode_eval evalbytes current_sub fc + indirect :5.24 say state switch unicode_strings unicode_eval evalbytes current_sub fc - postderef_qq + postderef_qq indirect :5.26 say state switch unicode_strings unicode_eval evalbytes current_sub fc - postderef_qq + postderef_qq indirect :5.28 say state switch unicode_strings unicode_eval evalbytes current_sub fc - postderef_qq bitwise + postderef_qq bitwise indirect :5.30 say state switch unicode_strings unicode_eval evalbytes current_sub fc - postderef_qq bitwise + postderef_qq bitwise indirect :5.32 say state switch unicode_strings unicode_eval evalbytes current_sub fc - postderef_qq bitwise + postderef_qq bitwise indirect The C<:default> bundle represents the feature set that is enabled before any C or C declaration. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 07c5c73..36daf64 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -179,6 +179,14 @@ old perls from CPAN. L has been upgraded from version 2.23 to 2.24. +=item * + +L has been upgraded from version 1.57 to 1.58. + +A new C feature has been added, which is enabled by default +but allows turning off L. + =back =head2 Removed Modules and Pragmata diff --git a/regen/feature.pl b/regen/feature.pl index e3eb8e9..667f524 100755 --- a/regen/feature.pl +++ b/regen/feature.pl @@ -36,6 +36,7 @@ my %feature = ( fc => 'fc', signatures => 'signatures', isa => 'isa', + indirect => 'indirect', ); # NOTE: If a feature is ever enabled in a non-contiguous range of Perl @@ -45,29 +46,29 @@ my %feature = ( # 5.odd implies the next 5.even, but an explicit 5.even can override it. my %feature_bundle = ( all => [ keys %feature ], - default => [qw()], - "5.9.5" => [qw(say state switch)], - "5.10" => [qw(say state switch)], - "5.11" => [qw(say state switch unicode_strings)], - "5.13" => [qw(say state switch unicode_strings)], + default => [qw(indirect)], + "5.9.5" => [qw(say state switch indirect)], + "5.10" => [qw(say state switch indirect)], + "5.11" => [qw(say state switch unicode_strings indirect)], + "5.13" => [qw(say state switch unicode_strings indirect)], "5.15" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc)], + evalbytes current_sub fc indirect)], "5.17" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc)], + evalbytes current_sub fc indirect)], "5.19" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc)], + evalbytes current_sub fc indirect)], "5.21" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc)], + evalbytes current_sub fc indirect)], "5.23" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc postderef_qq)], + evalbytes current_sub fc postderef_qq indirect)], "5.25" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc postderef_qq)], + evalbytes current_sub fc postderef_qq indirect)], "5.27" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc postderef_qq bitwise)], + evalbytes current_sub fc postderef_qq bitwise indirect)], "5.29" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc postderef_qq bitwise)], + evalbytes current_sub fc postderef_qq bitwise indirect)], "5.31" => [qw(say state switch unicode_strings unicode_eval - evalbytes current_sub fc postderef_qq bitwise)], + evalbytes current_sub fc postderef_qq bitwise indirect)], ); my @noops = qw( postderef lexical_subs ); @@ -468,7 +469,7 @@ read_only_bottom_close_and_rename($h); __END__ package feature; -our $VERSION = '1.57'; +our $VERSION = '1.58'; FEATURES @@ -761,6 +762,18 @@ right operand. See L for more details. This feature is available from Perl 5.32 onwards. +=head2 The 'indirect' feature + +This feature allows the use of L for method calls, e.g. C. It is enabled by default, but can be turned off to +disallow indirect object syntax. + +This feature is available under this name from Perl 5.32 onwards. In +previous versions, it was simply on all the time. To disallow (or +warn on) indirect object syntax on older Perls, see the L +CPAN module. + =head1 FEATURE BUNDLES It's possible to load multiple features together, using diff --git a/t/lib/feature/indirect b/t/lib/feature/indirect new file mode 100644 index 0000000..cd96f89 --- /dev/null +++ b/t/lib/feature/indirect @@ -0,0 +1,141 @@ +Test no feature indirect. + +__END__ +# NAME feature indirect +use feature 'say'; +package Foo { + sub new { bless {}, shift } +} +# various indirect object look-alikes +my $foox = "foox"; +print STDERR "Hello\n"; +printf STDERR "Test%s\n", "x"; +say STDERR "Hello"; +exec $foox "foo", "bar"; +system $foox "foo", "bar"; +my $x = new Foo; +no feature "indirect"; +print STDERR "Hello\n"; +printf STDERR "Test%s\n", "x"; +say STDERR "Hello"; +exec $foox "foo", "bar"; +system $foox "foo", "bar"; +my $y = new Foo; +EXPECT +OPTIONS fatal +Bareword found where operator expected at - line 19, near "new Foo" + (Do you need to predeclare new?) +syntax error at - line 19, near "new Foo" +Execution of - aborted due to compilation errors. +######## +# NAME METHOD BLOCK +use feature 'say'; +package Foo { + sub new { bless {}, shift } +} +# make sure this works (either way) +my $st = STDOUT; +print { $st } "Foo\n"; +say { $st } "Foo"; + +# make sure this continues to work by default +my $class = "Foo"; +my $x = new { $class }; + +use feature "indirect"; + +# and with it explicitly enabled + +print { $st } "Foo\n"; +say { $st } "Foo"; + +my $y = new { $class }; + + +no feature "indirect"; + +# and only the indirect now fails +print { $st } "Foo\n"; +say { $st } "Foo"; +my $z = new { $class }; + +EXPECT +OPTIONS fatal +syntax error at - line 29, near "new { " +Execution of - aborted due to compilation errors. +######## +# NAME METHOD SCALAR +use feature 'say'; +package Foo { + sub new { bless {}, shift } +} +# make sure this works (either way) +my $st = STDOUT; +print $st "Foo\n"; +say $st "Foo"; + +# make sure this continues to work by default +my $class = "Foo"; +my $x = new $class; + +use feature "indirect"; + +# and with it explicitly enabled + +print $st "Foo\n"; +say $st "Foo"; + +my $y = new $class; + + +no feature "indirect"; + +# and only the indirect now fails +print $st "Foo\n"; +say $st "Foo"; +my $z = new $class; + +EXPECT +OPTIONS fatal +Scalar found where operator expected at - line 29, near "new $class" + (Do you need to predeclare new?) +syntax error at - line 29, near "new $class" +Execution of - aborted due to compilation errors. +######## +# NAME FUNCMETH SCALAR +use feature 'say'; +package Foo { + sub new { bless {}, shift } +} +# make sure this works (either way) +my $st = STDOUT; +print $st ("Foo\n"); +say $st ("Foo"); + +# make sure this continues to work by default +my $class = "Foo"; +my $x = new $class (); + +use feature "indirect"; + +# and with it explicitly enabled + +print $st ("Foo\n"); +say $st ("Foo"); + +my $y = new $class (); + + +no feature "indirect"; + +# and only the indirect now fails +print $st ("Foo\n"); +say $st ("Foo"); +my $z = new $class (); + +EXPECT +OPTIONS fatal +Scalar found where operator expected at - line 29, near "new $class" + (Do you need to predeclare new?) +syntax error at - line 29, near "new $class " +Execution of - aborted due to compilation errors. diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 96494d2..758b4b4 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -150,6 +150,7 @@ HTML::StripScripts HTTP::Lite iconv(1) iconv(3) +indirect inetd(8) invoker IO::Compress diff --git a/toke.c b/toke.c index 2c3bbb3..ff68348 100644 --- a/toke.c +++ b/toke.c @@ -4464,6 +4464,9 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) PERL_ARGS_ASSERT_INTUIT_METHOD; + if (!FEATURE_INDIRECT_IS_ENABLED) + return 0; + if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; if (cv && SvPOK(cv)) { @@ -7494,7 +7497,7 @@ yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && !c.cv) { + if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) { op_free(c.rv2cv_op); PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; -- 1.8.3.1