From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Sun, 13 Jan 2002 18:27:00 +0000 (+0000)
Subject: Make the crypt() pickier: if downgrading doesn't work,
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f2791508ba1ad17a1652fe09ecc58a5c83cae5d7;p=p5sagit%2Fp5-mst-13.2.git

Make the crypt() pickier: if downgrading doesn't work,
croak.

p4raw-id: //depot/perl@14244
---

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 48c4849..8fcc060 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -865,10 +865,12 @@ back.  Look at the F<by-module/Crypt> and F<by-module/PGP> directories
 on your favorite CPAN mirror for a slew of potentially useful
 modules.
 
-If using crypt() on a Unicode string (which potentially has
-characters with codepoints above 255), Perl tries to make sense of
-the situation by using only the low eight bits of the characters when
-calling crypt().
+If using crypt() on a Unicode string (which I<potentially> has
+characters with codepoints above 255), Perl tries to make sense
+of the situation by trying to downgrade (a copy of the string)
+the string back to an eight-bit byte string before calling crypt()
+(on that copy).  If that works, good.  If not, crypt() dies with
+C<Wide character in crypt>.
 
 =item dbmclose HASH
 
diff --git a/pp.c b/pp.c
index 319adaf..0d7f75b 100644
--- a/pp.c
+++ b/pp.c
@@ -3178,26 +3178,22 @@ PP(pp_crypt)
     STRLEN n_a;
     STRLEN len;
     char *tmps = SvPV(left, len);
-    char *t    = 0;
     if (DO_UTF8(left)) {
-         /* If Unicode take the crypt() of the low 8 bits of
-	  * the characters of the string.  Yes, we made this up.  */
-	 char *s    = tmps;
-	 char *send = tmps + len;
-	 STRLEN i   = 0;
-	 Newz(688, t, len + 1, char);
-	 while (s < send) {
-	      t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
-	      s += UTF8SKIP(s);
-	 }
-	 tmps = t;
+         /* If Unicode, try to dowgrade.
+	  * 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");
+	 tmps = SvPVX(tsv);
     }
 #   ifdef FCRYPT
     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
 #   else
     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
 #   endif
-    Safefree(t);
 #else
     DIE(aTHX_
       "The crypt() function is unimplemented due to excessive paranoia.");
diff --git a/t/op/crypt.t b/t/op/crypt.t
index 8beb41d..d11a2a0 100644
--- a/t/op/crypt.t
+++ b/t/op/crypt.t
@@ -14,7 +14,7 @@ BEGIN {
         skip_all("crypt unimplemented");
     }
     else {
-        plan(tests => 2);
+        plan(tests => 4);
     }
 }
 
@@ -30,4 +30,14 @@ BEGIN {
 
 ok(substr(crypt("ab", "cd"), 2) ne substr(crypt("ab", "ce"), 2), "salt makes a difference");
 
-ok(crypt("HI", "HO") eq crypt(join("",map{chr($_+256)}unpack"C*","HI"), "HO"), "low eight bits of Unicode");
+$a = "a\xFF\x{100}";
+
+eval {$b = crypt($a, "cd")};
+like($@, qr/Wide character in crypt/, "wide characters ungood");
+
+chop $a; # throw away the wide character
+
+eval {$b = crypt($a, "cd")};
+is($@, '',                   "downgrade to eight bit characters");
+is($b, crypt("a\xFF", "cd"), "downgrade results agree");
+