Make srand respect magic

It was returning U+FFFD for negative numbers, but only for non-magical
variables.

diff --git a/pp.c b/pp.c
index 156a500..f4c5693 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3256,18 +3256,29 @@ PP(pp_chr)
     char *tmps;
     UV value;
 
-    if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
+    SvGETMAGIC(TOPs);
+    if (((SvIOKp(TOPs) && !SvIsUV(TOPs) && SvIV_nomg(TOPs) < 0)
         ||
-        (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
+        (SvNOKp(TOPs) && SvNV_nomg(TOPs) < 0.0))) {
        if (IN_BYTES) {
-           value = POPu; /* chr(-1) eq chr(0xff), etc. */
+           value = SvUV_nomg(TOPs); /* chr(-1) eq chr(0xff), etc. */
+           (void)POPs;
        } else {
            SV *top = POPs;
-           Perl_ck_warner(aTHX_ packWARN(WARN_UTF8), "Invalid negative number (%"SVf") in chr", top);
+           if (ckWARN(WARN_UTF8)) {
+               if (SvGMAGICAL(top)) {
+                   SV *top2 = sv_newmortal();
+                   sv_setsv_nomg(top2, top);
+                   top = top2;
+               }
+               Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                          "Invalid negative number (%"SVf") in chr", top);
+           }
            value = UNICODE_REPLACEMENT;
        }
     } else {
-       value = POPu;
+       value = SvUV_nomg(TOPs);
+       (void)POPs;
     }
 
     SvUPGRADE(TARG,SVt_PV);

diff --git a/t/op/chr.t b/t/op/chr.t
index 5ac453f..510492e 100644 (file)
--- a/t/op/chr.t
+++ b/t/op/chr.t
@@ -6,7 +6,7 @@ BEGIN {
     require "test.pl";
 }
 
-plan tests => 34;
+plan tests => 38;
 
 # Note that t/op/ord.t already tests for chr() <-> ord() rountripping.
 
@@ -30,6 +30,15 @@ is(chr(-3.0), "\x{FFFD}");
     is(chr(-2  ), "\xFE");
     is(chr(-3.0), "\xFD");
 }
+# Make sure -1 is treated the same way when coming from a tied variable
+sub TIESCALAR {bless[]}
+sub STORE { $_[0][0] = $_[1] }
+sub FETCH { $_[0][0] }
+tie $t, "";
+$t = -1; is chr $t, chr -1, 'chr $tied when $tied is -1';
+$t = -2; is chr $t, chr -2, 'chr $tied when $tied is -2';
+$t = -1.1; is chr $t, chr -1.1, 'chr $tied when $tied is -1.1';
+$t = -2.2; is chr $t, chr -2.2, 'chr $tied when $tied is -2.2';
 
 # Check UTF-8 (not UTF-EBCDIC).
 SKIP: {
@@ -63,3 +72,4 @@ sub hexes {
     is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding
     is(hexes(0x200000), "f8 88 80 80 80");
 }
+