Forbid setting $/ to a reference to a non-postive integer

This used to work like setting it to 'undef', but has been deprecated
since Perl 5.20.

In passing, avoid duplicate duplicate uninitialized warning by reusing
the SvIV() result already stored in 'val'.

6 files changed, 44 insertions, 44 deletions

diff --git a/mg.c b/mg.c
index 90918af90a..c66aa0bb13 100644
--- a/mg.c
+++ b/mg.c
@@ -2915,7 +2915,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '/':
         {
-            SV *tmpsv = sv;
             if (SvROK(sv)) {
                 SV *referent = SvRV(sv);
                 const char *reftype = sv_reftype(referent, 0);
@@ -2929,11 +2928,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                 if (reftype[0] == 'S' || reftype[0] == 'L') {
                     IV val = SvIV(referent);
                     if (val <= 0) {
-                        tmpsv = &PL_sv_undef;
-                        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                            "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28",
-                            SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
-                        );
+                        sv_setsv(sv, PL_rs);
+                        Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
+                                         val < 0 ? "a negative integer" : "zero");
                     }
                 } else {
                     sv_setsv(sv, PL_rs);
@@ -2943,7 +2940,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                 }
             }
             SvREFCNT_dec(PL_rs);
-            PL_rs = newSVsv(tmpsv);
+            PL_rs = newSVsv(sv);
         }
 	break;
     case '\\':
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index d22cfed26a..1e0afc9da8 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -74,6 +74,11 @@ to the same symbol (glob or scalar) has been deprecated since Perl 5.10.
 
 Use of a bare terminator has been deprecated since Perl 5.000.
 
+=head2 Setting $/ to a reference to a non-positive integer no longer allowed
+
+This used to work like setting it to C<undef>, but has been deprecated
+since Perl 5.20.
+
 =head1 Deprecations
 
 XXX Any deprecated features, syntax, modules etc. should be listed here.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 80116a8832..169e8dc452 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -5550,9 +5550,9 @@ didn't think so.
 forget to check the return value of your socket() call?  See
 L<perlfunc/setsockopt>.
 
-=item Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28
+=item Setting $/ to a reference to %s is forbidden
 
-(D deprecated) You assigned a reference to a scalar to C<$/> where the
+(F) You assigned a reference to a scalar to C<$/> where the
 referenced item is not a positive integer.  In older perls this B<appeared>
 to work the same as setting it to C<undef> but was in fact internally
 different, less efficient and with very bad luck could have resulted in
@@ -5563,8 +5563,8 @@ setting C<$/> to undef, with the exception that this warning would be
 thrown.
 
 You are recommended to change your code to set C<$/> to C<undef> explicitly
-if you wish to slurp the file.  In Perl 5.28 assigning C<$/> to a 
-reference to an integer which isn't positive will throw a fatal error.
+if you wish to slurp the file.  As of Perl 5.28 assigning C<$/> to a
+reference to an integer which isn't positive is a fatal error.
 
 =item Setting $/ to %s reference is forbidden
 
diff --git a/t/base/rs.t b/t/base/rs.t
index f52d8e42ff..37ebb6a198 100644
--- a/t/base/rs.t
+++ b/t/base/rs.t
@@ -1,7 +1,7 @@
 #!./perl
 # Test $/
 
-print "1..39\n";
+print "1..41\n";
 
 $test_count = 1;
 $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
@@ -237,17 +237,31 @@ sub test_record {
   if ($bar ne "78") {print "not ";}
   print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
   $test_count++;
-
-  # Naughty straight number - should get the rest of the file
-  # no warnings 'deprecated'; # but not in t/base/*
-  { local $SIG{__WARN__} = sub {}; $/ = \0 }
-  $bar = <FH>;
-  if ($bar ne "90123456789012345678901234567890") {print "not ";}
-  print "ok $test_count # \$/ = \\0\n";
-  $test_count++;
 }
 
 sub test_bad_setting {
+  if (eval {$/ = \0; 1}) {
+    print "not ok ",$test_count++," # \$/ = \\0; should die\n";
+    print "not ok ",$test_count++," # \$/ = \\0; produced expected error message\n";
+  } else {
+    my $msg= $@ || "Zombie Error";
+    print "ok ",$test_count++," # \$/ = \\0; should die\n";
+    if ($msg!~m!Setting \$\/ to a reference to zero is forbidden!) {
+      print "not ";
+    }
+    print "ok ",$test_count++," # \$/ = \\0; produced expected error message\n";
+  }
+  if (eval {$/ = \-1; 1}) {
+    print "not ok ",$test_count++," # \$/ = \\-1; should die\n";
+    print "not ok ",$test_count++," # \$/ = \\-1; produced expected error message\n";
+  } else {
+    my $msg= $@ || "Zombie Error";
+    print "ok ",$test_count++," # \$/ = \\-1; should die\n";
+    if ($msg!~m!Setting \$\/ to a reference to a negative integer is forbidden!) {
+      print "not ";
+    }
+    print "ok ",$test_count++," # \$/ = \\-1; produced expected error message\n";
+  }
   if (eval {$/ = []; 1}) {
     print "not ok ",$test_count++," # \$/ = []; should die\n";
     print "not ok ",$test_count++," # \$/ = []; produced expected error message\n";
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index 1dc71397b6..774c6ee432 100644
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -404,15 +404,19 @@ use warnings 'uninitialized';
 my ($m1);
 
 local $/ =\$m1;
+EXPECT
+Use of uninitialized value $m1 in scalar assignment at - line 4.
+Setting $/ to a reference to zero is forbidden at - line 4.
+########
+use warnings 'uninitialized';
+
 my $x = "abc";
 chomp $x; chop $x;
 my $y;
 chomp ($x, $y); chop ($x, $y);
 EXPECT
-Use of uninitialized value $m1 in scalar assignment at - line 4.
-Use of uninitialized value $m1 in scalar assignment at - line 4.
-Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28 at - line 4.
-Use of uninitialized value $y in chop at - line 8.
+Use of uninitialized value $y in chomp at - line 6.
+Use of uninitialized value $y in chop at - line 6.
 ########
 use warnings 'uninitialized';
 my ($m1, @ma, %mh);
diff --git a/t/lib/warnings/mg b/t/lib/warnings/mg
index 7fdefc26b3..589db847b2 100644
--- a/t/lib/warnings/mg
+++ b/t/lib/warnings/mg
@@ -3,8 +3,6 @@
   No such signal: SIG%s
     $SIG{FRED} = sub {}
 
-  Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28
-
   SIG%s handler \"%s\" not defined.
     $SIG{"INT"} = "ok3"; kill "INT",$$;
 
@@ -21,24 +19,6 @@ $SIG{FRED} = sub {};
 EXPECT
 
 ########
--w
-# warnable code, warnings enabled via command line switch
-$/ = \0;
-EXPECT
-Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28 at - line 3.
-########
--w
-# warnable code, warnings enabled via command line switch
-$/ = \-1;
-EXPECT
-Setting $/ to a reference to a negative integer as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28 at - line 3.
-########
-$/ = \-1;
-no warnings 'deprecated';
-$/ = \-1;
-EXPECT
-Setting $/ to a reference to a negative integer as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28 at - line 1.
-########
 # mg.c
 use warnings 'signal' ;
 if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {