Eliminate modifiable variables in constants

Transform previously deprecated cases into exceptions.

Update diagnostic; change D to F

remove now irrelevant code (TonyC)

For: RT 134138

3 files changed, 25 insertions, 48 deletions

diff --git a/pad.c b/pad.c
index c0098bedf3..7854678928 100644
--- a/pad.c
+++ b/pad.c
@@ -2127,7 +2127,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
 	 * from the parent */
 	if (const_sv && SvREFCNT(const_sv) == 2) {
 	    const bool was_method = cBOOL(CvMETHOD(cv));
-	    bool copied = FALSE;
 	    if (outside) {
 		PADNAME * const pn =
 		    PadlistNAMESARRAY(CvPADLIST(outside))
@@ -2156,28 +2155,15 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
 			) == o
 		     && !OpSIBLING(o))
 		    {
-			Perl_ck_warner_d(aTHX_
-					  packWARN(WARN_DEPRECATED),
-					 "Constants from lexical "
-					 "variables potentially "
-					 "modified elsewhere are "
-					 "deprecated. This will not "
-                                         "be allowed in Perl 5.32");
-			/* We *copy* the lexical variable, and donate the
-			   copy to newCONSTSUB.  Yes, this is ugly, and
-			   should be killed.  We need to do this for the
-			   time being, however, because turning on SvPADTMP
-			   on a lexical will have observable effects
-			   elsewhere.  */
-			const_sv = newSVsv(const_sv);
-			copied = TRUE;
+                        Perl_croak(aTHX_
+                            "Constants from lexical variables potentially modified "
+                            "elsewhere are no longer permitted");
 		    }
 		    else
 			goto constoff;
 		}
 	    }
-	    if (!copied)
-		SvREFCNT_inc_simple_void_NN(const_sv);
+            SvREFCNT_inc_simple_void_NN(const_sv);
 	    /* If the lexical is not used elsewhere, it is safe to turn on
 	       SvPADTMP, since it is only when it is used in lvalue con-
 	       text that the difference is observable.  */
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 2aaa5030ec..0144f99e49 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1833,10 +1833,9 @@ The message indicates the type of reference that was expected.  This
 usually indicates a syntax error in dereferencing the constant value.
 See L<perlsub/"Constant Functions"> and L<constant>.
 
-=item Constants from lexical variables potentially modified elsewhere are
-deprecated. This will not be allowed in Perl 5.32
+=item Constants from lexical variables potentially modified elsewhere are no longer permitted
 
-(D deprecated) You wrote something like
+(F) You wrote something like
 
     my $var;
     $sub = sub () { $var };
@@ -1853,7 +1852,7 @@ breaks the behavior of closures, in which the subroutine captures
 the variable itself, rather than its value, so future changes to the
 variable are reflected in the subroutine's return value.
 
-This usage is deprecated, and will no longer be allowed in Perl 5.32,
+This usage was deprecated, and as of Perl 5.32 is no longer allowed,
 making it possible to change the behavior in the future.
 
 If you intended for the subroutine to be eligible for inlining, then
diff --git a/t/op/const-optree.t b/t/op/const-optree.t
index 4d897d247e..3a8181beb8 100644
--- a/t/op/const-optree.t
+++ b/t/op/const-optree.t
@@ -8,7 +8,7 @@ BEGIN {
     require './test.pl';
     set_up_inc('../lib');
 }
-plan 168;
+plan 148;
 
 # @tests is an array of hash refs, each of which can have various keys:
 #
@@ -25,6 +25,11 @@ plan 168;
 #   deprecated  - whether the sub returning a code ref will emit a depreca-
 #                 tion warning when called
 #   method      - whether the sub has the :method attribute
+#   exception   - sub now throws an exception (previously threw
+#                 deprecation warning)
+
+my $exception_134138 = 'Constants from lexical variables potentially modified '
+    . 'elsewhere are no longer permitted';
 
 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
 sub blonk { ++$blonk_was_called }
@@ -47,11 +52,7 @@ push @tests, {
 push @tests, {
   nickname    => 'sub with simple lexical modified elsewhere',
   generator   => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
-  retval      => 5, # change to 7 when the deprecation cycle is over
-  same_retval => 0,
-  inlinable   => 1,
-  deprecated  => 1,
-  method      => 0,
+  exception   => $exception_134138,
 };
 
 push @tests, {
@@ -184,11 +185,7 @@ push @tests, {
     my $sub1 = sub () { $x++ };
     $ret;
   },
-  retval      => 5,
-  same_retval => 0,
-  inlinable   => 1,
-  deprecated  => 1,
-  method      => 0,
+  exception   => $exception_134138,
 };
 push @tests, {
   nickname    => 'complex lexical op tree before an lvalue closure',
@@ -307,11 +304,7 @@ push @tests, {
     eval '$outer++';
     $ret;
   },
-  retval      => 43,
-  same_retval => 0,
-  inlinable   => 1,
-  deprecated  => 1,
-  method      => 0,
+  exception   => $exception_134138,
 };
 push @tests, {
   nickname    => 'sub () { $x } with s///ee in scope',
@@ -322,11 +315,7 @@ push @tests, {
     $dummy =~ s//$dummy/ee;
     $ret;
   },
-  retval      => 43,
-  same_retval => 0,
-  inlinable   => 1,
-  deprecated  => 1,
-  method      => 0,
+  exception   => $exception_134138,
 };
 push @tests, {
   nickname    => 'sub () { $x } with eval not in scope',
@@ -414,11 +403,7 @@ push @tests, {
 push @tests, {
   nickname    => 'sub closing over state var++',
   generator   => sub { state $x++; sub () { $x } },
-  retval      => 1,
-  same_retval => 0,
-  inlinable   => 1,
-  deprecated  => 1,
-  method      => 0,
+  exception   => $exception_134138,
 };
 
 
@@ -426,6 +411,12 @@ use feature 'refaliasing';
 no warnings 'experimental::refaliasing';
 for \%_ (@tests) {
     my $nickname = $_{nickname};
+    if (exists $_{exception} and $_{exception}) {
+        local $@;
+        eval { my $sub = &{$_{generator}}; };
+        like($@, qr/$_{exception}/, "$nickname: now throws exception (RT 134138)");
+        next;
+    }
     my $w;
     local $SIG{__WARN__} = sub { $w = shift };
     my $sub = &{$_{generator}};
@@ -492,3 +483,4 @@ pass("No assertion failure when turning on PADSTALE on lexical shared by"
     $z = &$sub;
     is $z, $y, 'inlinable sub ret vals are not swipable';
 }
+