Add tests and fix new fatal errors related to $/

In b3a2acfa0c0e4f8e48e1f6eb4d6fd143f293d2c6 I added new exceptions, but
forgot to test them properly. In the process I managed to partially break
the functionality, and since it was not tested I did not notice.

Ilmari on #p5p pointed out I forgot the test, and in the end I had to completely
rewrite the original patch.

Now tested as fully as I could. Thanks Ilmari.

1 files changed, 24 insertions, 12 deletions

diff --git a/mg.c b/mg.c
index 6d04536a62..99a63f6844 100644
--- a/mg.c
+++ b/mg.c
@@ -2749,19 +2749,31 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	break;
     case '/':
-        if (!SvROK(sv) || ( SvTYPE(SvRV(sv)) < SVt_PVAV && SvIV(SvRV(sv)) > 0 ) ) {
-            SvREFCNT_dec(PL_rs);
-            PL_rs = newSVsv(sv);
-        } else if (SvTYPE(SvRV(sv)) >= SVt_PVAV) {
-            Perl_croak(aTHX_ "Setting $/ to a %s reference is forbidden", sv_reftype(SvRV(sv),0));
-        } else {
-            /* treat as undef */
-            Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
-                "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
-                SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
-            );
+        {
+            SV *tmpsv= sv;
+            if (SvROK(sv)) {
+                SV *referent= SvRV(sv);
+                const char *reftype= sv_reftype(referent, 0);
+                /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
+                 * is to copy pretty much the entire sv_reftype() into this routine, or to do
+                 * a full string comparison on the return of sv_reftype() both of which
+                 * make me feel worse! NOTE, do not modify this comment without reviewing the
+                 * corresponding comment in sv_reftype(). - Yves */
+                if (reftype[0] == 'S' || reftype[0] == 'L') {
+                    IV val= SvIV(referent);
+                    if (val <= 0) {
+                        tmpsv= &PL_sv_undef;
+                        Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+                            "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
+                            SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
+                        );
+                    }
+                } else {
+                    Perl_croak(aTHX_ "Setting $/ to a %s reference is forbidden", reftype);
+                }
+            }
             SvREFCNT_dec(PL_rs);
-            PL_rs= newSVsv(&PL_sv_undef);
+            PL_rs = newSVsv(tmpsv);
         }
 	break;
     case '\\':