Must remember to update MANIFEST, OK?

[perl5.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index 2783d69..fc75c72 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -231,7 +231,6 @@ PP(pp_substcont)
        if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
            cx->sb_rxtainted |= 2;
        sv_catsv(dstr, POPs);
-       FREETMPS; /* Prevent excess tmp stack */
 
        /* Are we done */
        if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
@@ -439,7 +438,6 @@ PP(pp_formline)
     SV * nsv = NULL;
     OP * parseres = NULL;
     const char *fmt;
-    bool oneline;
 
     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
        if (SvREADONLY(tmpForm)) {
@@ -505,6 +503,7 @@ PP(pp_formline)
                *t = '\0';
                sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
                t = SvEND(PL_formtarget);
+               f += arg;
                break;
            }
            if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
@@ -765,51 +764,76 @@ PP(pp_formline)
 
        case FF_LINESNGL:
            chopspace = 0;
-           oneline = TRUE;
-           goto ff_line;
        case FF_LINEGLOB:
-           oneline = FALSE;
-       ff_line:
            {
+               const bool oneline = fpc[-1] == FF_LINESNGL;
                const char *s = item = SvPV_const(sv, len);
+               item_is_utf8 = DO_UTF8(sv);
                itemsize = len;
-               if ((item_is_utf8 = DO_UTF8(sv)))
-                   itemsize = sv_len_utf8(sv);
                if (itemsize) {
-                   bool chopped = FALSE;
+                   STRLEN to_copy = itemsize;
                    const char *const send = s + len;
+                   const U8 *source = (const U8 *) s;
+                   U8 *tmp = NULL;
+
                    gotsome = TRUE;
                    chophere = s + itemsize;
                    while (s < send) {
                        if (*s++ == '\n') {
                            if (oneline) {
-                               chopped = TRUE;
+                               to_copy = s - SvPVX_const(sv) - 1;
                                chophere = s;
                                break;
                            } else {
                                if (s == send) {
                                    itemsize--;
-                                   chopped = TRUE;
+                                   to_copy--;
                                } else
                                    lines++;
                            }
                        }
                    }
-                   SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
-                   if (targ_is_utf8)
-                       SvUTF8_on(PL_formtarget);
-                   if (oneline) {
-                       SvCUR_set(sv, chophere - item);
-                       sv_catsv(PL_formtarget, sv);
-                       SvCUR_set(sv, itemsize);
-                   } else
-                       sv_catsv(PL_formtarget, sv);
-                   if (chopped)
-                       SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
-                   SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+                   if (targ_is_utf8 && !item_is_utf8) {
+                       source = tmp = bytes_to_utf8(source, &to_copy);
+                       SvCUR_set(PL_formtarget,
+                                 t - SvPVX_const(PL_formtarget));
+                   } else {
+                       if (item_is_utf8 && !targ_is_utf8) {
+                           /* Upgrade targ to UTF8, and then we reduce it to
+                              a problem we have a simple solution for.  */
+                           SvCUR_set(PL_formtarget,
+                                     t - SvPVX_const(PL_formtarget));
+                           targ_is_utf8 = TRUE;
+                           /* Don't need get magic.  */
+                           sv_utf8_upgrade_flags(PL_formtarget, 0);
+                       } else {
+                           SvCUR_set(PL_formtarget,
+                                     t - SvPVX_const(PL_formtarget));
+                       }
+
+                       /* Easy. They agree.  */
+                       assert (item_is_utf8 == targ_is_utf8);
+                   }
+                   SvGROW(PL_formtarget,
+                          SvCUR(PL_formtarget) + to_copy + fudge + 1);
                    t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
-                   if (item_is_utf8)
-                       targ_is_utf8 = TRUE;
+
+                   Copy(source, t, to_copy, char);
+                   t += to_copy;
+                   SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
+                   if (item_is_utf8) {
+                       if (SvGMAGICAL(sv)) {
+                           /* Mustn't call sv_pos_b2u() as it does a second
+                              mg_get(). Is this a bug? Do we need a _flags()
+                              variant? */
+                           itemsize = utf8_length(source, source + itemsize);
+                       } else {
+                           sv_pos_b2u(sv, &itemsize);
+                       }
+                       assert(!tmp);
+                   } else if (tmp) {
+                       Safefree(tmp);
+                   }
                }
                break;
            }
@@ -2149,8 +2173,9 @@ PP(pp_return)
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
     LEAVESUB(sv);
-    if (clear_errsv)
-       sv_setpvn(ERRSV,"",0);
+    if (clear_errsv) {
+       CLEAR_ERRSV();
+    }
     return retop;
 }
 
@@ -3002,7 +3027,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
        PL_in_eval |= EVAL_KEEPERR;
     else
-       sv_setpvn(ERRSV,"",0);
+       CLEAR_ERRSV();
     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
        SV **newsp;                     /* Used by POPBLOCK. */
        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
@@ -3353,11 +3378,11 @@ PP(pp_require)
                            }
                        }
 
-                       if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
+                       if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
                            arg = SvRV(arg);
                        }
 
-                       if (SvTYPE(arg) == SVt_PVGV) {
+                       if (isGV_with_GP(arg)) {
                            IO * const io = GvIO((GV *)arg);
 
                            ++filter_has_file;
@@ -3773,8 +3798,9 @@ PP(pp_leaveeval)
     }
     else {
        LEAVE;
-       if (!(save_flags & OPf_SPECIAL))
-           sv_setpvn(ERRSV,"",0);
+       if (!(save_flags & OPf_SPECIAL)) {
+           CLEAR_ERRSV();
+       }
     }
 
     RETURNOP(retop);
@@ -3818,7 +3844,7 @@ Perl_create_eval_scope(pTHX_ U32 flags)
     if (flags & G_KEEPERR)
        PL_in_eval |= EVAL_KEEPERR;
     else
-       sv_setpvn(ERRSV,"",0);
+       CLEAR_ERRSV();
     if (flags & G_FAKINGEVAL) {
        PL_eval_root = PL_op; /* Only needed so that goto works right. */
     }
@@ -3877,7 +3903,7 @@ PP(pp_leavetry)
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
     LEAVE;
-    sv_setpvn(ERRSV,"",0);
+    CLEAR_ERRSV();
     RETURN;
 }
 
@@ -4013,6 +4039,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        && (Other = d)) )
        
 
+#   define SM_OBJECT ( \
+          (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))          \
+    ||                                                                 \
+          (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )        \
+
 #   define SM_OTHER_REF(type) \
        (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
 
@@ -4044,6 +4075,9 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     if (SvGMAGICAL(e))
        e = sv_mortalcopy(e);
 
+    if (SM_OBJECT)
+       Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+
     if (SM_CV_NEP) {
        I32 c;