This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add 'indirect' feature that can be turned off to disable indirect object syntax 17477/head
authorDagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Tue, 21 Jan 2020 10:35:05 +0000 (10:35 +0000)
committerDagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Sun, 16 Feb 2020 16:00:00 +0000 (16:00 +0000)
Co-authored-by: Tony Cook <tony@develop-help.com>
MANIFEST
feature.h
lib/feature.pm
pod/perldelta.pod
regen/feature.pl
t/lib/feature/indirect [new file with mode: 0644]
t/porting/known_pod_issues.dat
toke.c

index d8d62c6..88fb70d 100644 (file)
--- 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
index 0044b06..2f2f23c 100644 (file)
--- a/feature.h
+++ b/feature.h
 #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
         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;
index 668b430..e6f467e 100644 (file)
@@ -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<perlop/Class Instance Operator> for more details.
 
 This feature is available from Perl 5.32 onwards.
 
+=head2 The 'indirect' feature
+
+This feature allows the use of L<indirect object
+syntax|perlobj/Indirect Object Syntax> for method calls, e.g.  C<new
+Foo 1, 2;>. 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<indirect>
+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<use feature> or C<no feature> declaration.
index 07c5c73..36daf64 100644 (file)
@@ -179,6 +179,14 @@ old perls from CPAN.
 
 L<threads> has been upgraded from version 2.23 to 2.24.
 
+=item *
+
+L<feature> has been upgraded from version 1.57 to 1.58.
+
+A new C<indirect> feature has been added, which is enabled by default
+but allows turning off L<indirect object syntax|perlobj/Indirect
+Object Syntax>.
+
 =back
 
 =head2 Removed Modules and Pragmata
index e3eb8e9..667f524 100755 (executable)
@@ -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<perlop/Class Instance Operator> for more details.
 
 This feature is available from Perl 5.32 onwards.
 
+=head2 The 'indirect' feature
+
+This feature allows the use of L<indirect object
+syntax|perlobj/Indirect Object Syntax> for method calls, e.g.  C<new
+Foo 1, 2;>. 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<indirect>
+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 (file)
index 0000000..cd96f89
--- /dev/null
@@ -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.
index 96494d2..758b4b4 100644 (file)
@@ -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 (file)
--- 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;