pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *      Now far ahead the Road has gone,
  13  *          And I must follow, if I can,
  14  *      Pursuing it with eager feet,
  15  *          Until it joins some larger way
  16  *      Where many paths and errands meet.
  17  *          And whither then?  I cannot say.
  18  *
  19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains control-oriented pp ("push/pop") functions that
  23  * execute the opcodes that make up a perl program. A typical pp function
  24  * expects to find its arguments on the stack, and usually pushes its
  25  * results onto the stack, hence the 'pp' terminology. Each OP structure
  26  * contains a pointer to the relevant pp_foo() function.
  27  *
  28  * Control-oriented means things like pp_enteriter() and pp_next(), which
  29  * alter the flow of control of the program.
  30  */
  31
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_PP_CTL_C
  35 #include "perl.h"
  36
  37 #ifndef WORD_ALIGN
  38 #define WORD_ALIGN sizeof(U32)
  39 #endif
  40
  41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  42
  43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  44
  45 PP(pp_wantarray)
  46 {
  47     dVAR;
  48     dSP;
  49     I32 cxix;
  50     EXTEND(SP, 1);
  51
  52     cxix = dopoptosub(cxstack_ix);
  53     if (cxix < 0)
  54         RETPUSHUNDEF;
  55
  56     switch (cxstack[cxix].blk_gimme) {
  57     case G_ARRAY:
  58         RETPUSHYES;
  59     case G_SCALAR:
  60         RETPUSHNO;
  61     default:
  62         RETPUSHUNDEF;
  63     }
  64 }
  65
  66 PP(pp_regcreset)
  67 {
  68     dVAR;
  69     /* XXXX Should store the old value to allow for tie/overload - and
  70        restore in regcomp, where marked with XXXX. */
  71     PL_reginterp_cnt = 0;
  72     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV *tmpstr;
  82     REGEXP *re = NULL;
  83
  84     /* prevent recompiling under /o and ithreads. */
  85 #if defined(USE_ITHREADS)
  86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  87         if (PL_op->op_flags & OPf_STACKED) {
  88             dMARK;
  89             SP = MARK;
  90         }
  91         else
  92             (void)POPs;
  93         RETURN;
  94     }
  95 #endif
  96
  97 #define tryAMAGICregexp(rx)                     \
  98     STMT_START {                                \
  99         SvGETMAGIC(rx);                         \
 100         if (SvROK(rx) && SvAMAGIC(rx)) {        \
 101             SV *sv = AMG_CALLun(rx, regexp);    \
 102             if (sv) {                           \
 103                 if (SvROK(sv))                  \
 104                     sv = SvRV(sv);              \
 105                 if (SvTYPE(sv) != SVt_REGEXP)   \
 106                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
 107                 rx = sv;                        \
 108             }                                   \
 109         }                                       \
 110     } STMT_END
 111
 112
 113     if (PL_op->op_flags & OPf_STACKED) {
 114         /* multiple args; concatentate them */
 115         dMARK; dORIGMARK;
 116         tmpstr = PAD_SV(ARGTARG);
 117         sv_setpvs(tmpstr, "");
 118         while (++MARK <= SP) {
 119             SV *msv = *MARK;
 120             SV *sv;
 121
 122             tryAMAGICregexp(msv);
 123
 124             if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
 125                 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
 126             {
 127                sv_setsv(tmpstr, sv);
 128                continue;
 129             }
 130             sv_catsv_nomg(tmpstr, msv);
 131         }
 132         SvSETMAGIC(tmpstr);
 133         SP = ORIGMARK;
 134     }
 135     else {
 136         tmpstr = POPs;
 137         tryAMAGICregexp(tmpstr);
 138     }
 139
 140 #undef tryAMAGICregexp
 141
 142     if (SvROK(tmpstr)) {
 143         SV * const sv = SvRV(tmpstr);
 144         if (SvTYPE(sv) == SVt_REGEXP)
 145             re = (REGEXP*) sv;
 146     }
 147     else if (SvTYPE(tmpstr) == SVt_REGEXP)
 148         re = (REGEXP*) tmpstr;
 149
 150     if (re) {
 151         /* The match's LHS's get-magic might need to access this op's reg-
 152            exp (as is sometimes the case with $';  see bug 70764).  So we
 153            must call get-magic now before we replace the regexp. Hopeful-
 154            ly this hack can be replaced with the approach described at
 155            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
 156            /msg122415.html some day. */
 157         if(pm->op_type == OP_MATCH) {
 158          SV *lhs;
 159          const bool was_tainted = PL_tainted;
 160          if (pm->op_flags & OPf_STACKED)
 161             lhs = TOPs;
 162          else if (pm->op_private & OPpTARGET_MY)
 163             lhs = PAD_SV(pm->op_targ);
 164          else lhs = DEFSV;
 165          SvGETMAGIC(lhs);
 166          /* Restore the previous value of PL_tainted (which may have been
 167             modified by get-magic), to avoid incorrectly setting the
 168             RXf_TAINTED flag further down. */
 169          PL_tainted = was_tainted;
 170         }
 171
 172         re = reg_temp_copy(NULL, re);
 173         ReREFCNT_dec(PM_GETRE(pm));
 174         PM_SETRE(pm, re);
 175     }
 176     else {
 177         STRLEN len = 0;
 178         const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
 179
 180         re = PM_GETRE(pm);
 181         assert (re != (REGEXP*) &PL_sv_undef);
 182
 183         /* Check against the last compiled regexp. */
 184         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
 185             memNE(RX_PRECOMP(re), t, len))
 186         {
 187             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
 188             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 189             if (re) {
 190                 ReREFCNT_dec(re);
 191 #ifdef USE_ITHREADS
 192                 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
 193 #else
 194                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 195 #endif
 196             } else if (PL_curcop->cop_hints_hash) {
 197                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 198                                        "regcomp", 7, 0, 0);
 199                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 200                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 201             }
 202
 203             if (PL_op->op_flags & OPf_SPECIAL)
 204                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 205
 206             if (DO_UTF8(tmpstr)) {
 207                 assert (SvUTF8(tmpstr));
 208             } else if (SvUTF8(tmpstr)) {
 209                 /* Not doing UTF-8, despite what the SV says. Is this only if
 210                    we're trapped in use 'bytes'?  */
 211                 /* Make a copy of the octet sequence, but without the flag on,
 212                    as the compiler now honours the SvUTF8 flag on tmpstr.  */
 213                 STRLEN len;
 214                 const char *const p = SvPV(tmpstr, len);
 215                 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
 216             }
 217             else if (SvAMAGIC(tmpstr)) {
 218                 /* make a copy to avoid extra stringifies */
 219                 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
 220             }
 221
 222             /* If it is gmagical, create a mortal copy, but without calling
 223                get-magic, as we have already done that. */
 224             if(SvGMAGICAL(tmpstr)) {
 225                 SV *mortalcopy = sv_newmortal();
 226                 sv_setsv_flags(mortalcopy, tmpstr, 0);
 227                 tmpstr = mortalcopy;
 228             }
 229
 230             if (eng)
 231                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 232             else
 233                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 234
 235             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 236                                            inside tie/overload accessors.  */
 237         }
 238     }
 239
 240     re = PM_GETRE(pm);
 241
 242 #ifndef INCOMPLETE_TAINTS
 243     if (PL_tainting) {
 244         if (PL_tainted)
 245             RX_EXTFLAGS(re) |= RXf_TAINTED;
 246         else
 247             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 248     }
 249 #endif
 250
 251     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 252         pm = PL_curpm;
 253
 254
 255 #if !defined(USE_ITHREADS)
 256     /* can't change the optree at runtime either */
 257     /* PMf_KEEP is handled differently under threads to avoid these problems */
 258     if (pm->op_pmflags & PMf_KEEP) {
 259         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 260         cLOGOP->op_first->op_next = PL_op->op_next;
 261     }
 262 #endif
 263     RETURN;
 264 }
 265
 266 PP(pp_substcont)
 267 {
 268     dVAR;
 269     dSP;
 270     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 271     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 272     register SV * const dstr = cx->sb_dstr;
 273     register char *s = cx->sb_s;
 274     register char *m = cx->sb_m;
 275     char *orig = cx->sb_orig;
 276     register REGEXP * const rx = cx->sb_rx;
 277     SV *nsv = NULL;
 278     REGEXP *old = PM_GETRE(pm);
 279
 280     PERL_ASYNC_CHECK();
 281
 282     if(old != rx) {
 283         if(old)
 284             ReREFCNT_dec(old);
 285         PM_SETRE(pm,ReREFCNT_inc(rx));
 286     }
 287
 288     rxres_restore(&cx->sb_rxres, rx);
 289     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 290
 291     if (cx->sb_iters++) {
 292         const I32 saviters = cx->sb_iters;
 293         if (cx->sb_iters > cx->sb_maxiters)
 294             DIE(aTHX_ "Substitution loop");
 295
 296         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 297
 298         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 299             cx->sb_rxtainted |= 2;
 300         sv_catsv_nomg(dstr, POPs);
 301         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 302         s -= RX_GOFS(rx);
 303
 304         /* Are we done */
 305         if (CxONCE(cx) || s < orig ||
 306                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 307                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 308                              ((cx->sb_rflags & REXEC_COPY_STR)
 309                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 310                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 311         {
 312             SV * const targ = cx->sb_targ;
 313
 314             assert(cx->sb_strend >= s);
 315             if(cx->sb_strend > s) {
 316                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 317                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 318                  else
 319                       sv_catpvn(dstr, s, cx->sb_strend - s);
 320             }
 321             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 322
 323 #ifdef PERL_OLD_COPY_ON_WRITE
 324             if (SvIsCOW(targ)) {
 325                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 326             } else
 327 #endif
 328             {
 329                 SvPV_free(targ);
 330             }
 331             SvPV_set(targ, SvPVX(dstr));
 332             SvCUR_set(targ, SvCUR(dstr));
 333             SvLEN_set(targ, SvLEN(dstr));
 334             if (DO_UTF8(dstr))
 335                 SvUTF8_on(targ);
 336             SvPV_set(dstr, NULL);
 337
 338             TAINT_IF(cx->sb_rxtainted & 1);
 339             if (pm->op_pmflags & PMf_NONDESTRUCT)
 340                 PUSHs(targ);
 341             else
 342                 mPUSHi(saviters - 1);
 343
 344             (void)SvPOK_only_UTF8(targ);
 345             TAINT_IF(cx->sb_rxtainted);
 346             SvSETMAGIC(targ);
 347             SvTAINT(targ);
 348
 349             LEAVE_SCOPE(cx->sb_oldsave);
 350             POPSUBST(cx);
 351             RETURNOP(pm->op_next);
 352         }
 353         cx->sb_iters = saviters;
 354     }
 355     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 356         m = s;
 357         s = orig;
 358         cx->sb_orig = orig = RX_SUBBEG(rx);
 359         s = orig + (m - s);
 360         cx->sb_strend = s + (cx->sb_strend - m);
 361     }
 362     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 363     if (m > s) {
 364         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 365             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 366         else
 367             sv_catpvn(dstr, s, m-s);
 368     }
 369     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 370     { /* Update the pos() information. */
 371         SV * const sv = cx->sb_targ;
 372         MAGIC *mg;
 373         SvUPGRADE(sv, SVt_PVMG);
 374         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 375 #ifdef PERL_OLD_COPY_ON_WRITE
 376             if (SvIsCOW(sv))
 377                 sv_force_normal_flags(sv, 0);
 378 #endif
 379             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 380                              NULL, 0);
 381         }
 382         mg->mg_len = m - orig;
 383     }
 384     if (old != rx)
 385         (void)ReREFCNT_inc(rx);
 386     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 387     rxres_save(&cx->sb_rxres, rx);
 388     PL_curpm = pm;
 389     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 390 }
 391
 392 void
 393 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 394 {
 395     UV *p = (UV*)*rsp;
 396     U32 i;
 397
 398     PERL_ARGS_ASSERT_RXRES_SAVE;
 399     PERL_UNUSED_CONTEXT;
 400
 401     if (!p || p[1] < RX_NPARENS(rx)) {
 402 #ifdef PERL_OLD_COPY_ON_WRITE
 403         i = 7 + RX_NPARENS(rx) * 2;
 404 #else
 405         i = 6 + RX_NPARENS(rx) * 2;
 406 #endif
 407         if (!p)
 408             Newx(p, i, UV);
 409         else
 410             Renew(p, i, UV);
 411         *rsp = (void*)p;
 412     }
 413
 414     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 415     RX_MATCH_COPIED_off(rx);
 416
 417 #ifdef PERL_OLD_COPY_ON_WRITE
 418     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 419     RX_SAVED_COPY(rx) = NULL;
 420 #endif
 421
 422     *p++ = RX_NPARENS(rx);
 423
 424     *p++ = PTR2UV(RX_SUBBEG(rx));
 425     *p++ = (UV)RX_SUBLEN(rx);
 426     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 427         *p++ = (UV)RX_OFFS(rx)[i].start;
 428         *p++ = (UV)RX_OFFS(rx)[i].end;
 429     }
 430 }
 431
 432 static void
 433 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 434 {
 435     UV *p = (UV*)*rsp;
 436     U32 i;
 437
 438     PERL_ARGS_ASSERT_RXRES_RESTORE;
 439     PERL_UNUSED_CONTEXT;
 440
 441     RX_MATCH_COPY_FREE(rx);
 442     RX_MATCH_COPIED_set(rx, *p);
 443     *p++ = 0;
 444
 445 #ifdef PERL_OLD_COPY_ON_WRITE
 446     if (RX_SAVED_COPY(rx))
 447         SvREFCNT_dec (RX_SAVED_COPY(rx));
 448     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 449     *p++ = 0;
 450 #endif
 451
 452     RX_NPARENS(rx) = *p++;
 453
 454     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 455     RX_SUBLEN(rx) = (I32)(*p++);
 456     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 457         RX_OFFS(rx)[i].start = (I32)(*p++);
 458         RX_OFFS(rx)[i].end = (I32)(*p++);
 459     }
 460 }
 461
 462 static void
 463 S_rxres_free(pTHX_ void **rsp)
 464 {
 465     UV * const p = (UV*)*rsp;
 466
 467     PERL_ARGS_ASSERT_RXRES_FREE;
 468     PERL_UNUSED_CONTEXT;
 469
 470     if (p) {
 471 #ifdef PERL_POISON
 472         void *tmp = INT2PTR(char*,*p);
 473         Safefree(tmp);
 474         if (*p)
 475             PoisonFree(*p, 1, sizeof(*p));
 476 #else
 477         Safefree(INT2PTR(char*,*p));
 478 #endif
 479 #ifdef PERL_OLD_COPY_ON_WRITE
 480         if (p[1]) {
 481             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 482         }
 483 #endif
 484         Safefree(p);
 485         *rsp = NULL;
 486     }
 487 }
 488
 489 PP(pp_formline)
 490 {
 491     dVAR; dSP; dMARK; dORIGMARK;
 492     register SV * const tmpForm = *++MARK;
 493     register U32 *fpc;
 494     register char *t;
 495     const char *f;
 496     register I32 arg;
 497     register SV *sv = NULL;
 498     const char *item = NULL;
 499     I32 itemsize  = 0;
 500     I32 fieldsize = 0;
 501     I32 lines = 0;
 502     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 503     const char *chophere = NULL;
 504     char *linemark = NULL;
 505     NV value;
 506     bool gotsome = FALSE;
 507     STRLEN len;
 508     const STRLEN fudge = SvPOK(tmpForm)
 509                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 510     bool item_is_utf8 = FALSE;
 511     bool targ_is_utf8 = FALSE;
 512     SV * nsv = NULL;
 513     OP * parseres = NULL;
 514     const char *fmt;
 515
 516     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 517         if (SvREADONLY(tmpForm)) {
 518             SvREADONLY_off(tmpForm);
 519             parseres = doparseform(tmpForm);
 520             SvREADONLY_on(tmpForm);
 521         }
 522         else
 523             parseres = doparseform(tmpForm);
 524         if (parseres)
 525             return parseres;
 526     }
 527     SvPV_force(PL_formtarget, len);
 528     if (DO_UTF8(PL_formtarget))
 529         targ_is_utf8 = TRUE;
 530     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 531     t += len;
 532     f = SvPV_const(tmpForm, len);
 533     /* need to jump to the next word */
 534     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 535
 536     for (;;) {
 537         DEBUG_f( {
 538             const char *name = "???";
 539             arg = -1;
 540             switch (*fpc) {
 541             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 542             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 543             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 544             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 545             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 546
 547             case FF_CHECKNL:    name = "CHECKNL";       break;
 548             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 549             case FF_SPACE:      name = "SPACE";         break;
 550             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 551             case FF_ITEM:       name = "ITEM";          break;
 552             case FF_CHOP:       name = "CHOP";          break;
 553             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 554             case FF_NEWLINE:    name = "NEWLINE";       break;
 555             case FF_MORE:       name = "MORE";          break;
 556             case FF_LINEMARK:   name = "LINEMARK";      break;
 557             case FF_END:        name = "END";           break;
 558             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 559             case FF_LINESNGL:   name = "LINESNGL";      break;
 560             }
 561             if (arg >= 0)
 562                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 563             else
 564                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 565         } );
 566         switch (*fpc++) {
 567         case FF_LINEMARK:
 568             linemark = t;
 569             lines++;
 570             gotsome = FALSE;
 571             break;
 572
 573         case FF_LITERAL:
 574             arg = *fpc++;
 575             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 576                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 577                 *t = '\0';
 578                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 579                 t = SvEND(PL_formtarget);
 580                 f += arg;
 581                 break;
 582             }
 583             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 584                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 585                 *t = '\0';
 586                 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 587                 t = SvEND(PL_formtarget);
 588                 targ_is_utf8 = TRUE;
 589             }
 590             while (arg--)
 591                 *t++ = *f++;
 592             break;
 593
 594         case FF_SKIP:
 595             f += *fpc++;
 596             break;
 597
 598         case FF_FETCH:
 599             arg = *fpc++;
 600             f += arg;
 601             fieldsize = arg;
 602
 603             if (MARK < SP)
 604                 sv = *++MARK;
 605             else {
 606                 sv = &PL_sv_no;
 607                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 608             }
 609             break;
 610
 611         case FF_CHECKNL:
 612             {
 613                 const char *send;
 614                 const char *s = item = SvPV_const(sv, len);
 615                 itemsize = len;
 616                 if (DO_UTF8(sv)) {
 617                     itemsize = sv_len_utf8(sv);
 618                     if (itemsize != (I32)len) {
 619                         I32 itembytes;
 620                         if (itemsize > fieldsize) {
 621                             itemsize = fieldsize;
 622                             itembytes = itemsize;
 623                             sv_pos_u2b(sv, &itembytes, 0);
 624                         }
 625                         else
 626                             itembytes = len;
 627                         send = chophere = s + itembytes;
 628                         while (s < send) {
 629                             if (*s & ~31)
 630                                 gotsome = TRUE;
 631                             else if (*s == '\n')
 632                                 break;
 633                             s++;
 634                         }
 635                         item_is_utf8 = TRUE;
 636                         itemsize = s - item;
 637                         sv_pos_b2u(sv, &itemsize);
 638                         break;
 639                     }
 640                 }
 641                 item_is_utf8 = FALSE;
 642                 if (itemsize > fieldsize)
 643                     itemsize = fieldsize;
 644                 send = chophere = s + itemsize;
 645                 while (s < send) {
 646                     if (*s & ~31)
 647                         gotsome = TRUE;
 648                     else if (*s == '\n')
 649                         break;
 650                     s++;
 651                 }
 652                 itemsize = s - item;
 653                 break;
 654             }
 655
 656         case FF_CHECKCHOP:
 657             {
 658                 const char *s = item = SvPV_const(sv, len);
 659                 itemsize = len;
 660                 if (DO_UTF8(sv)) {
 661                     itemsize = sv_len_utf8(sv);
 662                     if (itemsize != (I32)len) {
 663                         I32 itembytes;
 664                         if (itemsize <= fieldsize) {
 665                             const char *send = chophere = s + itemsize;
 666                             while (s < send) {
 667                                 if (*s == '\r') {
 668                                     itemsize = s - item;
 669                                     chophere = s;
 670                                     break;
 671                                 }
 672                                 if (*s++ & ~31)
 673                                     gotsome = TRUE;
 674                             }
 675                         }
 676                         else {
 677                             const char *send;
 678                             itemsize = fieldsize;
 679                             itembytes = itemsize;
 680                             sv_pos_u2b(sv, &itembytes, 0);
 681                             send = chophere = s + itembytes;
 682                             while (s < send || (s == send && isSPACE(*s))) {
 683                                 if (isSPACE(*s)) {
 684                                     if (chopspace)
 685                                         chophere = s;
 686                                     if (*s == '\r')
 687                                         break;
 688                                 }
 689                                 else {
 690                                     if (*s & ~31)
 691                                         gotsome = TRUE;
 692                                     if (strchr(PL_chopset, *s))
 693                                         chophere = s + 1;
 694                                 }
 695                                 s++;
 696                             }
 697                             itemsize = chophere - item;
 698                             sv_pos_b2u(sv, &itemsize);
 699                         }
 700                         item_is_utf8 = TRUE;
 701                         break;
 702                     }
 703                 }
 704                 item_is_utf8 = FALSE;
 705                 if (itemsize <= fieldsize) {
 706                     const char *const send = chophere = s + itemsize;
 707                     while (s < send) {
 708                         if (*s == '\r') {
 709                             itemsize = s - item;
 710                             chophere = s;
 711                             break;
 712                         }
 713                         if (*s++ & ~31)
 714                             gotsome = TRUE;
 715                     }
 716                 }
 717                 else {
 718                     const char *send;
 719                     itemsize = fieldsize;
 720                     send = chophere = s + itemsize;
 721                     while (s < send || (s == send && isSPACE(*s))) {
 722                         if (isSPACE(*s)) {
 723                             if (chopspace)
 724                                 chophere = s;
 725                             if (*s == '\r')
 726                                 break;
 727                         }
 728                         else {
 729                             if (*s & ~31)
 730                                 gotsome = TRUE;
 731                             if (strchr(PL_chopset, *s))
 732                                 chophere = s + 1;
 733                         }
 734                         s++;
 735                     }
 736                     itemsize = chophere - item;
 737                 }
 738                 break;
 739             }
 740
 741         case FF_SPACE:
 742             arg = fieldsize - itemsize;
 743             if (arg) {
 744                 fieldsize -= arg;
 745                 while (arg-- > 0)
 746                     *t++ = ' ';
 747             }
 748             break;
 749
 750         case FF_HALFSPACE:
 751             arg = fieldsize - itemsize;
 752             if (arg) {
 753                 arg /= 2;
 754                 fieldsize -= arg;
 755                 while (arg-- > 0)
 756                     *t++ = ' ';
 757             }
 758             break;
 759
 760         case FF_ITEM:
 761             {
 762                 const char *s = item;
 763                 arg = itemsize;
 764                 if (item_is_utf8) {
 765                     if (!targ_is_utf8) {
 766                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 767                         *t = '\0';
 768                         sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
 769                                                                     fudge + 1);
 770                         t = SvEND(PL_formtarget);
 771                         targ_is_utf8 = TRUE;
 772                     }
 773                     while (arg--) {
 774                         if (UTF8_IS_CONTINUED(*s)) {
 775                             STRLEN skip = UTF8SKIP(s);
 776                             switch (skip) {
 777                             default:
 778                                 Move(s,t,skip,char);
 779                                 s += skip;
 780                                 t += skip;
 781                                 break;
 782                             case 7: *t++ = *s++;
 783                             case 6: *t++ = *s++;
 784                             case 5: *t++ = *s++;
 785                             case 4: *t++ = *s++;
 786                             case 3: *t++ = *s++;
 787                             case 2: *t++ = *s++;
 788                             case 1: *t++ = *s++;
 789                             }
 790                         }
 791                         else {
 792                             if ( !((*t++ = *s++) & ~31) )
 793                                 t[-1] = ' ';
 794                         }
 795                     }
 796                     break;
 797                 }
 798                 if (targ_is_utf8 && !item_is_utf8) {
 799                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 800                     *t = '\0';
 801                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 802                     for (; t < SvEND(PL_formtarget); t++) {
 803 #ifdef EBCDIC
 804                         const int ch = *t;
 805                         if (iscntrl(ch))
 806 #else
 807                             if (!(*t & ~31))
 808 #endif
 809                                 *t = ' ';
 810                     }
 811                     break;
 812                 }
 813                 while (arg--) {
 814 #ifdef EBCDIC
 815                     const int ch = *t++ = *s++;
 816                     if (iscntrl(ch))
 817 #else
 818                         if ( !((*t++ = *s++) & ~31) )
 819 #endif
 820                             t[-1] = ' ';
 821                 }
 822                 break;
 823             }
 824
 825         case FF_CHOP:
 826             {
 827                 const char *s = chophere;
 828                 if (chopspace) {
 829                     while (isSPACE(*s))
 830                         s++;
 831                 }
 832                 sv_chop(sv,s);
 833                 SvSETMAGIC(sv);
 834                 break;
 835             }
 836
 837         case FF_LINESNGL:
 838             chopspace = 0;
 839         case FF_LINEGLOB:
 840             {
 841                 const bool oneline = fpc[-1] == FF_LINESNGL;
 842                 const char *s = item = SvPV_const(sv, len);
 843                 item_is_utf8 = DO_UTF8(sv);
 844                 itemsize = len;
 845                 if (itemsize) {
 846                     STRLEN to_copy = itemsize;
 847                     const char *const send = s + len;
 848                     const U8 *source = (const U8 *) s;
 849                     U8 *tmp = NULL;
 850
 851                     gotsome = TRUE;
 852                     chophere = s + itemsize;
 853                     while (s < send) {
 854                         if (*s++ == '\n') {
 855                             if (oneline) {
 856                                 to_copy = s - SvPVX_const(sv) - 1;
 857                                 chophere = s;
 858                                 break;
 859                             } else {
 860                                 if (s == send) {
 861                                     itemsize--;
 862                                     to_copy--;
 863                                 } else
 864                                     lines++;
 865                             }
 866                         }
 867                     }
 868                     if (targ_is_utf8 && !item_is_utf8) {
 869                         source = tmp = bytes_to_utf8(source, &to_copy);
 870                         SvCUR_set(PL_formtarget,
 871                                   t - SvPVX_const(PL_formtarget));
 872                     } else {
 873                         if (item_is_utf8 && !targ_is_utf8) {
 874                             /* Upgrade targ to UTF8, and then we reduce it to
 875                                a problem we have a simple solution for.  */
 876                             SvCUR_set(PL_formtarget,
 877                                       t - SvPVX_const(PL_formtarget));
 878                             targ_is_utf8 = TRUE;
 879                             /* Don't need get magic.  */
 880                             sv_utf8_upgrade_nomg(PL_formtarget);
 881                         } else {
 882                             SvCUR_set(PL_formtarget,
 883                                       t - SvPVX_const(PL_formtarget));
 884                         }
 885
 886                         /* Easy. They agree.  */
 887                         assert (item_is_utf8 == targ_is_utf8);
 888                     }
 889                     SvGROW(PL_formtarget,
 890                            SvCUR(PL_formtarget) + to_copy + fudge + 1);
 891                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 892
 893                     Copy(source, t, to_copy, char);
 894                     t += to_copy;
 895                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 896                     if (item_is_utf8) {
 897                         if (SvGMAGICAL(sv)) {
 898                             /* Mustn't call sv_pos_b2u() as it does a second
 899                                mg_get(). Is this a bug? Do we need a _flags()
 900                                variant? */
 901                             itemsize = utf8_length(source, source + itemsize);
 902                         } else {
 903                             sv_pos_b2u(sv, &itemsize);
 904                         }
 905                         assert(!tmp);
 906                     } else if (tmp) {
 907                         Safefree(tmp);
 908                     }
 909                 }
 910                 break;
 911             }
 912
 913         case FF_0DECIMAL:
 914             arg = *fpc++;
 915 #if defined(USE_LONG_DOUBLE)
 916             fmt = (const char *)
 917                 ((arg & 256) ?
 918                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 919 #else
 920             fmt = (const char *)
 921                 ((arg & 256) ?
 922                  "%#0*.*f"              : "%0*.*f");
 923 #endif
 924             goto ff_dec;
 925         case FF_DECIMAL:
 926             arg = *fpc++;
 927 #if defined(USE_LONG_DOUBLE)
 928             fmt = (const char *)
 929                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 930 #else
 931             fmt = (const char *)
 932                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 933 #endif
 934         ff_dec:
 935             /* If the field is marked with ^ and the value is undefined,
 936                blank it out. */
 937             if ((arg & 512) && !SvOK(sv)) {
 938                 arg = fieldsize;
 939                 while (arg--)
 940                     *t++ = ' ';
 941                 break;
 942             }
 943             gotsome = TRUE;
 944             value = SvNV(sv);
 945             /* overflow evidence */
 946             if (num_overflow(value, fieldsize, arg)) {
 947                 arg = fieldsize;
 948                 while (arg--)
 949                     *t++ = '#';
 950                 break;
 951             }
 952             /* Formats aren't yet marked for locales, so assume "yes". */
 953             {
 954                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 955                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 956                 RESTORE_NUMERIC_STANDARD();
 957             }
 958             t += fieldsize;
 959             break;
 960
 961         case FF_NEWLINE:
 962             f++;
 963             while (t-- > linemark && *t == ' ') ;
 964             t++;
 965             *t++ = '\n';
 966             break;
 967
 968         case FF_BLANK:
 969             arg = *fpc++;
 970             if (gotsome) {
 971                 if (arg) {              /* repeat until fields exhausted? */
 972                     *t = '\0';
 973                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 974                     lines += FmLINES(PL_formtarget);
 975                     if (targ_is_utf8)
 976                         SvUTF8_on(PL_formtarget);
 977                     FmLINES(PL_formtarget) = lines;
 978                     SP = ORIGMARK;
 979                     RETURNOP(cLISTOP->op_first);
 980                 }
 981             }
 982             else {
 983                 t = linemark;
 984                 lines--;
 985             }
 986             break;
 987
 988         case FF_MORE:
 989             {
 990                 const char *s = chophere;
 991                 const char *send = item + len;
 992                 if (chopspace) {
 993                     while (isSPACE(*s) && (s < send))
 994                         s++;
 995                 }
 996                 if (s < send) {
 997                     char *s1;
 998                     arg = fieldsize - itemsize;
 999                     if (arg) {
1000                         fieldsize -= arg;
1001                         while (arg-- > 0)
1002                             *t++ = ' ';
1003                     }
1004                     s1 = t - 3;
1005                     if (strnEQ(s1,"   ",3)) {
1006                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1007                             s1--;
1008                     }
1009                     *s1++ = '.';
1010                     *s1++ = '.';
1011                     *s1++ = '.';
1012                 }
1013                 break;
1014             }
1015         case FF_END:
1016             *t = '\0';
1017             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1018             if (targ_is_utf8)
1019                 SvUTF8_on(PL_formtarget);
1020             FmLINES(PL_formtarget) += lines;
1021             SP = ORIGMARK;
1022             RETPUSHYES;
1023         }
1024     }
1025 }
1026
1027 PP(pp_grepstart)
1028 {
1029     dVAR; dSP;
1030     SV *src;
1031
1032     if (PL_stack_base + *PL_markstack_ptr == SP) {
1033         (void)POPMARK;
1034         if (GIMME_V == G_SCALAR)
1035             mXPUSHi(0);
1036         RETURNOP(PL_op->op_next->op_next);
1037     }
1038     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1039     pp_pushmark();                              /* push dst */
1040     pp_pushmark();                              /* push src */
1041     ENTER_with_name("grep");                                    /* enter outer scope */
1042
1043     SAVETMPS;
1044     if (PL_op->op_private & OPpGREP_LEX)
1045         SAVESPTR(PAD_SVl(PL_op->op_targ));
1046     else
1047         SAVE_DEFSV;
1048     ENTER_with_name("grep_item");                                       /* enter inner scope */
1049     SAVEVPTR(PL_curpm);
1050
1051     src = PL_stack_base[*PL_markstack_ptr];
1052     SvTEMP_off(src);
1053     if (PL_op->op_private & OPpGREP_LEX)
1054         PAD_SVl(PL_op->op_targ) = src;
1055     else
1056         DEFSV_set(src);
1057
1058     PUTBACK;
1059     if (PL_op->op_type == OP_MAPSTART)
1060         pp_pushmark();                  /* push top */
1061     return ((LOGOP*)PL_op->op_next)->op_other;
1062 }
1063
1064 PP(pp_mapwhile)
1065 {
1066     dVAR; dSP;
1067     const I32 gimme = GIMME_V;
1068     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1069     I32 count;
1070     I32 shift;
1071     SV** src;
1072     SV** dst;
1073
1074     /* first, move source pointer to the next item in the source list */
1075     ++PL_markstack_ptr[-1];
1076
1077     /* if there are new items, push them into the destination list */
1078     if (items && gimme != G_VOID) {
1079         /* might need to make room back there first */
1080         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1081             /* XXX this implementation is very pessimal because the stack
1082              * is repeatedly extended for every set of items.  Is possible
1083              * to do this without any stack extension or copying at all
1084              * by maintaining a separate list over which the map iterates
1085              * (like foreach does). --gsar */
1086
1087             /* everything in the stack after the destination list moves
1088              * towards the end the stack by the amount of room needed */
1089             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1090
1091             /* items to shift up (accounting for the moved source pointer) */
1092             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1093
1094             /* This optimization is by Ben Tilly and it does
1095              * things differently from what Sarathy (gsar)
1096              * is describing.  The downside of this optimization is
1097              * that leaves "holes" (uninitialized and hopefully unused areas)
1098              * to the Perl stack, but on the other hand this
1099              * shouldn't be a problem.  If Sarathy's idea gets
1100              * implemented, this optimization should become
1101              * irrelevant.  --jhi */
1102             if (shift < count)
1103                 shift = count; /* Avoid shifting too often --Ben Tilly */
1104
1105             EXTEND(SP,shift);
1106             src = SP;
1107             dst = (SP += shift);
1108             PL_markstack_ptr[-1] += shift;
1109             *PL_markstack_ptr += shift;
1110             while (count--)
1111                 *dst-- = *src--;
1112         }
1113         /* copy the new items down to the destination list */
1114         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1115         if (gimme == G_ARRAY) {
1116             while (items-- > 0)
1117                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1118         }
1119         else {
1120             /* scalar context: we don't care about which values map returns
1121              * (we use undef here). And so we certainly don't want to do mortal
1122              * copies of meaningless values. */
1123             while (items-- > 0) {
1124                 (void)POPs;
1125                 *dst-- = &PL_sv_undef;
1126             }
1127         }
1128     }
1129     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1130
1131     /* All done yet? */
1132     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1133
1134         (void)POPMARK;                          /* pop top */
1135         LEAVE_with_name("grep");                                        /* exit outer scope */
1136         (void)POPMARK;                          /* pop src */
1137         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1138         (void)POPMARK;                          /* pop dst */
1139         SP = PL_stack_base + POPMARK;           /* pop original mark */
1140         if (gimme == G_SCALAR) {
1141             if (PL_op->op_private & OPpGREP_LEX) {
1142                 SV* sv = sv_newmortal();
1143                 sv_setiv(sv, items);
1144                 PUSHs(sv);
1145             }
1146             else {
1147                 dTARGET;
1148                 XPUSHi(items);
1149             }
1150         }
1151         else if (gimme == G_ARRAY)
1152             SP += items;
1153         RETURN;
1154     }
1155     else {
1156         SV *src;
1157
1158         ENTER_with_name("grep_item");                                   /* enter inner scope */
1159         SAVEVPTR(PL_curpm);
1160
1161         /* set $_ to the new source item */
1162         src = PL_stack_base[PL_markstack_ptr[-1]];
1163         SvTEMP_off(src);
1164         if (PL_op->op_private & OPpGREP_LEX)
1165             PAD_SVl(PL_op->op_targ) = src;
1166         else
1167             DEFSV_set(src);
1168
1169         RETURNOP(cLOGOP->op_other);
1170     }
1171 }
1172
1173 /* Range stuff. */
1174
1175 PP(pp_range)
1176 {
1177     dVAR;
1178     if (GIMME == G_ARRAY)
1179         return NORMAL;
1180     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1181         return cLOGOP->op_other;
1182     else
1183         return NORMAL;
1184 }
1185
1186 PP(pp_flip)
1187 {
1188     dVAR;
1189     dSP;
1190
1191     if (GIMME == G_ARRAY) {
1192         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1193     }
1194     else {
1195         dTOPss;
1196         SV * const targ = PAD_SV(PL_op->op_targ);
1197         int flip = 0;
1198
1199         if (PL_op->op_private & OPpFLIP_LINENUM) {
1200             if (GvIO(PL_last_in_gv)) {
1201                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1202             }
1203             else {
1204                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1205                 if (gv && GvSV(gv))
1206                     flip = SvIV(sv) == SvIV(GvSV(gv));
1207             }
1208         } else {
1209             flip = SvTRUE(sv);
1210         }
1211         if (flip) {
1212             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1213             if (PL_op->op_flags & OPf_SPECIAL) {
1214                 sv_setiv(targ, 1);
1215                 SETs(targ);
1216                 RETURN;
1217             }
1218             else {
1219                 sv_setiv(targ, 0);
1220                 SP--;
1221                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1222             }
1223         }
1224         sv_setpvs(TARG, "");
1225         SETs(targ);
1226         RETURN;
1227     }
1228 }
1229
1230 /* This code tries to decide if "$left .. $right" should use the
1231    magical string increment, or if the range is numeric (we make
1232    an exception for .."0" [#18165]). AMS 20021031. */
1233
1234 #define RANGE_IS_NUMERIC(left,right) ( \
1235         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1236         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1237         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1238           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1239          && (!SvOK(right) || looks_like_number(right))))
1240
1241 PP(pp_flop)
1242 {
1243     dVAR; dSP;
1244
1245     if (GIMME == G_ARRAY) {
1246         dPOPPOPssrl;
1247
1248         SvGETMAGIC(left);
1249         SvGETMAGIC(right);
1250
1251         if (RANGE_IS_NUMERIC(left,right)) {
1252             register IV i, j;
1253             IV max;
1254             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1255                 (SvOK(right) && SvNV(right) > IV_MAX))
1256                 DIE(aTHX_ "Range iterator outside integer range");
1257             i = SvIV(left);
1258             max = SvIV(right);
1259             if (max >= i) {
1260                 j = max - i + 1;
1261                 EXTEND_MORTAL(j);
1262                 EXTEND(SP, j);
1263             }
1264             else
1265                 j = 0;
1266             while (j--) {
1267                 SV * const sv = sv_2mortal(newSViv(i++));
1268                 PUSHs(sv);
1269             }
1270         }
1271         else {
1272             SV * const final = sv_mortalcopy(right);
1273             STRLEN len;
1274             const char * const tmps = SvPV_const(final, len);
1275
1276             SV *sv = sv_mortalcopy(left);
1277             SvPV_force_nolen(sv);
1278             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1279                 XPUSHs(sv);
1280                 if (strEQ(SvPVX_const(sv),tmps))
1281                     break;
1282                 sv = sv_2mortal(newSVsv(sv));
1283                 sv_inc(sv);
1284             }
1285         }
1286     }
1287     else {
1288         dTOPss;
1289         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1290         int flop = 0;
1291         sv_inc(targ);
1292
1293         if (PL_op->op_private & OPpFLIP_LINENUM) {
1294             if (GvIO(PL_last_in_gv)) {
1295                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1296             }
1297             else {
1298                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1299                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1300             }
1301         }
1302         else {
1303             flop = SvTRUE(sv);
1304         }
1305
1306         if (flop) {
1307             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1308             sv_catpvs(targ, "E0");
1309         }
1310         SETs(targ);
1311     }
1312
1313     RETURN;
1314 }
1315
1316 /* Control. */
1317
1318 static const char * const context_name[] = {
1319     "pseudo-block",
1320     NULL, /* CXt_WHEN never actually needs "block" */
1321     NULL, /* CXt_BLOCK never actually needs "block" */
1322     NULL, /* CXt_GIVEN never actually needs "block" */
1323     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1324     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1325     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1326     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1327     "subroutine",
1328     "format",
1329     "eval",
1330     "substitution",
1331 };
1332
1333 STATIC I32
1334 S_dopoptolabel(pTHX_ const char *label)
1335 {
1336     dVAR;
1337     register I32 i;
1338
1339     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1340
1341     for (i = cxstack_ix; i >= 0; i--) {
1342         register const PERL_CONTEXT * const cx = &cxstack[i];
1343         switch (CxTYPE(cx)) {
1344         case CXt_SUBST:
1345         case CXt_SUB:
1346         case CXt_FORMAT:
1347         case CXt_EVAL:
1348         case CXt_NULL:
1349             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1350                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1351             if (CxTYPE(cx) == CXt_NULL)
1352                 return -1;
1353             break;
1354         case CXt_LOOP_LAZYIV:
1355         case CXt_LOOP_LAZYSV:
1356         case CXt_LOOP_FOR:
1357         case CXt_LOOP_PLAIN:
1358           {
1359             const char *cx_label = CxLABEL(cx);
1360             if (!cx_label || strNE(label, cx_label) ) {
1361                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1362                         (long)i, cx_label));
1363                 continue;
1364             }
1365             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1366             return i;
1367           }
1368         }
1369     }
1370     return i;
1371 }
1372
1373
1374
1375 I32
1376 Perl_dowantarray(pTHX)
1377 {
1378     dVAR;
1379     const I32 gimme = block_gimme();
1380     return (gimme == G_VOID) ? G_SCALAR : gimme;
1381 }
1382
1383 I32
1384 Perl_block_gimme(pTHX)
1385 {
1386     dVAR;
1387     const I32 cxix = dopoptosub(cxstack_ix);
1388     if (cxix < 0)
1389         return G_VOID;
1390
1391     switch (cxstack[cxix].blk_gimme) {
1392     case G_VOID:
1393         return G_VOID;
1394     case G_SCALAR:
1395         return G_SCALAR;
1396     case G_ARRAY:
1397         return G_ARRAY;
1398     default:
1399         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1400         /* NOTREACHED */
1401         return 0;
1402     }
1403 }
1404
1405 I32
1406 Perl_is_lvalue_sub(pTHX)
1407 {
1408     dVAR;
1409     const I32 cxix = dopoptosub(cxstack_ix);
1410     assert(cxix >= 0);  /* We should only be called from inside subs */
1411
1412     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1413         return CxLVAL(cxstack + cxix);
1414     else
1415         return 0;
1416 }
1417
1418 STATIC I32
1419 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1420 {
1421     dVAR;
1422     I32 i;
1423
1424     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1425
1426     for (i = startingblock; i >= 0; i--) {
1427         register const PERL_CONTEXT * const cx = &cxstk[i];
1428         switch (CxTYPE(cx)) {
1429         default:
1430             continue;
1431         case CXt_EVAL:
1432         case CXt_SUB:
1433         case CXt_FORMAT:
1434             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1435             return i;
1436         }
1437     }
1438     return i;
1439 }
1440
1441 STATIC I32
1442 S_dopoptoeval(pTHX_ I32 startingblock)
1443 {
1444     dVAR;
1445     I32 i;
1446     for (i = startingblock; i >= 0; i--) {
1447         register const PERL_CONTEXT *cx = &cxstack[i];
1448         switch (CxTYPE(cx)) {
1449         default:
1450             continue;
1451         case CXt_EVAL:
1452             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1453             return i;
1454         }
1455     }
1456     return i;
1457 }
1458
1459 STATIC I32
1460 S_dopoptoloop(pTHX_ I32 startingblock)
1461 {
1462     dVAR;
1463     I32 i;
1464     for (i = startingblock; i >= 0; i--) {
1465         register const PERL_CONTEXT * const cx = &cxstack[i];
1466         switch (CxTYPE(cx)) {
1467         case CXt_SUBST:
1468         case CXt_SUB:
1469         case CXt_FORMAT:
1470         case CXt_EVAL:
1471         case CXt_NULL:
1472             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1473                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1474             if ((CxTYPE(cx)) == CXt_NULL)
1475                 return -1;
1476             break;
1477         case CXt_LOOP_LAZYIV:
1478         case CXt_LOOP_LAZYSV:
1479         case CXt_LOOP_FOR:
1480         case CXt_LOOP_PLAIN:
1481             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1482             return i;
1483         }
1484     }
1485     return i;
1486 }
1487
1488 STATIC I32
1489 S_dopoptogiven(pTHX_ I32 startingblock)
1490 {
1491     dVAR;
1492     I32 i;
1493     for (i = startingblock; i >= 0; i--) {
1494         register const PERL_CONTEXT *cx = &cxstack[i];
1495         switch (CxTYPE(cx)) {
1496         default:
1497             continue;
1498         case CXt_GIVEN:
1499             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1500             return i;
1501         case CXt_LOOP_PLAIN:
1502             assert(!CxFOREACHDEF(cx));
1503             break;
1504         case CXt_LOOP_LAZYIV:
1505         case CXt_LOOP_LAZYSV:
1506         case CXt_LOOP_FOR:
1507             if (CxFOREACHDEF(cx)) {
1508                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1509                 return i;
1510             }
1511         }
1512     }
1513     return i;
1514 }
1515
1516 STATIC I32
1517 S_dopoptowhen(pTHX_ I32 startingblock)
1518 {
1519     dVAR;
1520     I32 i;
1521     for (i = startingblock; i >= 0; i--) {
1522         register const PERL_CONTEXT *cx = &cxstack[i];
1523         switch (CxTYPE(cx)) {
1524         default:
1525             continue;
1526         case CXt_WHEN:
1527             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1528             return i;
1529         }
1530     }
1531     return i;
1532 }
1533
1534 void
1535 Perl_dounwind(pTHX_ I32 cxix)
1536 {
1537     dVAR;
1538     I32 optype;
1539
1540     while (cxstack_ix > cxix) {
1541         SV *sv;
1542         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1543         DEBUG_CX("UNWIND");                                             \
1544         /* Note: we don't need to restore the base context info till the end. */
1545         switch (CxTYPE(cx)) {
1546         case CXt_SUBST:
1547             POPSUBST(cx);
1548             continue;  /* not break */
1549         case CXt_SUB:
1550             POPSUB(cx,sv);
1551             LEAVESUB(sv);
1552             break;
1553         case CXt_EVAL:
1554             POPEVAL(cx);
1555             break;
1556         case CXt_LOOP_LAZYIV:
1557         case CXt_LOOP_LAZYSV:
1558         case CXt_LOOP_FOR:
1559         case CXt_LOOP_PLAIN:
1560             POPLOOP(cx);
1561             break;
1562         case CXt_NULL:
1563             break;
1564         case CXt_FORMAT:
1565             POPFORMAT(cx);
1566             break;
1567         }
1568         cxstack_ix--;
1569     }
1570     PERL_UNUSED_VAR(optype);
1571 }
1572
1573 void
1574 Perl_qerror(pTHX_ SV *err)
1575 {
1576     dVAR;
1577
1578     PERL_ARGS_ASSERT_QERROR;
1579
1580     if (PL_in_eval)
1581         sv_catsv(ERRSV, err);
1582     else if (PL_errors)
1583         sv_catsv(PL_errors, err);
1584     else
1585         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1586     if (PL_parser)
1587         ++PL_parser->error_count;
1588 }
1589
1590 void
1591 Perl_die_unwind(pTHX_ SV *msv)
1592 {
1593     dVAR;
1594     SV *exceptsv = sv_mortalcopy(msv);
1595     U8 in_eval = PL_in_eval;
1596     PERL_ARGS_ASSERT_DIE_UNWIND;
1597
1598     if (in_eval) {
1599         I32 cxix;
1600         I32 gimme;
1601
1602         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1603                && PL_curstackinfo->si_prev)
1604         {
1605             dounwind(-1);
1606             POPSTACK;
1607         }
1608
1609         if (cxix >= 0) {
1610             I32 optype;
1611             SV *namesv;
1612             register PERL_CONTEXT *cx;
1613             SV **newsp;
1614
1615             if (cxix < cxstack_ix)
1616                 dounwind(cxix);
1617
1618             POPBLOCK(cx,PL_curpm);
1619             if (CxTYPE(cx) != CXt_EVAL) {
1620                 STRLEN msglen;
1621                 const char* message = SvPVx_const(exceptsv, msglen);
1622                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1623                 PerlIO_write(Perl_error_log, message, msglen);
1624                 my_exit(1);
1625             }
1626             POPEVAL(cx);
1627             namesv = cx->blk_eval.old_namesv;
1628
1629             if (gimme == G_SCALAR)
1630                 *++newsp = &PL_sv_undef;
1631             PL_stack_sp = newsp;
1632
1633             LEAVE;
1634
1635             /* LEAVE could clobber PL_curcop (see save_re_context())
1636              * XXX it might be better to find a way to avoid messing with
1637              * PL_curcop in save_re_context() instead, but this is a more
1638              * minimal fix --GSAR */
1639             PL_curcop = cx->blk_oldcop;
1640
1641             if (optype == OP_REQUIRE) {
1642                 const char* const msg = SvPVx_nolen_const(exceptsv);
1643                 (void)hv_store(GvHVn(PL_incgv),
1644                                SvPVX_const(namesv), SvCUR(namesv),
1645                                &PL_sv_undef, 0);
1646                 /* note that unlike pp_entereval, pp_require isn't
1647                  * supposed to trap errors. So now that we've popped the
1648                  * EVAL that pp_require pushed, and processed the error
1649                  * message, rethrow the error */
1650                 Perl_croak(aTHX_ "%sCompilation failed in require",
1651                            *msg ? msg : "Unknown error\n");
1652             }
1653             if (in_eval & EVAL_KEEPERR) {
1654                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1655                                SvPV_nolen_const(exceptsv));
1656             }
1657             else {
1658                 sv_setsv(ERRSV, exceptsv);
1659             }
1660             assert(CxTYPE(cx) == CXt_EVAL);
1661             PL_restartjmpenv = cx->blk_eval.cur_top_env;
1662             PL_restartop = cx->blk_eval.retop;
1663             JMPENV_JUMP(3);
1664             /* NOTREACHED */
1665         }
1666     }
1667
1668     write_to_stderr(exceptsv);
1669     my_failure_exit();
1670     /* NOTREACHED */
1671 }
1672
1673 PP(pp_xor)
1674 {
1675     dVAR; dSP; dPOPTOPssrl;
1676     if (SvTRUE(left) != SvTRUE(right))
1677         RETSETYES;
1678     else
1679         RETSETNO;
1680 }
1681
1682 /*
1683 =for apidoc caller_cx
1684
1685 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1686 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1687 information returned to Perl by C<caller>. Note that XSUBs don't get a
1688 stack frame, so C<caller_cx(0, NULL)> will return information for the
1689 immediately-surrounding Perl code.
1690
1691 This function skips over the automatic calls to C<&DB::sub> made on the
1692 behalf of the debugger. If the stack frame requested was a sub called by
1693 C<DB::sub>, the return value will be the frame for the call to
1694 C<DB::sub>, since that has the correct line number/etc. for the call
1695 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1696 frame for the sub call itself.
1697
1698 =cut
1699 */
1700
1701 const PERL_CONTEXT *
1702 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1703 {
1704     register I32 cxix = dopoptosub(cxstack_ix);
1705     register const PERL_CONTEXT *cx;
1706     register const PERL_CONTEXT *ccstack = cxstack;
1707     const PERL_SI *top_si = PL_curstackinfo;
1708
1709     for (;;) {
1710         /* we may be in a higher stacklevel, so dig down deeper */
1711         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1712             top_si = top_si->si_prev;
1713             ccstack = top_si->si_cxstack;
1714             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1715         }
1716         if (cxix < 0)
1717             return NULL;
1718         /* caller() should not report the automatic calls to &DB::sub */
1719         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1720                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1721             count++;
1722         if (!count--)
1723             break;
1724         cxix = dopoptosub_at(ccstack, cxix - 1);
1725     }
1726
1727     cx = &ccstack[cxix];
1728     if (dbcxp) *dbcxp = cx;
1729
1730     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1731         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1732         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1733            field below is defined for any cx. */
1734         /* caller() should not report the automatic calls to &DB::sub */
1735         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1736             cx = &ccstack[dbcxix];
1737     }
1738
1739     return cx;
1740 }
1741
1742 PP(pp_caller)
1743 {
1744     dVAR;
1745     dSP;
1746     register const PERL_CONTEXT *cx;
1747     const PERL_CONTEXT *dbcx;
1748     I32 gimme;
1749     const char *stashname;
1750     I32 count = 0;
1751
1752     if (MAXARG)
1753         count = POPi;
1754
1755     cx = caller_cx(count, &dbcx);
1756     if (!cx) {
1757         if (GIMME != G_ARRAY) {
1758             EXTEND(SP, 1);
1759             RETPUSHUNDEF;
1760         }
1761         RETURN;
1762     }
1763
1764     stashname = CopSTASHPV(cx->blk_oldcop);
1765     if (GIMME != G_ARRAY) {
1766         EXTEND(SP, 1);
1767         if (!stashname)
1768             PUSHs(&PL_sv_undef);
1769         else {
1770             dTARGET;
1771             sv_setpv(TARG, stashname);
1772             PUSHs(TARG);
1773         }
1774         RETURN;
1775     }
1776
1777     EXTEND(SP, 11);
1778
1779     if (!stashname)
1780         PUSHs(&PL_sv_undef);
1781     else
1782         mPUSHs(newSVpv(stashname, 0));
1783     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1784     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1785     if (!MAXARG)
1786         RETURN;
1787     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1788         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1789         /* So is ccstack[dbcxix]. */
1790         if (isGV(cvgv)) {
1791             SV * const sv = newSV(0);
1792             gv_efullname3(sv, cvgv, NULL);
1793             mPUSHs(sv);
1794             PUSHs(boolSV(CxHASARGS(cx)));
1795         }
1796         else {
1797             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1798             PUSHs(boolSV(CxHASARGS(cx)));
1799         }
1800     }
1801     else {
1802         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1803         mPUSHi(0);
1804     }
1805     gimme = (I32)cx->blk_gimme;
1806     if (gimme == G_VOID)
1807         PUSHs(&PL_sv_undef);
1808     else
1809         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1810     if (CxTYPE(cx) == CXt_EVAL) {
1811         /* eval STRING */
1812         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1813             PUSHs(cx->blk_eval.cur_text);
1814             PUSHs(&PL_sv_no);
1815         }
1816         /* require */
1817         else if (cx->blk_eval.old_namesv) {
1818             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1819             PUSHs(&PL_sv_yes);
1820         }
1821         /* eval BLOCK (try blocks have old_namesv == 0) */
1822         else {
1823             PUSHs(&PL_sv_undef);
1824             PUSHs(&PL_sv_undef);
1825         }
1826     }
1827     else {
1828         PUSHs(&PL_sv_undef);
1829         PUSHs(&PL_sv_undef);
1830     }
1831     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1832         && CopSTASH_eq(PL_curcop, PL_debstash))
1833     {
1834         AV * const ary = cx->blk_sub.argarray;
1835         const int off = AvARRAY(ary) - AvALLOC(ary);
1836
1837         if (!PL_dbargs)
1838             Perl_init_dbargs(aTHX);
1839
1840         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1841             av_extend(PL_dbargs, AvFILLp(ary) + off);
1842         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1843         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1844     }
1845     /* XXX only hints propagated via op_private are currently
1846      * visible (others are not easily accessible, since they
1847      * use the global PL_hints) */
1848     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1849     {
1850         SV * mask ;
1851         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1852
1853         if  (old_warnings == pWARN_NONE ||
1854                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1855             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1856         else if (old_warnings == pWARN_ALL ||
1857                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1858             /* Get the bit mask for $warnings::Bits{all}, because
1859              * it could have been extended by warnings::register */
1860             SV **bits_all;
1861             HV * const bits = get_hv("warnings::Bits", 0);
1862             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1863                 mask = newSVsv(*bits_all);
1864             }
1865             else {
1866                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1867             }
1868         }
1869         else
1870             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1871         mPUSHs(mask);
1872     }
1873
1874     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1875           sv_2mortal(newRV_noinc(
1876                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1877                                               cx->blk_oldcop->cop_hints_hash))))
1878           : &PL_sv_undef);
1879     RETURN;
1880 }
1881
1882 PP(pp_reset)
1883 {
1884     dVAR;
1885     dSP;
1886     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1887     sv_reset(tmps, CopSTASH(PL_curcop));
1888     PUSHs(&PL_sv_yes);
1889     RETURN;
1890 }
1891
1892 /* like pp_nextstate, but used instead when the debugger is active */
1893
1894 PP(pp_dbstate)
1895 {
1896     dVAR;
1897     PL_curcop = (COP*)PL_op;
1898     TAINT_NOT;          /* Each statement is presumed innocent */
1899     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1900     FREETMPS;
1901
1902     PERL_ASYNC_CHECK();
1903
1904     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1905             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1906     {
1907         dSP;
1908         register PERL_CONTEXT *cx;
1909         const I32 gimme = G_ARRAY;
1910         U8 hasargs;
1911         GV * const gv = PL_DBgv;
1912         register CV * const cv = GvCV(gv);
1913
1914         if (!cv)
1915             DIE(aTHX_ "No DB::DB routine defined");
1916
1917         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1918             /* don't do recursive DB::DB call */
1919             return NORMAL;
1920
1921         ENTER;
1922         SAVETMPS;
1923
1924         SAVEI32(PL_debug);
1925         SAVESTACK_POS();
1926         PL_debug = 0;
1927         hasargs = 0;
1928         SPAGAIN;
1929
1930         if (CvISXSUB(cv)) {
1931             CvDEPTH(cv)++;
1932             PUSHMARK(SP);
1933             (void)(*CvXSUB(cv))(aTHX_ cv);
1934             CvDEPTH(cv)--;
1935             FREETMPS;
1936             LEAVE;
1937             return NORMAL;
1938         }
1939         else {
1940             PUSHBLOCK(cx, CXt_SUB, SP);
1941             PUSHSUB_DB(cx);
1942             cx->blk_sub.retop = PL_op->op_next;
1943             CvDEPTH(cv)++;
1944             SAVECOMPPAD();
1945             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1946             RETURNOP(CvSTART(cv));
1947         }
1948     }
1949     else
1950         return NORMAL;
1951 }
1952
1953 PP(pp_enteriter)
1954 {
1955     dVAR; dSP; dMARK;
1956     register PERL_CONTEXT *cx;
1957     const I32 gimme = GIMME_V;
1958     void *itervar; /* location of the iteration variable */
1959     U8 cxtype = CXt_LOOP_FOR;
1960
1961     ENTER_with_name("loop1");
1962     SAVETMPS;
1963
1964     if (PL_op->op_targ) {                        /* "my" variable */
1965         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
1966             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1967             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1968                     SVs_PADSTALE, SVs_PADSTALE);
1969         }
1970         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1971 #ifdef USE_ITHREADS
1972         itervar = PL_comppad;
1973 #else
1974         itervar = &PAD_SVl(PL_op->op_targ);
1975 #endif
1976     }
1977     else {                                      /* symbol table variable */
1978         GV * const gv = MUTABLE_GV(POPs);
1979         SV** svp = &GvSV(gv);
1980         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
1981         *svp = newSV(0);
1982         itervar = (void *)gv;
1983     }
1984
1985     if (PL_op->op_private & OPpITER_DEF)
1986         cxtype |= CXp_FOR_DEF;
1987
1988     ENTER_with_name("loop2");
1989
1990     PUSHBLOCK(cx, cxtype, SP);
1991     PUSHLOOP_FOR(cx, itervar, MARK);
1992     if (PL_op->op_flags & OPf_STACKED) {
1993         SV *maybe_ary = POPs;
1994         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1995             dPOPss;
1996             SV * const right = maybe_ary;
1997             SvGETMAGIC(sv);
1998             SvGETMAGIC(right);
1999             if (RANGE_IS_NUMERIC(sv,right)) {
2000                 cx->cx_type &= ~CXTYPEMASK;
2001                 cx->cx_type |= CXt_LOOP_LAZYIV;
2002                 /* Make sure that no-one re-orders cop.h and breaks our
2003                    assumptions */
2004                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2005 #ifdef NV_PRESERVES_UV
2006                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2007                                   (SvNV(sv) > (NV)IV_MAX)))
2008                         ||
2009                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2010                                      (SvNV(right) < (NV)IV_MIN))))
2011 #else
2012                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2013                                   ||
2014                                   ((SvNV(sv) > 0) &&
2015                                         ((SvUV(sv) > (UV)IV_MAX) ||
2016                                          (SvNV(sv) > (NV)UV_MAX)))))
2017                         ||
2018                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2019                                      ||
2020                                      ((SvNV(right) > 0) &&
2021                                         ((SvUV(right) > (UV)IV_MAX) ||
2022                                          (SvNV(right) > (NV)UV_MAX))))))
2023 #endif
2024                     DIE(aTHX_ "Range iterator outside integer range");
2025                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2026                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2027 #ifdef DEBUGGING
2028                 /* for correct -Dstv display */
2029                 cx->blk_oldsp = sp - PL_stack_base;
2030 #endif
2031             }
2032             else {
2033                 cx->cx_type &= ~CXTYPEMASK;
2034                 cx->cx_type |= CXt_LOOP_LAZYSV;
2035                 /* Make sure that no-one re-orders cop.h and breaks our
2036                    assumptions */
2037                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2038                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2039                 cx->blk_loop.state_u.lazysv.end = right;
2040                 SvREFCNT_inc(right);
2041                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2042                 /* This will do the upgrade to SVt_PV, and warn if the value
2043                    is uninitialised.  */
2044                 (void) SvPV_nolen_const(right);
2045                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2046                    to replace !SvOK() with a pointer to "".  */
2047                 if (!SvOK(right)) {
2048                     SvREFCNT_dec(right);
2049                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2050                 }
2051             }
2052         }
2053         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2054             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2055             SvREFCNT_inc(maybe_ary);
2056             cx->blk_loop.state_u.ary.ix =
2057                 (PL_op->op_private & OPpITER_REVERSED) ?
2058                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2059                 -1;
2060         }
2061     }
2062     else { /* iterating over items on the stack */
2063         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2064         if (PL_op->op_private & OPpITER_REVERSED) {
2065             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2066         }
2067         else {
2068             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2069         }
2070     }
2071
2072     RETURN;
2073 }
2074
2075 PP(pp_enterloop)
2076 {
2077     dVAR; dSP;
2078     register PERL_CONTEXT *cx;
2079     const I32 gimme = GIMME_V;
2080
2081     ENTER_with_name("loop1");
2082     SAVETMPS;
2083     ENTER_with_name("loop2");
2084
2085     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2086     PUSHLOOP_PLAIN(cx, SP);
2087
2088     RETURN;
2089 }
2090
2091 PP(pp_leaveloop)
2092 {
2093     dVAR; dSP;
2094     register PERL_CONTEXT *cx;
2095     I32 gimme;
2096     SV **newsp;
2097     PMOP *newpm;
2098     SV **mark;
2099
2100     POPBLOCK(cx,newpm);
2101     assert(CxTYPE_is_LOOP(cx));
2102     mark = newsp;
2103     newsp = PL_stack_base + cx->blk_loop.resetsp;
2104
2105     TAINT_NOT;
2106     if (gimme == G_VOID)
2107         NOOP;
2108     else if (gimme == G_SCALAR) {
2109         if (mark < SP)
2110             *++newsp = sv_mortalcopy(*SP);
2111         else
2112             *++newsp = &PL_sv_undef;
2113     }
2114     else {
2115         while (mark < SP) {
2116             *++newsp = sv_mortalcopy(*++mark);
2117             TAINT_NOT;          /* Each item is independent */
2118         }
2119     }
2120     SP = newsp;
2121     PUTBACK;
2122
2123     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2124     PL_curpm = newpm;   /* ... and pop $1 et al */
2125
2126     LEAVE_with_name("loop2");
2127     LEAVE_with_name("loop1");
2128
2129     return NORMAL;
2130 }
2131
2132 PP(pp_return)
2133 {
2134     dVAR; dSP; dMARK;
2135     register PERL_CONTEXT *cx;
2136     bool popsub2 = FALSE;
2137     bool clear_errsv = FALSE;
2138     I32 gimme;
2139     SV **newsp;
2140     PMOP *newpm;
2141     I32 optype = 0;
2142     SV *namesv;
2143     SV *sv;
2144     OP *retop = NULL;
2145
2146     const I32 cxix = dopoptosub(cxstack_ix);
2147
2148     if (cxix < 0) {
2149         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2150                                      * sort block, which is a CXt_NULL
2151                                      * not a CXt_SUB */
2152             dounwind(0);
2153             PL_stack_base[1] = *PL_stack_sp;
2154             PL_stack_sp = PL_stack_base + 1;
2155             return 0;
2156         }
2157         else
2158             DIE(aTHX_ "Can't return outside a subroutine");
2159     }
2160     if (cxix < cxstack_ix)
2161         dounwind(cxix);
2162
2163     if (CxMULTICALL(&cxstack[cxix])) {
2164         gimme = cxstack[cxix].blk_gimme;
2165         if (gimme == G_VOID)
2166             PL_stack_sp = PL_stack_base;
2167         else if (gimme == G_SCALAR) {
2168             PL_stack_base[1] = *PL_stack_sp;
2169             PL_stack_sp = PL_stack_base + 1;
2170         }
2171         return 0;
2172     }
2173
2174     POPBLOCK(cx,newpm);
2175     switch (CxTYPE(cx)) {
2176     case CXt_SUB:
2177         popsub2 = TRUE;
2178         retop = cx->blk_sub.retop;
2179         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2180         break;
2181     case CXt_EVAL:
2182         if (!(PL_in_eval & EVAL_KEEPERR))
2183             clear_errsv = TRUE;
2184         POPEVAL(cx);
2185         namesv = cx->blk_eval.old_namesv;
2186         retop = cx->blk_eval.retop;
2187         if (CxTRYBLOCK(cx))
2188             break;
2189         lex_end();
2190         if (optype == OP_REQUIRE &&
2191             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2192         {
2193             /* Unassume the success we assumed earlier. */
2194             (void)hv_delete(GvHVn(PL_incgv),
2195                             SvPVX_const(namesv), SvCUR(namesv),
2196                             G_DISCARD);
2197             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2198         }
2199         break;
2200     case CXt_FORMAT:
2201         POPFORMAT(cx);
2202         retop = cx->blk_sub.retop;
2203         break;
2204     default:
2205         DIE(aTHX_ "panic: return");
2206     }
2207
2208     TAINT_NOT;
2209     if (gimme == G_SCALAR) {
2210         if (MARK < SP) {
2211             if (popsub2) {
2212                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2213                     if (SvTEMP(TOPs)) {
2214                         *++newsp = SvREFCNT_inc(*SP);
2215                         FREETMPS;
2216                         sv_2mortal(*newsp);
2217                     }
2218                     else {
2219                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2220                         FREETMPS;
2221                         *++newsp = sv_mortalcopy(sv);
2222                         SvREFCNT_dec(sv);
2223                     }
2224                 }
2225                 else
2226                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2227             }
2228             else
2229                 *++newsp = sv_mortalcopy(*SP);
2230         }
2231         else
2232             *++newsp = &PL_sv_undef;
2233     }
2234     else if (gimme == G_ARRAY) {
2235         while (++MARK <= SP) {
2236             *++newsp = (popsub2 && SvTEMP(*MARK))
2237                         ? *MARK : sv_mortalcopy(*MARK);
2238             TAINT_NOT;          /* Each item is independent */
2239         }
2240     }
2241     PL_stack_sp = newsp;
2242
2243     LEAVE;
2244     /* Stack values are safe: */
2245     if (popsub2) {
2246         cxstack_ix--;
2247         POPSUB(cx,sv);  /* release CV and @_ ... */
2248     }
2249     else
2250         sv = NULL;
2251     PL_curpm = newpm;   /* ... and pop $1 et al */
2252
2253     LEAVESUB(sv);
2254     if (clear_errsv) {
2255         CLEAR_ERRSV();
2256     }
2257     return retop;
2258 }
2259
2260 PP(pp_last)
2261 {
2262     dVAR; dSP;
2263     I32 cxix;
2264     register PERL_CONTEXT *cx;
2265     I32 pop2 = 0;
2266     I32 gimme;
2267     I32 optype;
2268     OP *nextop = NULL;
2269     SV **newsp;
2270     PMOP *newpm;
2271     SV **mark;
2272     SV *sv = NULL;
2273
2274
2275     if (PL_op->op_flags & OPf_SPECIAL) {
2276         cxix = dopoptoloop(cxstack_ix);
2277         if (cxix < 0)
2278             DIE(aTHX_ "Can't \"last\" outside a loop block");
2279     }
2280     else {
2281         cxix = dopoptolabel(cPVOP->op_pv);
2282         if (cxix < 0)
2283             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2284     }
2285     if (cxix < cxstack_ix)
2286         dounwind(cxix);
2287
2288     POPBLOCK(cx,newpm);
2289     cxstack_ix++; /* temporarily protect top context */
2290     mark = newsp;
2291     switch (CxTYPE(cx)) {
2292     case CXt_LOOP_LAZYIV:
2293     case CXt_LOOP_LAZYSV:
2294     case CXt_LOOP_FOR:
2295     case CXt_LOOP_PLAIN:
2296         pop2 = CxTYPE(cx);
2297         newsp = PL_stack_base + cx->blk_loop.resetsp;
2298         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2299         break;
2300     case CXt_SUB:
2301         pop2 = CXt_SUB;
2302         nextop = cx->blk_sub.retop;
2303         break;
2304     case CXt_EVAL:
2305         POPEVAL(cx);
2306         nextop = cx->blk_eval.retop;
2307         break;
2308     case CXt_FORMAT:
2309         POPFORMAT(cx);
2310         nextop = cx->blk_sub.retop;
2311         break;
2312     default:
2313         DIE(aTHX_ "panic: last");
2314     }
2315
2316     TAINT_NOT;
2317     if (gimme == G_SCALAR) {
2318         if (MARK < SP)
2319             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2320                         ? *SP : sv_mortalcopy(*SP);
2321         else
2322             *++newsp = &PL_sv_undef;
2323     }
2324     else if (gimme == G_ARRAY) {
2325         while (++MARK <= SP) {
2326             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2327                         ? *MARK : sv_mortalcopy(*MARK);
2328             TAINT_NOT;          /* Each item is independent */
2329         }
2330     }
2331     SP = newsp;
2332     PUTBACK;
2333
2334     LEAVE;
2335     cxstack_ix--;
2336     /* Stack values are safe: */
2337     switch (pop2) {
2338     case CXt_LOOP_LAZYIV:
2339     case CXt_LOOP_PLAIN:
2340     case CXt_LOOP_LAZYSV:
2341     case CXt_LOOP_FOR:
2342         POPLOOP(cx);    /* release loop vars ... */
2343         LEAVE;
2344         break;
2345     case CXt_SUB:
2346         POPSUB(cx,sv);  /* release CV and @_ ... */
2347         break;
2348     }
2349     PL_curpm = newpm;   /* ... and pop $1 et al */
2350
2351     LEAVESUB(sv);
2352     PERL_UNUSED_VAR(optype);
2353     PERL_UNUSED_VAR(gimme);
2354     return nextop;
2355 }
2356
2357 PP(pp_next)
2358 {
2359     dVAR;
2360     I32 cxix;
2361     register PERL_CONTEXT *cx;
2362     I32 inner;
2363
2364     if (PL_op->op_flags & OPf_SPECIAL) {
2365         cxix = dopoptoloop(cxstack_ix);
2366         if (cxix < 0)
2367             DIE(aTHX_ "Can't \"next\" outside a loop block");
2368     }
2369     else {
2370         cxix = dopoptolabel(cPVOP->op_pv);
2371         if (cxix < 0)
2372             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2373     }
2374     if (cxix < cxstack_ix)
2375         dounwind(cxix);
2376
2377     /* clear off anything above the scope we're re-entering, but
2378      * save the rest until after a possible continue block */
2379     inner = PL_scopestack_ix;
2380     TOPBLOCK(cx);
2381     if (PL_scopestack_ix < inner)
2382         leave_scope(PL_scopestack[PL_scopestack_ix]);
2383     PL_curcop = cx->blk_oldcop;
2384     return (cx)->blk_loop.my_op->op_nextop;
2385 }
2386
2387 PP(pp_redo)
2388 {
2389     dVAR;
2390     I32 cxix;
2391     register PERL_CONTEXT *cx;
2392     I32 oldsave;
2393     OP* redo_op;
2394
2395     if (PL_op->op_flags & OPf_SPECIAL) {
2396         cxix = dopoptoloop(cxstack_ix);
2397         if (cxix < 0)
2398             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2399     }
2400     else {
2401         cxix = dopoptolabel(cPVOP->op_pv);
2402         if (cxix < 0)
2403             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2404     }
2405     if (cxix < cxstack_ix)
2406         dounwind(cxix);
2407
2408     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2409     if (redo_op->op_type == OP_ENTER) {
2410         /* pop one less context to avoid $x being freed in while (my $x..) */
2411         cxstack_ix++;
2412         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2413         redo_op = redo_op->op_next;
2414     }
2415
2416     TOPBLOCK(cx);
2417     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2418     LEAVE_SCOPE(oldsave);
2419     FREETMPS;
2420     PL_curcop = cx->blk_oldcop;
2421     return redo_op;
2422 }
2423
2424 STATIC OP *
2425 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2426 {
2427     dVAR;
2428     OP **ops = opstack;
2429     static const char too_deep[] = "Target of goto is too deeply nested";
2430
2431     PERL_ARGS_ASSERT_DOFINDLABEL;
2432
2433     if (ops >= oplimit)
2434         Perl_croak(aTHX_ too_deep);
2435     if (o->op_type == OP_LEAVE ||
2436         o->op_type == OP_SCOPE ||
2437         o->op_type == OP_LEAVELOOP ||
2438         o->op_type == OP_LEAVESUB ||
2439         o->op_type == OP_LEAVETRY)
2440     {
2441         *ops++ = cUNOPo->op_first;
2442         if (ops >= oplimit)
2443             Perl_croak(aTHX_ too_deep);
2444     }
2445     *ops = 0;
2446     if (o->op_flags & OPf_KIDS) {
2447         OP *kid;
2448         /* First try all the kids at this level, since that's likeliest. */
2449         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2450             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2451                 const char *kid_label = CopLABEL(kCOP);
2452                 if (kid_label && strEQ(kid_label, label))
2453                     return kid;
2454             }
2455         }
2456         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2457             if (kid == PL_lastgotoprobe)
2458                 continue;
2459             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2460                 if (ops == opstack)
2461                     *ops++ = kid;
2462                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2463                          ops[-1]->op_type == OP_DBSTATE)
2464                     ops[-1] = kid;
2465                 else
2466                     *ops++ = kid;
2467             }
2468             if ((o = dofindlabel(kid, label, ops, oplimit)))
2469                 return o;
2470         }
2471     }
2472     *ops = 0;
2473     return 0;
2474 }
2475
2476 PP(pp_goto)
2477 {
2478     dVAR; dSP;
2479     OP *retop = NULL;
2480     I32 ix;
2481     register PERL_CONTEXT *cx;
2482 #define GOTO_DEPTH 64
2483     OP *enterops[GOTO_DEPTH];
2484     const char *label = NULL;
2485     const bool do_dump = (PL_op->op_type == OP_DUMP);
2486     static const char must_have_label[] = "goto must have label";
2487
2488     if (PL_op->op_flags & OPf_STACKED) {
2489         SV * const sv = POPs;
2490
2491         /* This egregious kludge implements goto &subroutine */
2492         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2493             I32 cxix;
2494             register PERL_CONTEXT *cx;
2495             CV *cv = MUTABLE_CV(SvRV(sv));
2496             SV** mark;
2497             I32 items = 0;
2498             I32 oldsave;
2499             bool reified = 0;
2500
2501         retry:
2502             if (!CvROOT(cv) && !CvXSUB(cv)) {
2503                 const GV * const gv = CvGV(cv);
2504                 if (gv) {
2505                     GV *autogv;
2506                     SV *tmpstr;
2507                     /* autoloaded stub? */
2508                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2509                         goto retry;
2510                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2511                                           GvNAMELEN(gv), FALSE);
2512                     if (autogv && (cv = GvCV(autogv)))
2513                         goto retry;
2514                     tmpstr = sv_newmortal();
2515                     gv_efullname3(tmpstr, gv, NULL);
2516                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2517                 }
2518                 DIE(aTHX_ "Goto undefined subroutine");
2519             }
2520
2521             /* First do some returnish stuff. */
2522             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2523             FREETMPS;
2524             cxix = dopoptosub(cxstack_ix);
2525             if (cxix < 0)
2526                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2527             if (cxix < cxstack_ix)
2528                 dounwind(cxix);
2529             TOPBLOCK(cx);
2530             SPAGAIN;
2531             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2532             if (CxTYPE(cx) == CXt_EVAL) {
2533                 if (CxREALEVAL(cx))
2534                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2535                 else
2536                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2537             }
2538             else if (CxMULTICALL(cx))
2539                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2540             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2541                 /* put @_ back onto stack */
2542                 AV* av = cx->blk_sub.argarray;
2543
2544                 items = AvFILLp(av) + 1;
2545                 EXTEND(SP, items+1); /* @_ could have been extended. */
2546                 Copy(AvARRAY(av), SP + 1, items, SV*);
2547                 SvREFCNT_dec(GvAV(PL_defgv));
2548                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2549                 CLEAR_ARGARRAY(av);
2550                 /* abandon @_ if it got reified */
2551                 if (AvREAL(av)) {
2552                     reified = 1;
2553                     SvREFCNT_dec(av);
2554                     av = newAV();
2555                     av_extend(av, items-1);
2556                     AvREIFY_only(av);
2557                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2558                 }
2559             }
2560             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2561                 AV* const av = GvAV(PL_defgv);
2562                 items = AvFILLp(av) + 1;
2563                 EXTEND(SP, items+1); /* @_ could have been extended. */
2564                 Copy(AvARRAY(av), SP + 1, items, SV*);
2565             }
2566             mark = SP;
2567             SP += items;
2568             if (CxTYPE(cx) == CXt_SUB &&
2569                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2570                 SvREFCNT_dec(cx->blk_sub.cv);
2571             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2572             LEAVE_SCOPE(oldsave);
2573
2574             /* Now do some callish stuff. */
2575             SAVETMPS;
2576             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2577             if (CvISXSUB(cv)) {
2578                 OP* const retop = cx->blk_sub.retop;
2579                 SV **newsp;
2580                 I32 gimme;
2581                 if (reified) {
2582                     I32 index;
2583                     for (index=0; index<items; index++)
2584                         sv_2mortal(SP[-index]);
2585                 }
2586
2587                 /* XS subs don't have a CxSUB, so pop it */
2588                 POPBLOCK(cx, PL_curpm);
2589                 /* Push a mark for the start of arglist */
2590                 PUSHMARK(mark);
2591                 PUTBACK;
2592                 (void)(*CvXSUB(cv))(aTHX_ cv);
2593                 LEAVE;
2594                 return retop;
2595             }
2596             else {
2597                 AV* const padlist = CvPADLIST(cv);
2598                 if (CxTYPE(cx) == CXt_EVAL) {
2599                     PL_in_eval = CxOLD_IN_EVAL(cx);
2600                     PL_eval_root = cx->blk_eval.old_eval_root;
2601                     cx->cx_type = CXt_SUB;
2602                 }
2603                 cx->blk_sub.cv = cv;
2604                 cx->blk_sub.olddepth = CvDEPTH(cv);
2605
2606                 CvDEPTH(cv)++;
2607                 if (CvDEPTH(cv) < 2)
2608                     SvREFCNT_inc_simple_void_NN(cv);
2609                 else {
2610                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2611                         sub_crush_depth(cv);
2612                     pad_push(padlist, CvDEPTH(cv));
2613                 }
2614                 SAVECOMPPAD();
2615                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2616                 if (CxHASARGS(cx))
2617                 {
2618                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2619
2620                     cx->blk_sub.savearray = GvAV(PL_defgv);
2621                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2622                     CX_CURPAD_SAVE(cx->blk_sub);
2623                     cx->blk_sub.argarray = av;
2624
2625                     if (items >= AvMAX(av) + 1) {
2626                         SV **ary = AvALLOC(av);
2627                         if (AvARRAY(av) != ary) {
2628                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2629                             AvARRAY(av) = ary;
2630                         }
2631                         if (items >= AvMAX(av) + 1) {
2632                             AvMAX(av) = items - 1;
2633                             Renew(ary,items+1,SV*);
2634                             AvALLOC(av) = ary;
2635                             AvARRAY(av) = ary;
2636                         }
2637                     }
2638                     ++mark;
2639                     Copy(mark,AvARRAY(av),items,SV*);
2640                     AvFILLp(av) = items - 1;
2641                     assert(!AvREAL(av));
2642                     if (reified) {
2643                         /* transfer 'ownership' of refcnts to new @_ */
2644                         AvREAL_on(av);
2645                         AvREIFY_off(av);
2646                     }
2647                     while (items--) {
2648                         if (*mark)
2649                             SvTEMP_off(*mark);
2650                         mark++;
2651                     }
2652                 }
2653                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2654                     Perl_get_db_sub(aTHX_ NULL, cv);
2655                     if (PERLDB_GOTO) {
2656                         CV * const gotocv = get_cvs("DB::goto", 0);
2657                         if (gotocv) {
2658                             PUSHMARK( PL_stack_sp );
2659                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2660                             PL_stack_sp--;
2661                         }
2662                     }
2663                 }
2664                 RETURNOP(CvSTART(cv));
2665             }
2666         }
2667         else {
2668             label = SvPV_nolen_const(sv);
2669             if (!(do_dump || *label))
2670                 DIE(aTHX_ must_have_label);
2671         }
2672     }
2673     else if (PL_op->op_flags & OPf_SPECIAL) {
2674         if (! do_dump)
2675             DIE(aTHX_ must_have_label);
2676     }
2677     else
2678         label = cPVOP->op_pv;
2679
2680     PERL_ASYNC_CHECK();
2681
2682     if (label && *label) {
2683         OP *gotoprobe = NULL;
2684         bool leaving_eval = FALSE;
2685         bool in_block = FALSE;
2686         PERL_CONTEXT *last_eval_cx = NULL;
2687
2688         /* find label */
2689
2690         PL_lastgotoprobe = NULL;
2691         *enterops = 0;
2692         for (ix = cxstack_ix; ix >= 0; ix--) {
2693             cx = &cxstack[ix];
2694             switch (CxTYPE(cx)) {
2695             case CXt_EVAL:
2696                 leaving_eval = TRUE;
2697                 if (!CxTRYBLOCK(cx)) {
2698                     gotoprobe = (last_eval_cx ?
2699                                 last_eval_cx->blk_eval.old_eval_root :
2700                                 PL_eval_root);
2701                     last_eval_cx = cx;
2702                     break;
2703                 }
2704                 /* else fall through */
2705             case CXt_LOOP_LAZYIV:
2706             case CXt_LOOP_LAZYSV:
2707             case CXt_LOOP_FOR:
2708             case CXt_LOOP_PLAIN:
2709             case CXt_GIVEN:
2710             case CXt_WHEN:
2711                 gotoprobe = cx->blk_oldcop->op_sibling;
2712                 break;
2713             case CXt_SUBST:
2714                 continue;
2715             case CXt_BLOCK:
2716                 if (ix) {
2717                     gotoprobe = cx->blk_oldcop->op_sibling;
2718                     in_block = TRUE;
2719                 } else
2720                     gotoprobe = PL_main_root;
2721                 break;
2722             case CXt_SUB:
2723                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2724                     gotoprobe = CvROOT(cx->blk_sub.cv);
2725                     break;
2726                 }
2727                 /* FALL THROUGH */
2728             case CXt_FORMAT:
2729             case CXt_NULL:
2730                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2731             default:
2732                 if (ix)
2733                     DIE(aTHX_ "panic: goto");
2734                 gotoprobe = PL_main_root;
2735                 break;
2736             }
2737             if (gotoprobe) {
2738                 retop = dofindlabel(gotoprobe, label,
2739                                     enterops, enterops + GOTO_DEPTH);
2740                 if (retop)
2741                     break;
2742             }
2743             PL_lastgotoprobe = gotoprobe;
2744         }
2745         if (!retop)
2746             DIE(aTHX_ "Can't find label %s", label);
2747
2748         /* if we're leaving an eval, check before we pop any frames
2749            that we're not going to punt, otherwise the error
2750            won't be caught */
2751
2752         if (leaving_eval && *enterops && enterops[1]) {
2753             I32 i;
2754             for (i = 1; enterops[i]; i++)
2755                 if (enterops[i]->op_type == OP_ENTERITER)
2756                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2757         }
2758
2759         if (*enterops && enterops[1]) {
2760             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2761             if (enterops[i])
2762                 deprecate("\"goto\" to jump into a construct");
2763         }
2764
2765         /* pop unwanted frames */
2766
2767         if (ix < cxstack_ix) {
2768             I32 oldsave;
2769
2770             if (ix < 0)
2771                 ix = 0;
2772             dounwind(ix);
2773             TOPBLOCK(cx);
2774             oldsave = PL_scopestack[PL_scopestack_ix];
2775             LEAVE_SCOPE(oldsave);
2776         }
2777
2778         /* push wanted frames */
2779
2780         if (*enterops && enterops[1]) {
2781             OP * const oldop = PL_op;
2782             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2783             for (; enterops[ix]; ix++) {
2784                 PL_op = enterops[ix];
2785                 /* Eventually we may want to stack the needed arguments
2786                  * for each op.  For now, we punt on the hard ones. */
2787                 if (PL_op->op_type == OP_ENTERITER)
2788                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2789                 PL_op->op_ppaddr(aTHX);
2790             }
2791             PL_op = oldop;
2792         }
2793     }
2794
2795     if (do_dump) {
2796 #ifdef VMS
2797         if (!retop) retop = PL_main_start;
2798 #endif
2799         PL_restartop = retop;
2800         PL_do_undump = TRUE;
2801
2802         my_unexec();
2803
2804         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2805         PL_do_undump = FALSE;
2806     }
2807
2808     RETURNOP(retop);
2809 }
2810
2811 PP(pp_exit)
2812 {
2813     dVAR;
2814     dSP;
2815     I32 anum;
2816
2817     if (MAXARG < 1)
2818         anum = 0;
2819     else {
2820         anum = SvIVx(POPs);
2821 #ifdef VMS
2822         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2823             anum = 0;
2824         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2825 #endif
2826     }
2827     PL_exit_flags |= PERL_EXIT_EXPECTED;
2828 #ifdef PERL_MAD
2829     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2830     if (anum || !(PL_minus_c && PL_madskills))
2831         my_exit(anum);
2832 #else
2833     my_exit(anum);
2834 #endif
2835     PUSHs(&PL_sv_undef);
2836     RETURN;
2837 }
2838
2839 /* Eval. */
2840
2841 STATIC void
2842 S_save_lines(pTHX_ AV *array, SV *sv)
2843 {
2844     const char *s = SvPVX_const(sv);
2845     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2846     I32 line = 1;
2847
2848     PERL_ARGS_ASSERT_SAVE_LINES;
2849
2850     while (s && s < send) {
2851         const char *t;
2852         SV * const tmpstr = newSV_type(SVt_PVMG);
2853
2854         t = (const char *)memchr(s, '\n', send - s);
2855         if (t)
2856             t++;
2857         else
2858             t = send;
2859
2860         sv_setpvn(tmpstr, s, t - s);
2861         av_store(array, line++, tmpstr);
2862         s = t;
2863     }
2864 }
2865
2866 /*
2867 =for apidoc docatch
2868
2869 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2870
2871 0 is used as continue inside eval,
2872
2873 3 is used for a die caught by an inner eval - continue inner loop
2874
2875 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2876 establish a local jmpenv to handle exception traps.
2877
2878 =cut
2879 */
2880 STATIC OP *
2881 S_docatch(pTHX_ OP *o)
2882 {
2883     dVAR;
2884     int ret;
2885     OP * const oldop = PL_op;
2886     dJMPENV;
2887
2888 #ifdef DEBUGGING
2889     assert(CATCH_GET == TRUE);
2890 #endif
2891     PL_op = o;
2892
2893     JMPENV_PUSH(ret);
2894     switch (ret) {
2895     case 0:
2896         assert(cxstack_ix >= 0);
2897         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2898         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2899  redo_body:
2900         CALLRUNOPS(aTHX);
2901         break;
2902     case 3:
2903         /* die caught by an inner eval - continue inner loop */
2904         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2905             PL_restartjmpenv = NULL;
2906             PL_op = PL_restartop;
2907             PL_restartop = 0;
2908             goto redo_body;
2909         }
2910         /* FALL THROUGH */
2911     default:
2912         JMPENV_POP;
2913         PL_op = oldop;
2914         JMPENV_JUMP(ret);
2915         /* NOTREACHED */
2916     }
2917     JMPENV_POP;
2918     PL_op = oldop;
2919     return NULL;
2920 }
2921
2922 /* James Bond: Do you expect me to talk?
2923    Auric Goldfinger: No, Mr. Bond. I expect you to die.
2924
2925    This code is an ugly hack, doesn't work with lexicals in subroutines that are
2926    called more than once, and is only used by regcomp.c, for (?{}) blocks.
2927
2928    Currently it is not used outside the core code. Best if it stays that way.
2929 */
2930 OP *
2931 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2932 /* sv Text to convert to OP tree. */
2933 /* startop op_free() this to undo. */
2934 /* code Short string id of the caller. */
2935 {
2936     dVAR; dSP;                          /* Make POPBLOCK work. */
2937     PERL_CONTEXT *cx;
2938     SV **newsp;
2939     I32 gimme = G_VOID;
2940     I32 optype;
2941     OP dummy;
2942     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2943     char *tmpbuf = tbuf;
2944     char *safestr;
2945     int runtime;
2946     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2947     STRLEN len;
2948     bool need_catch;
2949
2950     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2951
2952     ENTER_with_name("eval");
2953     lex_start(sv, NULL, FALSE);
2954     SAVETMPS;
2955     /* switch to eval mode */
2956
2957     if (IN_PERL_COMPILETIME) {
2958         SAVECOPSTASH_FREE(&PL_compiling);
2959         CopSTASH_set(&PL_compiling, PL_curstash);
2960     }
2961     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2962         SV * const sv = sv_newmortal();
2963         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2964                        code, (unsigned long)++PL_evalseq,
2965                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2966         tmpbuf = SvPVX(sv);
2967         len = SvCUR(sv);
2968     }
2969     else
2970         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2971                           (unsigned long)++PL_evalseq);
2972     SAVECOPFILE_FREE(&PL_compiling);
2973     CopFILE_set(&PL_compiling, tmpbuf+2);
2974     SAVECOPLINE(&PL_compiling);
2975     CopLINE_set(&PL_compiling, 1);
2976     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2977        deleting the eval's FILEGV from the stash before gv_check() runs
2978        (i.e. before run-time proper). To work around the coredump that
2979        ensues, we always turn GvMULTI_on for any globals that were
2980        introduced within evals. See force_ident(). GSAR 96-10-12 */
2981     safestr = savepvn(tmpbuf, len);
2982     SAVEDELETE(PL_defstash, safestr, len);
2983     SAVEHINTS();
2984 #ifdef OP_IN_REGISTER
2985     PL_opsave = op;
2986 #else
2987     SAVEVPTR(PL_op);
2988 #endif
2989
2990     /* we get here either during compilation, or via pp_regcomp at runtime */
2991     runtime = IN_PERL_RUNTIME;
2992     if (runtime)
2993         runcv = find_runcv(NULL);
2994
2995     PL_op = &dummy;
2996     PL_op->op_type = OP_ENTEREVAL;
2997     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2998     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2999     PUSHEVAL(cx, 0);
3000     need_catch = CATCH_GET;
3001     CATCH_SET(TRUE);
3002
3003     if (runtime)
3004         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3005     else
3006         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3007     CATCH_SET(need_catch);
3008     POPBLOCK(cx,PL_curpm);
3009     POPEVAL(cx);
3010
3011     (*startop)->op_type = OP_NULL;
3012     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3013     lex_end();
3014     /* XXX DAPM do this properly one year */
3015     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3016     LEAVE_with_name("eval");
3017     if (IN_PERL_COMPILETIME)
3018         CopHINTS_set(&PL_compiling, PL_hints);
3019 #ifdef OP_IN_REGISTER
3020     op = PL_opsave;
3021 #endif
3022     PERL_UNUSED_VAR(newsp);
3023     PERL_UNUSED_VAR(optype);
3024
3025     return PL_eval_start;
3026 }
3027
3028
3029 /*
3030 =for apidoc find_runcv
3031
3032 Locate the CV corresponding to the currently executing sub or eval.
3033 If db_seqp is non_null, skip CVs that are in the DB package and populate
3034 *db_seqp with the cop sequence number at the point that the DB:: code was
3035 entered. (allows debuggers to eval in the scope of the breakpoint rather
3036 than in the scope of the debugger itself).
3037
3038 =cut
3039 */
3040
3041 CV*
3042 Perl_find_runcv(pTHX_ U32 *db_seqp)
3043 {
3044     dVAR;
3045     PERL_SI      *si;
3046
3047     if (db_seqp)
3048         *db_seqp = PL_curcop->cop_seq;
3049     for (si = PL_curstackinfo; si; si = si->si_prev) {
3050         I32 ix;
3051         for (ix = si->si_cxix; ix >= 0; ix--) {
3052             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3053             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3054                 CV * const cv = cx->blk_sub.cv;
3055                 /* skip DB:: code */
3056                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3057                     *db_seqp = cx->blk_oldcop->cop_seq;
3058                     continue;
3059                 }
3060                 return cv;
3061             }
3062             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3063                 return PL_compcv;
3064         }
3065     }
3066     return PL_main_cv;
3067 }
3068
3069
3070 /* Run yyparse() in a setjmp wrapper. Returns:
3071  *   0: yyparse() successful
3072  *   1: yyparse() failed
3073  *   3: yyparse() died
3074  */
3075 STATIC int
3076 S_try_yyparse(pTHX_ int gramtype)
3077 {
3078     int ret;
3079     dJMPENV;
3080
3081     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3082     JMPENV_PUSH(ret);
3083     switch (ret) {
3084     case 0:
3085         ret = yyparse(gramtype) ? 1 : 0;
3086         break;
3087     case 3:
3088         break;
3089     default:
3090         JMPENV_POP;
3091         JMPENV_JUMP(ret);
3092         /* NOTREACHED */
3093     }
3094     JMPENV_POP;
3095     return ret;
3096 }
3097
3098
3099 /* Compile a require/do, an eval '', or a /(?{...})/.
3100  * In the last case, startop is non-null, and contains the address of
3101  * a pointer that should be set to the just-compiled code.
3102  * outside is the lexically enclosing CV (if any) that invoked us.
3103  * Returns a bool indicating whether the compile was successful; if so,
3104  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3105  * pushes undef (also croaks if startop != NULL).
3106  */
3107
3108 STATIC bool
3109 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3110 {
3111     dVAR; dSP;
3112     OP * const saveop = PL_op;
3113     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3114     int yystatus;
3115
3116     PL_in_eval = (in_require
3117                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3118                   : EVAL_INEVAL);
3119
3120     PUSHMARK(SP);
3121
3122     SAVESPTR(PL_compcv);
3123     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3124     CvEVAL_on(PL_compcv);
3125     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3126     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3127
3128     CvOUTSIDE_SEQ(PL_compcv) = seq;
3129     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3130
3131     /* set up a scratch pad */
3132
3133     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3134     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3135
3136
3137     if (!PL_madskills)
3138         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3139
3140     /* make sure we compile in the right package */
3141
3142     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3143         SAVESPTR(PL_curstash);
3144         PL_curstash = CopSTASH(PL_curcop);
3145     }
3146     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3147     SAVESPTR(PL_beginav);
3148     PL_beginav = newAV();
3149     SAVEFREESV(PL_beginav);
3150     SAVESPTR(PL_unitcheckav);
3151     PL_unitcheckav = newAV();
3152     SAVEFREESV(PL_unitcheckav);
3153
3154 #ifdef PERL_MAD
3155     SAVEBOOL(PL_madskills);
3156     PL_madskills = 0;
3157 #endif
3158
3159     /* try to compile it */
3160
3161     PL_eval_root = NULL;
3162     PL_curcop = &PL_compiling;
3163     CopARYBASE_set(PL_curcop, 0);
3164     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3165         PL_in_eval |= EVAL_KEEPERR;
3166     else
3167         CLEAR_ERRSV();
3168
3169     CALL_BLOCK_HOOKS(eval, saveop);
3170
3171     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3172      * so honour CATCH_GET and trap it here if necessary */
3173
3174     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3175
3176     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3177         SV **newsp;                     /* Used by POPBLOCK. */
3178         PERL_CONTEXT *cx = NULL;
3179         I32 optype;                     /* Used by POPEVAL. */
3180         SV *namesv = NULL;
3181         const char *msg;
3182
3183         PERL_UNUSED_VAR(newsp);
3184         PERL_UNUSED_VAR(optype);
3185
3186         /* note that if yystatus == 3, then the EVAL CX block has already
3187          * been popped, and various vars restored */
3188         PL_op = saveop;
3189         if (yystatus != 3) {
3190             if (PL_eval_root) {
3191                 op_free(PL_eval_root);
3192                 PL_eval_root = NULL;
3193             }
3194             SP = PL_stack_base + POPMARK;       /* pop original mark */
3195             if (!startop) {
3196                 POPBLOCK(cx,PL_curpm);
3197                 POPEVAL(cx);
3198                 namesv = cx->blk_eval.old_namesv;
3199             }
3200         }
3201         lex_end();
3202         if (yystatus != 3)
3203             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3204
3205         msg = SvPVx_nolen_const(ERRSV);
3206         if (in_require) {
3207             if (!cx) {
3208                 /* If cx is still NULL, it means that we didn't go in the
3209                  * POPEVAL branch. */
3210                 cx = &cxstack[cxstack_ix];
3211                 assert(CxTYPE(cx) == CXt_EVAL);
3212                 namesv = cx->blk_eval.old_namesv;
3213             }
3214             (void)hv_store(GvHVn(PL_incgv),
3215                            SvPVX_const(namesv), SvCUR(namesv),
3216                            &PL_sv_undef, 0);
3217             Perl_croak(aTHX_ "%sCompilation failed in require",
3218                        *msg ? msg : "Unknown error\n");
3219         }
3220         else if (startop) {
3221             if (yystatus != 3) {
3222                 POPBLOCK(cx,PL_curpm);
3223                 POPEVAL(cx);
3224             }
3225             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3226                        (*msg ? msg : "Unknown error\n"));
3227         }
3228         else {
3229             if (!*msg) {
3230                 sv_setpvs(ERRSV, "Compilation error");
3231             }
3232         }
3233         PUSHs(&PL_sv_undef);
3234         PUTBACK;
3235         return FALSE;
3236     }
3237     CopLINE_set(&PL_compiling, 0);
3238     if (startop) {
3239         *startop = PL_eval_root;
3240     } else
3241         SAVEFREEOP(PL_eval_root);
3242
3243     /* Set the context for this new optree.
3244      * Propagate the context from the eval(). */
3245     if ((gimme & G_WANT) == G_VOID)
3246         scalarvoid(PL_eval_root);
3247     else if ((gimme & G_WANT) == G_ARRAY)
3248         list(PL_eval_root);
3249     else
3250         scalar(PL_eval_root);
3251
3252     DEBUG_x(dump_eval());
3253
3254     /* Register with debugger: */
3255     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3256         CV * const cv = get_cvs("DB::postponed", 0);
3257         if (cv) {
3258             dSP;
3259             PUSHMARK(SP);
3260             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3261             PUTBACK;
3262             call_sv(MUTABLE_SV(cv), G_DISCARD);
3263         }
3264     }
3265
3266     if (PL_unitcheckav) {
3267         OP *es = PL_eval_start;
3268         call_list(PL_scopestack_ix, PL_unitcheckav);
3269         PL_eval_start = es;
3270     }
3271
3272     /* compiled okay, so do it */
3273
3274     CvDEPTH(PL_compcv) = 1;
3275     SP = PL_stack_base + POPMARK;               /* pop original mark */
3276     PL_op = saveop;                     /* The caller may need it. */
3277     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3278
3279     PUTBACK;
3280     return TRUE;
3281 }
3282
3283 STATIC PerlIO *
3284 S_check_type_and_open(pTHX_ const char *name)
3285 {
3286     Stat_t st;
3287     const int st_rc = PerlLIO_stat(name, &st);
3288
3289     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3290
3291     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3292         return NULL;
3293     }
3294
3295     return PerlIO_open(name, PERL_SCRIPT_MODE);
3296 }
3297
3298 #ifndef PERL_DISABLE_PMC
3299 STATIC PerlIO *
3300 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3301 {
3302     PerlIO *fp;
3303
3304     PERL_ARGS_ASSERT_DOOPEN_PM;
3305
3306     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3307         SV *const pmcsv = newSV(namelen + 2);
3308         char *const pmc = SvPVX(pmcsv);
3309         Stat_t pmcstat;
3310
3311         memcpy(pmc, name, namelen);
3312         pmc[namelen] = 'c';
3313         pmc[namelen + 1] = '\0';
3314
3315         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3316             fp = check_type_and_open(name);
3317         }
3318         else {
3319             fp = check_type_and_open(pmc);
3320         }
3321         SvREFCNT_dec(pmcsv);
3322     }
3323     else {
3324         fp = check_type_and_open(name);
3325     }
3326     return fp;
3327 }
3328 #else
3329 #  define doopen_pm(name, namelen) check_type_and_open(name)
3330 #endif /* !PERL_DISABLE_PMC */
3331
3332 PP(pp_require)
3333 {
3334     dVAR; dSP;
3335     register PERL_CONTEXT *cx;
3336     SV *sv;
3337     const char *name;
3338     STRLEN len;
3339     char * unixname;
3340     STRLEN unixlen;
3341 #ifdef VMS
3342     int vms_unixname = 0;
3343 #endif
3344     const char *tryname = NULL;
3345     SV *namesv = NULL;
3346     const I32 gimme = GIMME_V;
3347     int filter_has_file = 0;
3348     PerlIO *tryrsfp = NULL;
3349     SV *filter_cache = NULL;
3350     SV *filter_state = NULL;
3351     SV *filter_sub = NULL;
3352     SV *hook_sv = NULL;
3353     SV *encoding;
3354     OP *op;
3355
3356     sv = POPs;
3357     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3358         sv = new_version(sv);
3359         if (!sv_derived_from(PL_patchlevel, "version"))
3360             upg_version(PL_patchlevel, TRUE);
3361         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3362             if ( vcmp(sv,PL_patchlevel) <= 0 )
3363                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3364                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3365         }
3366         else {
3367             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3368                 I32 first = 0;
3369                 AV *lav;
3370                 SV * const req = SvRV(sv);
3371                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3372
3373                 /* get the left hand term */
3374                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3375
3376                 first  = SvIV(*av_fetch(lav,0,0));
3377                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3378                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3379                     || av_len(lav) > 1               /* FP with > 3 digits */
3380                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3381                    ) {
3382                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3383                         "%"SVf", stopped", SVfARG(vnormal(req)),
3384                         SVfARG(vnormal(PL_patchlevel)));
3385                 }
3386                 else { /* probably 'use 5.10' or 'use 5.8' */
3387                     SV *hintsv;
3388                     I32 second = 0;
3389
3390                     if (av_len(lav)>=1)
3391                         second = SvIV(*av_fetch(lav,1,0));
3392
3393                     second /= second >= 600  ? 100 : 10;
3394                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3395                                            (int)first, (int)second);
3396                     upg_version(hintsv, TRUE);
3397
3398                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3399                         "--this is only %"SVf", stopped",
3400                         SVfARG(vnormal(req)),
3401                         SVfARG(vnormal(sv_2mortal(hintsv))),
3402                         SVfARG(vnormal(PL_patchlevel)));
3403                 }
3404             }
3405         }
3406
3407         /* We do this only with "use", not "require" or "no". */
3408         if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3409             /* If we request a version >= 5.9.5, load feature.pm with the
3410              * feature bundle that corresponds to the required version. */
3411             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3412                 SV *const importsv = vnormal(sv);
3413                 *SvPVX_mutable(importsv) = ':';
3414                 ENTER_with_name("load_feature");
3415                 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3416                 LEAVE_with_name("load_feature");
3417             }
3418             /* If a version >= 5.11.0 is requested, strictures are on by default! */
3419             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3420                 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3421             }
3422         }
3423
3424         RETPUSHYES;
3425     }
3426     name = SvPV_const(sv, len);
3427     if (!(name && len > 0 && *name))
3428         DIE(aTHX_ "Null filename used");
3429     TAINT_PROPER("require");
3430
3431
3432 #ifdef VMS
3433     /* The key in the %ENV hash is in the syntax of file passed as the argument
3434      * usually this is in UNIX format, but sometimes in VMS format, which
3435      * can result in a module being pulled in more than once.
3436      * To prevent this, the key must be stored in UNIX format if the VMS
3437      * name can be translated to UNIX.
3438      */
3439     if ((unixname = tounixspec(name, NULL)) != NULL) {
3440         unixlen = strlen(unixname);
3441         vms_unixname = 1;
3442     }
3443     else
3444 #endif
3445     {
3446         /* if not VMS or VMS name can not be translated to UNIX, pass it
3447          * through.
3448          */
3449         unixname = (char *) name;
3450         unixlen = len;
3451     }
3452     if (PL_op->op_type == OP_REQUIRE) {
3453         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3454                                           unixname, unixlen, 0);
3455         if ( svp ) {
3456             if (*svp != &PL_sv_undef)
3457                 RETPUSHYES;
3458             else
3459                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3460                             "Compilation failed in require", unixname);
3461         }
3462     }
3463
3464     /* prepare to compile file */
3465
3466     if (path_is_absolute(name)) {
3467         tryname = name;
3468         tryrsfp = doopen_pm(name, len);
3469     }
3470     if (!tryrsfp) {
3471         AV * const ar = GvAVn(PL_incgv);
3472         I32 i;
3473 #ifdef VMS
3474         if (vms_unixname)
3475 #endif
3476         {
3477             namesv = newSV_type(SVt_PV);
3478             for (i = 0; i <= AvFILL(ar); i++) {
3479                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3480
3481                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3482                     mg_get(dirsv);
3483                 if (SvROK(dirsv)) {
3484                     int count;
3485                     SV **svp;
3486                     SV *loader = dirsv;
3487
3488                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3489                         && !sv_isobject(loader))
3490                     {
3491                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3492                     }
3493
3494                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3495                                    PTR2UV(SvRV(dirsv)), name);
3496                     tryname = SvPVX_const(namesv);
3497                     tryrsfp = NULL;
3498
3499                     ENTER_with_name("call_INC");
3500                     SAVETMPS;
3501                     EXTEND(SP, 2);
3502
3503                     PUSHMARK(SP);
3504                     PUSHs(dirsv);
3505                     PUSHs(sv);
3506                     PUTBACK;
3507                     if (sv_isobject(loader))
3508                         count = call_method("INC", G_ARRAY);
3509                     else
3510                         count = call_sv(loader, G_ARRAY);
3511                     SPAGAIN;
3512
3513                     if (count > 0) {
3514                         int i = 0;
3515                         SV *arg;
3516
3517                         SP -= count - 1;
3518                         arg = SP[i++];
3519
3520                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3521                             && !isGV_with_GP(SvRV(arg))) {
3522                             filter_cache = SvRV(arg);
3523                             SvREFCNT_inc_simple_void_NN(filter_cache);
3524
3525                             if (i < count) {
3526                                 arg = SP[i++];
3527                             }
3528                         }
3529
3530                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3531                             arg = SvRV(arg);
3532                         }
3533
3534                         if (isGV_with_GP(arg)) {
3535                             IO * const io = GvIO((const GV *)arg);
3536
3537                             ++filter_has_file;
3538
3539                             if (io) {
3540                                 tryrsfp = IoIFP(io);
3541                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3542                                     PerlIO_close(IoOFP(io));
3543                                 }
3544                                 IoIFP(io) = NULL;
3545                                 IoOFP(io) = NULL;
3546                             }
3547
3548                             if (i < count) {
3549                                 arg = SP[i++];
3550                             }
3551                         }
3552
3553                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3554                             filter_sub = arg;
3555                             SvREFCNT_inc_simple_void_NN(filter_sub);
3556
3557                             if (i < count) {
3558                                 filter_state = SP[i];
3559                                 SvREFCNT_inc_simple_void(filter_state);
3560                             }
3561                         }
3562
3563                         if (!tryrsfp && (filter_cache || filter_sub)) {
3564                             tryrsfp = PerlIO_open(BIT_BUCKET,
3565                                                   PERL_SCRIPT_MODE);
3566                         }
3567                         SP--;
3568                     }
3569
3570                     PUTBACK;
3571                     FREETMPS;
3572                     LEAVE_with_name("call_INC");
3573
3574                     /* Adjust file name if the hook has set an %INC entry.
3575                        This needs to happen after the FREETMPS above.  */
3576                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3577                     if (svp)
3578                         tryname = SvPV_nolen_const(*svp);
3579
3580                     if (tryrsfp) {
3581                         hook_sv = dirsv;
3582                         break;
3583                     }
3584
3585                     filter_has_file = 0;
3586                     if (filter_cache) {
3587                         SvREFCNT_dec(filter_cache);
3588                         filter_cache = NULL;
3589                     }
3590                     if (filter_state) {
3591                         SvREFCNT_dec(filter_state);
3592                         filter_state = NULL;
3593                     }
3594                     if (filter_sub) {
3595                         SvREFCNT_dec(filter_sub);
3596                         filter_sub = NULL;
3597                     }
3598                 }
3599                 else {
3600                   if (!path_is_absolute(name)
3601                   ) {
3602                     const char *dir;
3603                     STRLEN dirlen;
3604
3605                     if (SvOK(dirsv)) {
3606                         dir = SvPV_const(dirsv, dirlen);
3607                     } else {
3608                         dir = "";
3609                         dirlen = 0;
3610                     }
3611
3612 #ifdef VMS
3613                     char *unixdir;
3614                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3615                         continue;
3616                     sv_setpv(namesv, unixdir);
3617                     sv_catpv(namesv, unixname);
3618 #else
3619 #  ifdef __SYMBIAN32__
3620                     if (PL_origfilename[0] &&
3621                         PL_origfilename[1] == ':' &&
3622                         !(dir[0] && dir[1] == ':'))
3623                         Perl_sv_setpvf(aTHX_ namesv,
3624                                        "%c:%s\\%s",
3625                                        PL_origfilename[0],
3626                                        dir, name);
3627                     else
3628                         Perl_sv_setpvf(aTHX_ namesv,
3629                                        "%s\\%s",
3630                                        dir, name);
3631 #  else
3632                     /* The equivalent of
3633                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3634                        but without the need to parse the format string, or
3635                        call strlen on either pointer, and with the correct
3636                        allocation up front.  */
3637                     {
3638                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3639
3640                         memcpy(tmp, dir, dirlen);
3641                         tmp +=dirlen;
3642                         *tmp++ = '/';
3643                         /* name came from an SV, so it will have a '\0' at the
3644                            end that we can copy as part of this memcpy().  */
3645                         memcpy(tmp, name, len + 1);
3646
3647                         SvCUR_set(namesv, dirlen + len + 1);
3648
3649                         /* Don't even actually have to turn SvPOK_on() as we
3650                            access it directly with SvPVX() below.  */
3651                     }
3652 #  endif
3653 #endif
3654                     TAINT_PROPER("require");
3655                     tryname = SvPVX_const(namesv);
3656                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3657                     if (tryrsfp) {
3658                         if (tryname[0] == '.' && tryname[1] == '/') {
3659                             ++tryname;
3660                             while (*++tryname == '/');
3661                         }
3662                         break;
3663                     }
3664                     else if (errno == EMFILE)
3665                         /* no point in trying other paths if out of handles */
3666                         break;
3667                   }
3668                 }
3669             }
3670         }
3671     }
3672     if (tryrsfp) {
3673         SAVECOPFILE_FREE(&PL_compiling);
3674         CopFILE_set(&PL_compiling, tryname);
3675     }
3676     SvREFCNT_dec(namesv);
3677     if (!tryrsfp) {
3678         if (PL_op->op_type == OP_REQUIRE) {
3679             if(errno == EMFILE) {
3680                 /* diag_listed_as: Can't locate %s */
3681                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3682             } else {
3683                 if (namesv) {                   /* did we lookup @INC? */
3684                     AV * const ar = GvAVn(PL_incgv);
3685                     I32 i;
3686                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3687                     for (i = 0; i <= AvFILL(ar); i++) {
3688                         sv_catpvs(inc, " ");
3689                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3690                     }
3691
3692                     /* diag_listed_as: Can't locate %s */
3693                     DIE(aTHX_
3694                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3695                         name,
3696                         (memEQ(name + len - 2, ".h", 3)
3697                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3698                         (memEQ(name + len - 3, ".ph", 4)
3699                          ? " (did you run h2ph?)" : ""),
3700                         inc
3701                         );
3702                 }
3703             }
3704             DIE(aTHX_ "Can't locate %s", name);
3705         }
3706
3707         RETPUSHUNDEF;
3708     }
3709     else
3710         SETERRNO(0, SS_NORMAL);
3711
3712     /* Assume success here to prevent recursive requirement. */
3713     /* name is never assigned to again, so len is still strlen(name)  */
3714     /* Check whether a hook in @INC has already filled %INC */
3715     if (!hook_sv) {
3716         (void)hv_store(GvHVn(PL_incgv),
3717                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3718     } else {
3719         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3720         if (!svp)
3721             (void)hv_store(GvHVn(PL_incgv),
3722                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3723     }
3724
3725     ENTER_with_name("eval");
3726     SAVETMPS;
3727     lex_start(NULL, tryrsfp, TRUE);
3728
3729     SAVEHINTS();
3730     PL_hints = 0;
3731     hv_clear(GvHV(PL_hintgv));
3732
3733     SAVECOMPILEWARNINGS();
3734     if (PL_dowarn & G_WARN_ALL_ON)
3735         PL_compiling.cop_warnings = pWARN_ALL ;
3736     else if (PL_dowarn & G_WARN_ALL_OFF)
3737         PL_compiling.cop_warnings = pWARN_NONE ;
3738     else
3739         PL_compiling.cop_warnings = pWARN_STD ;
3740
3741     if (filter_sub || filter_cache) {
3742         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3743            than hanging another SV from it. In turn, filter_add() optionally
3744            takes the SV to use as the filter (or creates a new SV if passed
3745            NULL), so simply pass in whatever value filter_cache has.  */
3746         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3747         IoLINES(datasv) = filter_has_file;
3748         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3749         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3750     }
3751
3752     /* switch to eval mode */
3753     PUSHBLOCK(cx, CXt_EVAL, SP);
3754     PUSHEVAL(cx, name);
3755     cx->blk_eval.retop = PL_op->op_next;
3756
3757     SAVECOPLINE(&PL_compiling);
3758     CopLINE_set(&PL_compiling, 0);
3759
3760     PUTBACK;
3761
3762     /* Store and reset encoding. */
3763     encoding = PL_encoding;
3764     PL_encoding = NULL;
3765
3766     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3767         op = DOCATCH(PL_eval_start);
3768     else
3769         op = PL_op->op_next;
3770
3771     /* Restore encoding. */
3772     PL_encoding = encoding;
3773
3774     return op;
3775 }
3776
3777 /* This is a op added to hold the hints hash for
3778    pp_entereval. The hash can be modified by the code
3779    being eval'ed, so we return a copy instead. */
3780
3781 PP(pp_hintseval)
3782 {
3783     dVAR;
3784     dSP;
3785     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3786     RETURN;
3787 }
3788
3789
3790 PP(pp_entereval)
3791 {
3792     dVAR; dSP;
3793     register PERL_CONTEXT *cx;
3794     SV *sv;
3795     const I32 gimme = GIMME_V;
3796     const U32 was = PL_breakable_sub_gen;
3797     char tbuf[TYPE_DIGITS(long) + 12];
3798     char *tmpbuf = tbuf;
3799     STRLEN len;
3800     CV* runcv;
3801     U32 seq;
3802     HV *saved_hh = NULL;
3803
3804     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3805         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3806     }
3807     sv = POPs;
3808     if (!SvPOK(sv)) {
3809         /* make sure we've got a plain PV (no overload etc) before testing
3810          * for taint. Making a copy here is probably overkill, but better
3811          * safe than sorry */
3812         STRLEN len;
3813         const char * const p = SvPV_const(sv, len);
3814
3815         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3816     }
3817
3818     TAINT_IF(SvTAINTED(sv));
3819     TAINT_PROPER("eval");
3820
3821     ENTER_with_name("eval");
3822     lex_start(sv, NULL, FALSE);
3823     SAVETMPS;
3824
3825     /* switch to eval mode */
3826
3827     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3828         SV * const temp_sv = sv_newmortal();
3829         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3830                        (unsigned long)++PL_evalseq,
3831                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3832         tmpbuf = SvPVX(temp_sv);
3833         len = SvCUR(temp_sv);
3834     }
3835     else
3836         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3837     SAVECOPFILE_FREE(&PL_compiling);
3838     CopFILE_set(&PL_compiling, tmpbuf+2);
3839     SAVECOPLINE(&PL_compiling);
3840     CopLINE_set(&PL_compiling, 1);
3841     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3842        deleting the eval's FILEGV from the stash before gv_check() runs
3843        (i.e. before run-time proper). To work around the coredump that
3844        ensues, we always turn GvMULTI_on for any globals that were
3845        introduced within evals. See force_ident(). GSAR 96-10-12 */
3846     SAVEHINTS();
3847     PL_hints = PL_op->op_targ;
3848     if (saved_hh) {
3849         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3850         SvREFCNT_dec(GvHV(PL_hintgv));
3851         GvHV(PL_hintgv) = saved_hh;
3852     }
3853     SAVECOMPILEWARNINGS();
3854     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3855     if (PL_compiling.cop_hints_hash) {
3856         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3857     }
3858     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3859         /* The label, if present, is the first entry on the chain. So rather
3860            than writing a blank label in front of it (which involves an
3861            allocation), just use the next entry in the chain.  */
3862         PL_compiling.cop_hints_hash
3863             = PL_curcop->cop_hints_hash->refcounted_he_next;
3864         /* Check the assumption that this removed the label.  */
3865         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3866     }
3867     else
3868         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3869     if (PL_compiling.cop_hints_hash) {
3870         HINTS_REFCNT_LOCK;
3871         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3872         HINTS_REFCNT_UNLOCK;
3873     }
3874     /* special case: an eval '' executed within the DB package gets lexically
3875      * placed in the first non-DB CV rather than the current CV - this
3876      * allows the debugger to execute code, find lexicals etc, in the
3877      * scope of the code being debugged. Passing &seq gets find_runcv
3878      * to do the dirty work for us */
3879     runcv = find_runcv(&seq);
3880
3881     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3882     PUSHEVAL(cx, 0);
3883     cx->blk_eval.retop = PL_op->op_next;
3884
3885     /* prepare to compile string */
3886
3887     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3888         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3889     PUTBACK;
3890
3891     if (doeval(gimme, NULL, runcv, seq)) {
3892         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3893             ? (PERLDB_LINE || PERLDB_SAVESRC)
3894             :  PERLDB_SAVESRC_NOSUBS) {
3895             /* Retain the filegv we created.  */
3896         } else {
3897             char *const safestr = savepvn(tmpbuf, len);
3898             SAVEDELETE(PL_defstash, safestr, len);
3899         }
3900         return DOCATCH(PL_eval_start);
3901     } else {
3902         /* We have already left the scope set up earler thanks to the LEAVE
3903            in doeval().  */
3904         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3905             ? (PERLDB_LINE || PERLDB_SAVESRC)
3906             :  PERLDB_SAVESRC_INVALID) {
3907             /* Retain the filegv we created.  */
3908         } else {
3909             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3910         }
3911         return PL_op->op_next;
3912     }
3913 }
3914
3915 PP(pp_leaveeval)
3916 {
3917     dVAR; dSP;
3918     register SV **mark;
3919     SV **newsp;
3920     PMOP *newpm;
3921     I32 gimme;
3922     register PERL_CONTEXT *cx;
3923     OP *retop;
3924     const U8 save_flags = PL_op -> op_flags;
3925     I32 optype;
3926     SV *namesv;
3927
3928     POPBLOCK(cx,newpm);
3929     POPEVAL(cx);
3930     namesv = cx->blk_eval.old_namesv;
3931     retop = cx->blk_eval.retop;
3932
3933     TAINT_NOT;
3934     if (gimme == G_VOID)
3935         MARK = newsp;
3936     else if (gimme == G_SCALAR) {
3937         MARK = newsp + 1;
3938         if (MARK <= SP) {
3939             if (SvFLAGS(TOPs) & SVs_TEMP)
3940                 *MARK = TOPs;
3941             else
3942                 *MARK = sv_mortalcopy(TOPs);
3943         }
3944         else {
3945             MEXTEND(mark,0);
3946             *MARK = &PL_sv_undef;
3947         }
3948         SP = MARK;
3949     }
3950     else {
3951         /* in case LEAVE wipes old return values */
3952         for (mark = newsp + 1; mark <= SP; mark++) {
3953             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3954                 *mark = sv_mortalcopy(*mark);
3955                 TAINT_NOT;      /* Each item is independent */
3956             }
3957         }
3958     }
3959     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3960
3961 #ifdef DEBUGGING
3962     assert(CvDEPTH(PL_compcv) == 1);
3963 #endif
3964     CvDEPTH(PL_compcv) = 0;
3965     lex_end();
3966
3967     if (optype == OP_REQUIRE &&
3968         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3969     {
3970         /* Unassume the success we assumed earlier. */
3971         (void)hv_delete(GvHVn(PL_incgv),
3972                         SvPVX_const(namesv), SvCUR(namesv),
3973                         G_DISCARD);
3974         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3975                                SVfARG(namesv));
3976         /* die_unwind() did LEAVE, or we won't be here */
3977     }
3978     else {
3979         LEAVE_with_name("eval");
3980         if (!(save_flags & OPf_SPECIAL)) {
3981             CLEAR_ERRSV();
3982         }
3983     }
3984
3985     RETURNOP(retop);
3986 }
3987
3988 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3989    close to the related Perl_create_eval_scope.  */
3990 void
3991 Perl_delete_eval_scope(pTHX)
3992 {
3993     SV **newsp;
3994     PMOP *newpm;
3995     I32 gimme;
3996     register PERL_CONTEXT *cx;
3997     I32 optype;
3998
3999     POPBLOCK(cx,newpm);
4000     POPEVAL(cx);
4001     PL_curpm = newpm;
4002     LEAVE_with_name("eval_scope");
4003     PERL_UNUSED_VAR(newsp);
4004     PERL_UNUSED_VAR(gimme);
4005     PERL_UNUSED_VAR(optype);
4006 }
4007
4008 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4009    also needed by Perl_fold_constants.  */
4010 PERL_CONTEXT *
4011 Perl_create_eval_scope(pTHX_ U32 flags)
4012 {
4013     PERL_CONTEXT *cx;
4014     const I32 gimme = GIMME_V;
4015
4016     ENTER_with_name("eval_scope");
4017     SAVETMPS;
4018
4019     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4020     PUSHEVAL(cx, 0);
4021
4022     PL_in_eval = EVAL_INEVAL;
4023     if (flags & G_KEEPERR)
4024         PL_in_eval |= EVAL_KEEPERR;
4025     else
4026         CLEAR_ERRSV();
4027     if (flags & G_FAKINGEVAL) {
4028         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4029     }
4030     return cx;
4031 }
4032
4033 PP(pp_entertry)
4034 {
4035     dVAR;
4036     PERL_CONTEXT * const cx = create_eval_scope(0);
4037     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4038     return DOCATCH(PL_op->op_next);
4039 }
4040
4041 PP(pp_leavetry)
4042 {
4043     dVAR; dSP;
4044     SV **newsp;
4045     PMOP *newpm;
4046     I32 gimme;
4047     register PERL_CONTEXT *cx;
4048     I32 optype;
4049
4050     POPBLOCK(cx,newpm);
4051     POPEVAL(cx);
4052     PERL_UNUSED_VAR(optype);
4053
4054     TAINT_NOT;
4055     if (gimme == G_VOID)
4056         SP = newsp;
4057     else if (gimme == G_SCALAR) {
4058         register SV **mark;
4059         MARK = newsp + 1;
4060         if (MARK <= SP) {
4061             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4062                 *MARK = TOPs;
4063             else
4064                 *MARK = sv_mortalcopy(TOPs);
4065         }
4066         else {
4067             MEXTEND(mark,0);
4068             *MARK = &PL_sv_undef;
4069         }
4070         SP = MARK;
4071     }
4072     else {
4073         /* in case LEAVE wipes old return values */
4074         register SV **mark;
4075         for (mark = newsp + 1; mark <= SP; mark++) {
4076             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4077                 *mark = sv_mortalcopy(*mark);
4078                 TAINT_NOT;      /* Each item is independent */
4079             }
4080         }
4081     }
4082     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4083
4084     LEAVE_with_name("eval_scope");
4085     CLEAR_ERRSV();
4086     RETURN;
4087 }
4088
4089 PP(pp_entergiven)
4090 {
4091     dVAR; dSP;
4092     register PERL_CONTEXT *cx;
4093     const I32 gimme = GIMME_V;
4094
4095     ENTER_with_name("given");
4096     SAVETMPS;
4097
4098     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4099
4100     PUSHBLOCK(cx, CXt_GIVEN, SP);
4101     PUSHGIVEN(cx);
4102
4103     RETURN;
4104 }
4105
4106 PP(pp_leavegiven)
4107 {
4108     dVAR; dSP;
4109     register PERL_CONTEXT *cx;
4110     I32 gimme;
4111     SV **newsp;
4112     PMOP *newpm;
4113     PERL_UNUSED_CONTEXT;
4114
4115     POPBLOCK(cx,newpm);
4116     assert(CxTYPE(cx) == CXt_GIVEN);
4117
4118     TAINT_NOT;
4119     if (gimme == G_VOID)
4120         SP = newsp;
4121     else if (gimme == G_SCALAR) {
4122         register SV **mark;
4123         MARK = newsp + 1;
4124         if (MARK <= SP) {
4125             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4126                 *MARK = TOPs;
4127             else
4128                 *MARK = sv_mortalcopy(TOPs);
4129         }
4130         else {
4131             MEXTEND(mark,0);
4132             *MARK = &PL_sv_undef;
4133         }
4134         SP = MARK;
4135     }
4136     else {
4137         /* in case LEAVE wipes old return values */
4138         register SV **mark;
4139         for (mark = newsp + 1; mark <= SP; mark++) {
4140             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4141                 *mark = sv_mortalcopy(*mark);
4142                 TAINT_NOT;      /* Each item is independent */
4143             }
4144         }
4145     }
4146     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4147
4148     LEAVE_with_name("given");
4149     RETURN;
4150 }
4151
4152 /* Helper routines used by pp_smartmatch */
4153 STATIC PMOP *
4154 S_make_matcher(pTHX_ REGEXP *re)
4155 {
4156     dVAR;
4157     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4158
4159     PERL_ARGS_ASSERT_MAKE_MATCHER;
4160
4161     PM_SETRE(matcher, ReREFCNT_inc(re));
4162
4163     SAVEFREEOP((OP *) matcher);
4164     ENTER_with_name("matcher"); SAVETMPS;
4165     SAVEOP();
4166     return matcher;
4167 }
4168
4169 STATIC bool
4170 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4171 {
4172     dVAR;
4173     dSP;
4174
4175     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4176
4177     PL_op = (OP *) matcher;
4178     XPUSHs(sv);
4179     PUTBACK;
4180     (void) pp_match();
4181     SPAGAIN;
4182     return (SvTRUEx(POPs));
4183 }
4184
4185 STATIC void
4186 S_destroy_matcher(pTHX_ PMOP *matcher)
4187 {
4188     dVAR;
4189
4190     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4191     PERL_UNUSED_ARG(matcher);
4192
4193     FREETMPS;
4194     LEAVE_with_name("matcher");
4195 }
4196
4197 /* Do a smart match */
4198 PP(pp_smartmatch)
4199 {
4200     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4201     return do_smartmatch(NULL, NULL);
4202 }
4203
4204 /* This version of do_smartmatch() implements the
4205  * table of smart matches that is found in perlsyn.
4206  */
4207 STATIC OP *
4208 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4209 {
4210     dVAR;
4211     dSP;
4212
4213     bool object_on_left = FALSE;
4214     SV *e = TOPs;       /* e is for 'expression' */
4215     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4216
4217     /* Take care only to invoke mg_get() once for each argument.
4218      * Currently we do this by copying the SV if it's magical. */
4219     if (d) {
4220         if (SvGMAGICAL(d))
4221             d = sv_mortalcopy(d);
4222     }
4223     else
4224         d = &PL_sv_undef;
4225
4226     assert(e);
4227     if (SvGMAGICAL(e))
4228         e = sv_mortalcopy(e);
4229
4230     /* First of all, handle overload magic of the rightmost argument */
4231     if (SvAMAGIC(e)) {
4232         SV * tmpsv;
4233         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4234         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4235
4236         tmpsv = amagic_call(d, e, smart_amg, 0);
4237         if (tmpsv) {
4238             SPAGAIN;
4239             (void)POPs;
4240             SETs(tmpsv);
4241             RETURN;
4242         }
4243         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4244     }
4245
4246     SP -= 2;    /* Pop the values */
4247
4248
4249     /* ~~ undef */
4250     if (!SvOK(e)) {
4251         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4252         if (SvOK(d))
4253             RETPUSHNO;
4254         else
4255             RETPUSHYES;
4256     }
4257
4258     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4259         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4260         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4261     }
4262     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4263         object_on_left = TRUE;
4264
4265     /* ~~ sub */
4266     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4267         I32 c;
4268         if (object_on_left) {
4269             goto sm_any_sub; /* Treat objects like scalars */
4270         }
4271         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4272             /* Test sub truth for each key */
4273             HE *he;
4274             bool andedresults = TRUE;
4275             HV *hv = (HV*) SvRV(d);
4276             I32 numkeys = hv_iterinit(hv);
4277             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4278             if (numkeys == 0)
4279                 RETPUSHYES;
4280             while ( (he = hv_iternext(hv)) ) {
4281                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4282                 ENTER_with_name("smartmatch_hash_key_test");
4283                 SAVETMPS;
4284                 PUSHMARK(SP);
4285                 PUSHs(hv_iterkeysv(he));
4286                 PUTBACK;
4287                 c = call_sv(e, G_SCALAR);
4288                 SPAGAIN;
4289                 if (c == 0)
4290                     andedresults = FALSE;
4291                 else
4292                     andedresults = SvTRUEx(POPs) && andedresults;
4293                 FREETMPS;
4294                 LEAVE_with_name("smartmatch_hash_key_test");
4295             }
4296             if (andedresults)
4297                 RETPUSHYES;
4298             else
4299                 RETPUSHNO;
4300         }
4301         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4302             /* Test sub truth for each element */
4303             I32 i;
4304             bool andedresults = TRUE;
4305             AV *av = (AV*) SvRV(d);
4306             const I32 len = av_len(av);
4307             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4308             if (len == -1)
4309                 RETPUSHYES;
4310             for (i = 0; i <= len; ++i) {
4311                 SV * const * const svp = av_fetch(av, i, FALSE);
4312                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4313                 ENTER_with_name("smartmatch_array_elem_test");
4314                 SAVETMPS;
4315                 PUSHMARK(SP);
4316                 if (svp)
4317                     PUSHs(*svp);
4318                 PUTBACK;
4319                 c = call_sv(e, G_SCALAR);
4320                 SPAGAIN;
4321                 if (c == 0)
4322                     andedresults = FALSE;
4323                 else
4324                     andedresults = SvTRUEx(POPs) && andedresults;
4325                 FREETMPS;
4326                 LEAVE_with_name("smartmatch_array_elem_test");
4327             }
4328             if (andedresults)
4329                 RETPUSHYES;
4330             else
4331                 RETPUSHNO;
4332         }
4333         else {
4334           sm_any_sub:
4335             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4336             ENTER_with_name("smartmatch_coderef");
4337             SAVETMPS;
4338             PUSHMARK(SP);
4339             PUSHs(d);
4340             PUTBACK;
4341             c = call_sv(e, G_SCALAR);
4342             SPAGAIN;
4343             if (c == 0)
4344                 PUSHs(&PL_sv_no);
4345             else if (SvTEMP(TOPs))
4346                 SvREFCNT_inc_void(TOPs);
4347             FREETMPS;
4348             LEAVE_with_name("smartmatch_coderef");
4349             RETURN;
4350         }
4351     }
4352     /* ~~ %hash */
4353     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4354         if (object_on_left) {
4355             goto sm_any_hash; /* Treat objects like scalars */
4356         }
4357         else if (!SvOK(d)) {
4358             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4359             RETPUSHNO;
4360         }
4361         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4362             /* Check that the key-sets are identical */
4363             HE *he;
4364             HV *other_hv = MUTABLE_HV(SvRV(d));
4365             bool tied = FALSE;
4366             bool other_tied = FALSE;
4367             U32 this_key_count  = 0,
4368                 other_key_count = 0;
4369             HV *hv = MUTABLE_HV(SvRV(e));
4370
4371             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4372             /* Tied hashes don't know how many keys they have. */
4373             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4374                 tied = TRUE;
4375             }
4376             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4377                 HV * const temp = other_hv;
4378                 other_hv = hv;
4379                 hv = temp;
4380                 tied = TRUE;
4381             }
4382             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4383                 other_tied = TRUE;
4384
4385             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4386                 RETPUSHNO;
4387
4388             /* The hashes have the same number of keys, so it suffices
4389                to check that one is a subset of the other. */
4390             (void) hv_iterinit(hv);
4391             while ( (he = hv_iternext(hv)) ) {
4392                 SV *key = hv_iterkeysv(he);
4393
4394                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4395                 ++ this_key_count;
4396
4397                 if(!hv_exists_ent(other_hv, key, 0)) {
4398                     (void) hv_iterinit(hv);     /* reset iterator */
4399                     RETPUSHNO;
4400                 }
4401             }
4402
4403             if (other_tied) {
4404                 (void) hv_iterinit(other_hv);
4405                 while ( hv_iternext(other_hv) )
4406                     ++other_key_count;
4407             }
4408             else
4409                 other_key_count = HvUSEDKEYS(other_hv);
4410
4411             if (this_key_count != other_key_count)
4412                 RETPUSHNO;
4413             else
4414                 RETPUSHYES;
4415         }
4416         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4417             AV * const other_av = MUTABLE_AV(SvRV(d));
4418             const I32 other_len = av_len(other_av) + 1;
4419             I32 i;
4420             HV *hv = MUTABLE_HV(SvRV(e));
4421
4422             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4423             for (i = 0; i < other_len; ++i) {
4424                 SV ** const svp = av_fetch(other_av, i, FALSE);
4425                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4426                 if (svp) {      /* ??? When can this not happen? */
4427                     if (hv_exists_ent(hv, *svp, 0))
4428                         RETPUSHYES;
4429                 }
4430             }
4431             RETPUSHNO;
4432         }
4433         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4434             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4435           sm_regex_hash:
4436             {
4437                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4438                 HE *he;
4439                 HV *hv = MUTABLE_HV(SvRV(e));
4440
4441                 (void) hv_iterinit(hv);
4442                 while ( (he = hv_iternext(hv)) ) {
4443                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4444                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4445                         (void) hv_iterinit(hv);
4446                         destroy_matcher(matcher);
4447                         RETPUSHYES;
4448                     }
4449                 }
4450                 destroy_matcher(matcher);
4451                 RETPUSHNO;
4452             }
4453         }
4454         else {
4455           sm_any_hash:
4456             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4457             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4458                 RETPUSHYES;
4459             else
4460                 RETPUSHNO;
4461         }
4462     }
4463     /* ~~ @array */
4464     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4465         if (object_on_left) {
4466             goto sm_any_array; /* Treat objects like scalars */
4467         }
4468         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4469             AV * const other_av = MUTABLE_AV(SvRV(e));
4470             const I32 other_len = av_len(other_av) + 1;
4471             I32 i;
4472
4473             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4474             for (i = 0; i < other_len; ++i) {
4475                 SV ** const svp = av_fetch(other_av, i, FALSE);
4476
4477                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4478                 if (svp) {      /* ??? When can this not happen? */
4479                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4480                         RETPUSHYES;
4481                 }
4482             }
4483             RETPUSHNO;
4484         }
4485         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4486             AV *other_av = MUTABLE_AV(SvRV(d));
4487             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4488             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4489                 RETPUSHNO;
4490             else {
4491                 I32 i;
4492                 const I32 other_len = av_len(other_av);
4493
4494                 if (NULL == seen_this) {
4495 &n