X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b851fbc1add6c3d9fa6158884279133c311a3efc..95a3fe12cabdd424376b542e91e48eaae05c97fb:/pp.c

diff --git a/pp.c b/pp.c
index eb386ee..2d155eb 100644
--- a/pp.c
+++ b/pp.c
@@ -1,6 +1,6 @@
 /*    pp.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -555,7 +555,7 @@ PP(pp_gelem)
     case 'F':
 	if (strEQ(elem, "FILEHANDLE")) {
 	    /* finally deprecated in 5.8.0 */
-	    deprecate("*glob{FILEHANDLE}");
+	    deprecate_old("*glob{FILEHANDLE}");
 	    tmpRef = (SV*)GvIOp(gv);
 	}
 	else
@@ -1006,7 +1006,7 @@ PP(pp_divide)
 {
     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
     /* Only try to do UV divide first
-       if ((SLOPPYDIVIDE is true) or 
+       if ((SLOPPYDIVIDE is true) or
            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
             to preserve))
        The assumption is that it is better to use floating point divide
@@ -2702,7 +2702,7 @@ PP(pp_int)
 #   if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
 #       ifdef HAS_MODFL_POW32_BUG
 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
-                { 
+                {
                     NV offset = Perl_modf(value, &value);
                     (void)Perl_modf(offset, &offset);
                     value += offset;
@@ -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')
@@ -3134,7 +3154,7 @@ PP(pp_ord)
     }
 
     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
-    
+
     RETURN;
 }
 
@@ -3148,8 +3168,7 @@ PP(pp_chr)
 
     if (value > 255 && !IN_BYTES) {
 	SvGROW(TARG, UNISKIP(value)+1);
-	tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value,
-					  UNICODE_ALLOW_SUPER);
+	tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
 	SvCUR_set(TARG, tmps - SvPVX(TARG));
 	*tmps = '\0';
 	(void)SvPOK_only(TARG);
@@ -3178,26 +3197,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. */
-	 char *s    = tmps;
-	 char *send = tmps + len;
-	 STRLEN i   = 0;
-	 Newz(688, t, len, char);
-	 while (s < send) {
-	      t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
-	      s += UTF8SKIP(s);
-	 }
-	 tmps = t;
+         /* If Unicode, try to downgrade.
+	  * If not possible, croak.
+	  * Yes, we made this up.  */
+         SV* tsv = sv_2mortal(newSVsv(left));
+
+	 SvUTF8_on(tsv);
+	 sv_utf8_downgrade(tsv, FALSE);
+	 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.");
@@ -3335,8 +3350,10 @@ PP(pp_uc)
 	    SETs(TARG);
 	}
 	else {
+	    STRLEN nchar = utf8_length(s, s + len);
+
 	    (void)SvUPGRADE(TARG, SVt_PV);
-	    SvGROW(TARG, (len * 2) + 1);
+	    SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
 	    (void)SvPOK_only(TARG);
 	    d = (U8*)SvPVX(TARG);
 	    send = s + len;
@@ -3402,8 +3419,10 @@ PP(pp_lc)
 	    SETs(TARG);
 	}
 	else {
+	    STRLEN nchar = utf8_length(s, s + len);
+
 	    (void)SvUPGRADE(TARG, SVt_PV);
-	    SvGROW(TARG, (len * 2) + 1);
+	    SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
 	    (void)SvPOK_only(TARG);
 	    d = (U8*)SvPVX(TARG);
 	    send = s + len;
@@ -3848,7 +3867,7 @@ PP(pp_anonhash)
 	if (MARK < SP)
 	    sv_setsv(val, *++MARK);
 	else if (ckWARN(WARN_MISC))
-	    Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+	    Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
 	(void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;
@@ -3907,8 +3926,11 @@ PP(pp_splice)
 	offset = 0;
 	length = AvMAX(ary) + 1;
     }
-    if (offset > AvFILLp(ary) + 1)
+    if (offset > AvFILLp(ary) + 1) {
+	if (ckWARN(WARN_MISC))
+	    Perl_warner(aTHX_ WARN_MISC, "splice() offset past end of array" );
 	offset = AvFILLp(ary) + 1;
+    }
     after = AvFILLp(ary) + 1 - (offset + length);
     if (after < 0) {				/* not that much array */
 	length += after;			/* offset+length now in array */
@@ -4545,14 +4567,7 @@ PP(pp_lock)
     dSP;
     dTOPss;
     SV *retsv = sv;
-#ifdef USE_5005THREADS
-    sv_lock(sv);
-#endif /* USE_5005THREADS */
-#ifdef USE_ITHREADS
-    shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
-    if(ssv)
-        Perl_sharedsv_lock(aTHX_ ssv);
-#endif /* USE_ITHREADS */
+    SvLOCK(sv);
     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
 	|| SvTYPE(retsv) == SVt_PVCV) {
 	retsv = refto(retsv);