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'.

diff --git a/mg.c b/mg.c
index 90918af..c66aa0b 100644 (file)
--- 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 d22cfed..1e0afc9 100644 (file)
--- 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 80116a8..169e8dc 100644 (file)
--- 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 f52d8e4..37ebb6a 100644 (file)
--- 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 1dc7139..774c6ee 100644 (file)
--- 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 7fdefc2..589db84 100644 (file)
--- 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') {