Copyright++. (Not all the toplevel *.h have one, it seems.)

[p5sagit/p5-mst-13.2.git] / pp.c

diff --git a/pp.c b/pp.c
index 9237a8b..ddd27bf 100644 (file)
--- 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.
@@ -15,6 +15,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PP_C
 #include "perl.h"
+#include "keywords.h"
 
 /* variations on pp_null */
 
@@ -365,6 +366,8 @@ PP(pp_prototype)
                I32 oa;
                char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 
+               if (code == -KEY_chop || code == -KEY_chomp)
+                   goto set;
                while (i < MAXO) {      /* The slow way. */
                    if (strEQ(s + 6, PL_op_name[i])
                        || strEQ(s + 6, PL_op_desc[i]))
@@ -1120,8 +1123,8 @@ PP(pp_modulo)
     {
        UV left  = 0;
        UV right = 0;
-       bool left_neg;
-       bool right_neg;
+       bool left_neg = FALSE;
+       bool right_neg = FALSE;
        bool use_double = FALSE;
        bool dright_valid = FALSE;
        NV dright = 0.0;
@@ -2255,7 +2258,7 @@ PP(pp_complement)
              while (tmps < send) {
                  UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
                  tmps += UTF8SKIP(tmps);
-                 result = uvchr_to_utf8(result, ~c);
+                 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
              }
              *result = '\0';
              result -= targlen;
@@ -2624,7 +2627,7 @@ PP(pp_log)
       value = POPn;
       if (value <= 0.0) {
        SET_NUMERIC_STANDARD();
-       DIE(aTHX_ "Can't take log of %g", value);
+       DIE(aTHX_ "Can't take log of %"NVgf, value);
       }
       value = Perl_log(value);
       XPUSHn(value);
@@ -2640,7 +2643,7 @@ PP(pp_sqrt)
       value = POPn;
       if (value < 0.0) {
        SET_NUMERIC_STANDARD();
-       DIE(aTHX_ "Can't take sqrt of %g", value);
+       DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
       }
       value = Perl_sqrt(value);
       XPUSHn(value);
@@ -2788,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);
@@ -2808,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')
@@ -3145,7 +3168,8 @@ PP(pp_chr)
 
     if (value > 255 && !IN_BYTES) {
        SvGROW(TARG, UNISKIP(value)+1);
-       tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
+       tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value,
+                                         UNICODE_ALLOW_SUPER);
        SvCUR_set(TARG, tmps - SvPVX(TARG));
        *tmps = '\0';
        (void)SvPOK_only(TARG);
@@ -3174,26 +3198,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.");
@@ -3844,7 +3864,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;