[perl #35059] [PATCH] caller() skips frames (such as eval() frames) if $^P set

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

diff --git a/doop.c b/doop.c
index ffa1d1b..a8691d9 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1,7 +1,7 @@
 /*    doop.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, by Larry Wall and others
+ *    2000, 2001, 2002, 2004, 2005, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -12,6 +12,11 @@
  * "'So that was the job I felt I had to do when I started,' thought Sam."
  */
 
+/* This file contains some common functions needed to carry out certain
+ * ops. For example both pp_schomp() and pp_chomp() - scalar and array
+ * chomp operations - call the function do_chomp() found in this file.
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_DOOP_C
 #include "perl.h"
@@ -333,7 +338,7 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)
 
     if (grows) {
        /* d needs to be bigger than s, in case e.g. upgrading is required */
-       New(0, d, len*3+UTF8_MAXLEN, U8);
+       New(0, d, len * 3 + UTF8_MAXBYTES, U8);
        dend = d + len * 3;
        dstart = d;
     }
@@ -365,10 +370,10 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)
 
        if (d > dend) {
            STRLEN clen = d - dstart;
-           STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+           STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
            if (!grows)
                Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
-           Renew(dstart, nlen+UTF8_MAXLEN, U8);
+           Renew(dstart, nlen + UTF8_MAXBYTES, U8);
            d = dstart + clen;
            dend = dstart + nlen;
        }
@@ -475,7 +480,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
 
     if (grows) {
        /* d needs to be bigger than s, in case e.g. upgrading is required */
-       New(0, d, len*3+UTF8_MAXLEN, U8);
+       New(0, d, len * 3 + UTF8_MAXBYTES, U8);
        dend = d + len * 3;
        dstart = d;
     }
@@ -491,10 +496,10 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
        
            if (d > dend) {
                STRLEN clen = d - dstart;
-               STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+               STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
                if (!grows)
                    Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
-               Renew(dstart, nlen+UTF8_MAXLEN, U8);
+               Renew(dstart, nlen + UTF8_MAXBYTES, U8);
                d = dstart + clen;
                dend = dstart + nlen;
            }
@@ -545,10 +550,10 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
            uv = swash_fetch(rv, s, TRUE);
            if (d > dend) {
                STRLEN clen = d - dstart;
-               STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+               STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
                if (!grows)
                    Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
-               Renew(dstart, nlen+UTF8_MAXLEN, U8);
+               Renew(dstart, nlen + UTF8_MAXBYTES, U8);
                d = dstart + clen;
                dend = dstart + nlen;
            }
@@ -669,10 +674,9 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s
        ++mark;
     }
 
-    sv_setpv(sv, "");
+    sv_setpvn(sv, "", 0);
     /* sv_setpv retains old UTF8ness [perl #24846] */
-    if (SvUTF8(sv))
-       SvUTF8_off(sv);
+    SvUTF8_off(sv);
 
     if (PL_tainting && SvMAGICAL(sv))
        SvTAINTED_off(sv);
@@ -1008,6 +1012,8 @@ Perl_do_chomp(pTHX_ register SV *sv)
     STRLEN len;
     STRLEN n_a;
     char *s;
+    char *temp_buffer = NULL;
+    SV* svrecode = Nullsv;
 
     if (RsSNARF(PL_rs))
        return 0;
@@ -1043,6 +1049,18 @@ Perl_do_chomp(pTHX_ register SV *sv)
         if (SvREADONLY(sv))
             Perl_croak(aTHX_ PL_no_modify);
     }
+
+    if (PL_encoding) {
+       if (!SvUTF8(sv)) {
+       /* XXX, here sv is utf8-ized as a side-effect!
+          If encoding.pm is used properly, almost string-generating
+          operations, including literal strings, chr(), input data, etc.
+          should have been utf8-ized already, right?
+       */
+           sv_recode_to_utf8(sv, PL_encoding);
+       }
+    }
+
     s = SvPV(sv, len);
     if (s && len) {
        s += --len;
@@ -1057,8 +1075,43 @@ Perl_do_chomp(pTHX_ register SV *sv)
            }
        }
        else {
-           STRLEN rslen;
+           STRLEN rslen, rs_charlen;
            char *rsptr = SvPV(PL_rs, rslen);
+
+           rs_charlen = SvUTF8(PL_rs)
+               ? sv_len_utf8(PL_rs)
+               : rslen;
+
+           if (SvUTF8(PL_rs) != SvUTF8(sv)) {
+               /* Assumption is that rs is shorter than the scalar.  */
+               if (SvUTF8(PL_rs)) {
+                   /* RS is utf8, scalar is 8 bit.  */
+                   bool is_utf8 = TRUE;
+                   temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
+                                                        &rslen, &is_utf8);
+                   if (is_utf8) {
+                       /* Cannot downgrade, therefore cannot possibly match
+                        */
+                       assert (temp_buffer == rsptr);
+                       temp_buffer = NULL;
+                       goto nope;
+                   }
+                   rsptr = temp_buffer;
+               }
+               else if (PL_encoding) {
+                   /* RS is 8 bit, encoding.pm is used.
+                    * Do not recode PL_rs as a side-effect. */
+                  svrecode = newSVpvn(rsptr, rslen);
+                  sv_recode_to_utf8(svrecode, PL_encoding);
+                  rsptr = SvPV(svrecode, rslen);
+                  rs_charlen = sv_len_utf8(svrecode);
+               }
+               else {
+                   /* RS is 8 bit, scalar is utf8.  */
+                   temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
+                   rsptr = temp_buffer;
+               }
+           }
            if (rslen == 1) {
                if (*s != *rsptr)
                    goto nope;
@@ -1071,7 +1124,7 @@ Perl_do_chomp(pTHX_ register SV *sv)
                s -= rslen - 1;
                if (memNE(s, rsptr, rslen))
                    goto nope;
-               count += rslen;
+               count += rs_charlen;
            }
        }
        s = SvPV_force(sv, n_a);
@@ -1081,6 +1134,11 @@ Perl_do_chomp(pTHX_ register SV *sv)
        SvSETMAGIC(sv);
     }
   nope:
+
+    if (svrecode)
+        SvREFCNT_dec(svrecode);
+
+    Safefree(temp_buffer);
     return count;
 }
 
@@ -1112,8 +1170,8 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 
     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
        sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
-    lsave = lc = SvPV(left, leftlen);
-    rsave = rc = SvPV(right, rightlen);
+    lsave = lc = SvPV_nomg(left, leftlen);
+    rsave = rc = SvPV_nomg(right, rightlen);
     len = leftlen < rightlen ? leftlen : rightlen;
     lensave = len;
     if ((left_utf || right_utf) && (sv == left || sv == right)) {
@@ -1122,7 +1180,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     }
     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
        STRLEN n_a;
-       dc = SvPV_force(sv, n_a);
+       dc = SvPV_force_nomg(sv, n_a);
        if (SvCUR(sv) < (STRLEN)len) {
            dc = SvGROW(sv, (STRLEN)(len + 1));
            (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
@@ -1360,3 +1418,12 @@ Perl_do_kv(pTHX)
     return NORMAL;
 }
 
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/