Make also hex() and oct() to croak if their arguments

cannot be downgraded (that is, if they contain wide
characters), just like crypt() does (and use the croak
feature of sv_utf8_downgrade()).

p4raw-id: //depot/perl@14354

diff --git a/pp.c b/pp.c
index 0d7f75b..d041f1b 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2791,8 +2791,18 @@ PP(pp_hex)
     STRLEN len;
     NV result_nv;
     UV result_uv;
+    SV* sv = POPs;
 
-    tmps = (SvPVx(POPs, len));
+    tmps = (SvPVx(sv, len));
+    if (DO_UTF8(sv)) {
+        /* If Unicode, try to downgrade
+         * If not possible, croak. */
+         SV* tsv = sv_2mortal(newSVsv(sv));
+        
+        SvUTF8_on(tsv);
+        sv_utf8_downgrade(tsv, FALSE);
+        tmps = SvPVX(tsv);
+    }
     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
         XPUSHn(result_nv);
@@ -2811,8 +2821,18 @@ PP(pp_oct)
     STRLEN len;
     NV result_nv;
     UV result_uv;
+    SV* sv = POPs;
 
-    tmps = (SvPVx(POPs, len));
+    tmps = (SvPVx(sv, len));
+    if (DO_UTF8(sv)) {
+        /* If Unicode, try to downgrade
+         * If not possible, croak. */
+         SV* tsv = sv_2mortal(newSVsv(sv));
+        
+        SvUTF8_on(tsv);
+        sv_utf8_downgrade(tsv, FALSE);
+        tmps = SvPVX(tsv);
+    }
     while (*tmps && len && isSPACE(*tmps))
         tmps++, len--;
     if (*tmps == '0')
@@ -3178,15 +3198,15 @@ PP(pp_crypt)
     STRLEN n_a;
     STRLEN len;
     char *tmps = SvPV(left, len);
+
     if (DO_UTF8(left)) {
-         /* If Unicode, try to dowgrade.
+         /* If Unicode, try to downgrade.
          * If not possible, croak.
          * Yes, we made this up.  */
          SV* tsv = sv_2mortal(newSVsv(left));
-        
+
         SvUTF8_on(tsv);
-        if (!sv_utf8_downgrade(tsv, FALSE))
-             Perl_croak(aTHX_ "Wide character in crypt");
+        sv_utf8_downgrade(tsv, FALSE);
         tmps = SvPVX(tsv);
     }
 #   ifdef FCRYPT

diff --git a/t/op/oct.t b/t/op/oct.t
index 06bcf3e..f996b48 100755 (executable)
--- a/t/op/oct.t
+++ b/t/op/oct.t
@@ -2,7 +2,7 @@
 
 # tests 51 onwards aren't all warnings clean. (intentionally)
 
-print "1..69\n";
+print "1..71\n";
 
 my $test = 1;
 
@@ -145,3 +145,8 @@ test ('hex', "x3A",  0x3A);
 test ('hex', "0x4",     4);
 test ('hex', "x4",      4);
 
+eval '$a = oct "10\x{100}"';
+print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval '$a = hex "ab\x{100}"';
+print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++;