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(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 (eng)
 223                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 224             else
 225                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 226
 227             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 228                                            inside tie/overload accessors.  */
 229         }
 230     }
 231
 232     re = PM_GETRE(pm);
 233
 234 #ifndef INCOMPLETE_TAINTS
 235     if (PL_tainting) {
 236         if (PL_tainted)
 237             RX_EXTFLAGS(re) |= RXf_TAINTED;
 238         else
 239             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 240     }
 241 #endif
 242
 243     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 244         pm = PL_curpm;
 245
 246
 247 #if !defined(USE_ITHREADS)
 248     /* can't change the optree at runtime either */
 249     /* PMf_KEEP is handled differently under threads to avoid these problems */
 250     if (pm->op_pmflags & PMf_KEEP) {
 251         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 252         cLOGOP->op_first->op_next = PL_op->op_next;
 253     }
 254 #endif
 255     RETURN;
 256 }
 257
 258 PP(pp_substcont)
 259 {
 260     dVAR;
 261     dSP;
 262     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 263     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 264     register SV * const dstr = cx->sb_dstr;
 265     register char *s = cx->sb_s;
 266     register char *m = cx->sb_m;
 267     char *orig = cx->sb_orig;
 268     register REGEXP * const rx = cx->sb_rx;
 269     SV *nsv = NULL;
 270     REGEXP *old = PM_GETRE(pm);
 271
 272     PERL_ASYNC_CHECK();
 273
 274     if(old != rx) {
 275         if(old)
 276             ReREFCNT_dec(old);
 277         PM_SETRE(pm,ReREFCNT_inc(rx));
 278     }
 279
 280     rxres_restore(&cx->sb_rxres, rx);
 281     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 282
 283     if (cx->sb_iters++) {
 284         const I32 saviters = cx->sb_iters;
 285         if (cx->sb_iters > cx->sb_maxiters)
 286             DIE(aTHX_ "Substitution loop");
 287
 288         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 289
 290         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 291             cx->sb_rxtainted |= 2;
 292         sv_catsv_nomg(dstr, POPs);
 293         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 294         s -= RX_GOFS(rx);
 295
 296         /* Are we done */
 297         if (CxONCE(cx) || s < orig ||
 298                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 299                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 300                              ((cx->sb_rflags & REXEC_COPY_STR)
 301                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 302                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 303         {
 304             SV * const targ = cx->sb_targ;
 305
 306             assert(cx->sb_strend >= s);
 307             if(cx->sb_strend > s) {
 308                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 309                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 310                  else
 311                       sv_catpvn(dstr, s, cx->sb_strend - s);
 312             }
 313             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 314
 315 #ifdef PERL_OLD_COPY_ON_WRITE
 316             if (SvIsCOW(targ)) {
 317                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 318             } else
 319 #endif
 320             {
 321                 SvPV_free(targ);
 322             }
 323             SvPV_set(targ, SvPVX(dstr));
 324             SvCUR_set(targ, SvCUR(dstr));
 325             SvLEN_set(targ, SvLEN(dstr));
 326             if (DO_UTF8(dstr))
 327                 SvUTF8_on(targ);
 328             SvPV_set(dstr, NULL);
 329
 330             TAINT_IF(cx->sb_rxtainted & 1);
 331             if (pm->op_pmflags & PMf_NONDESTRUCT)
 332                 PUSHs(targ);
 333             else
 334                 mPUSHi(saviters - 1);
 335
 336             (void)SvPOK_only_UTF8(targ);
 337             TAINT_IF(cx->sb_rxtainted);
 338             SvSETMAGIC(targ);
 339             SvTAINT(targ);
 340
 341             LEAVE_SCOPE(cx->sb_oldsave);
 342             POPSUBST(cx);
 343             RETURNOP(pm->op_next);
 344         }
 345         cx->sb_iters = saviters;
 346     }
 347     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 348         m = s;
 349         s = orig;
 350         cx->sb_orig = orig = RX_SUBBEG(rx);
 351         s = orig + (m - s);
 352         cx->sb_strend = s + (cx->sb_strend - m);
 353     }
 354     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 355     if (m > s) {
 356         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 357             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 358         else
 359             sv_catpvn(dstr, s, m-s);
 360     }
 361     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 362     { /* Update the pos() information. */
 363         SV * const sv = cx->sb_targ;
 364         MAGIC *mg;
 365         SvUPGRADE(sv, SVt_PVMG);
 366         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 367 #ifdef PERL_OLD_COPY_ON_WRITE
 368             if (SvIsCOW(sv))
 369                 sv_force_normal_flags(sv, 0);
 370 #endif
 371             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 372                              NULL, 0);
 373         }
 374         mg->mg_len = m - orig;
 375     }
 376     if (old != rx)
 377         (void)ReREFCNT_inc(rx);
 378     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 379     rxres_save(&cx->sb_rxres, rx);
 380     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 381 }
 382
 383 void
 384 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 385 {
 386     UV *p = (UV*)*rsp;
 387     U32 i;
 388
 389     PERL_ARGS_ASSERT_RXRES_SAVE;
 390     PERL_UNUSED_CONTEXT;
 391
 392     if (!p || p[1] < RX_NPARENS(rx)) {
 393 #ifdef PERL_OLD_COPY_ON_WRITE
 394         i = 7 + RX_NPARENS(rx) * 2;
 395 #else
 396         i = 6 + RX_NPARENS(rx) * 2;
 397 #endif
 398         if (!p)
 399             Newx(p, i, UV);
 400         else
 401             Renew(p, i, UV);
 402         *rsp = (void*)p;
 403     }
 404
 405     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 406     RX_MATCH_COPIED_off(rx);
 407
 408 #ifdef PERL_OLD_COPY_ON_WRITE
 409     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 410     RX_SAVED_COPY(rx) = NULL;
 411 #endif
 412
 413     *p++ = RX_NPARENS(rx);
 414
 415     *p++ = PTR2UV(RX_SUBBEG(rx));
 416     *p++ = (UV)RX_SUBLEN(rx);
 417     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 418         *p++ = (UV)RX_OFFS(rx)[i].start;
 419         *p++ = (UV)RX_OFFS(rx)[i].end;
 420     }
 421 }
 422
 423 static void
 424 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 425 {
 426     UV *p = (UV*)*rsp;
 427     U32 i;
 428
 429     PERL_ARGS_ASSERT_RXRES_RESTORE;
 430     PERL_UNUSED_CONTEXT;
 431
 432     RX_MATCH_COPY_FREE(rx);
 433     RX_MATCH_COPIED_set(rx, *p);
 434     *p++ = 0;
 435
 436 #ifdef PERL_OLD_COPY_ON_WRITE
 437     if (RX_SAVED_COPY(rx))
 438         SvREFCNT_dec (RX_SAVED_COPY(rx));
 439     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 440     *p++ = 0;
 441 #endif
 442
 443     RX_NPARENS(rx) = *p++;
 444
 445     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 446     RX_SUBLEN(rx) = (I32)(*p++);
 447     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 448         RX_OFFS(rx)[i].start = (I32)(*p++);
 449         RX_OFFS(rx)[i].end = (I32)(*p++);
 450     }
 451 }
 452
 453 static void
 454 S_rxres_free(pTHX_ void **rsp)
 455 {
 456     UV * const p = (UV*)*rsp;
 457
 458     PERL_ARGS_ASSERT_RXRES_FREE;
 459     PERL_UNUSED_CONTEXT;
 460
 461     if (p) {
 462 #ifdef PERL_POISON
 463         void *tmp = INT2PTR(char*,*p);
 464         Safefree(tmp);
 465         if (*p)
 466             PoisonFree(*p, 1, sizeof(*p));
 467 #else
 468         Safefree(INT2PTR(char*,*p));
 469 #endif
 470 #ifdef PERL_OLD_COPY_ON_WRITE
 471         if (p[1]) {
 472             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 473         }
 474 #endif
 475         Safefree(p);
 476         *rsp = NULL;
 477     }
 478 }
 479
 480 PP(pp_formline)
 481 {
 482     dVAR; dSP; dMARK; dORIGMARK;
 483     register SV * const tmpForm = *++MARK;
 484     register U32 *fpc;
 485     register char *t;
 486     const char *f;
 487     register I32 arg;
 488     register SV *sv = NULL;
 489     const char *item = NULL;
 490     I32 itemsize  = 0;
 491     I32 fieldsize = 0;
 492     I32 lines = 0;
 493     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 494     const char *chophere = NULL;
 495     char *linemark = NULL;
 496     NV value;
 497     bool gotsome = FALSE;
 498     STRLEN len;
 499     const STRLEN fudge = SvPOK(tmpForm)
 500                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 501     bool item_is_utf8 = FALSE;
 502     bool targ_is_utf8 = FALSE;
 503     SV * nsv = NULL;
 504     OP * parseres = NULL;
 505     const char *fmt;
 506
 507     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 508         if (SvREADONLY(tmpForm)) {
 509             SvREADONLY_off(tmpForm);
 510             parseres = doparseform(tmpForm);
 511             SvREADONLY_on(tmpForm);
 512         }
 513         else
 514             parseres = doparseform(tmpForm);
 515         if (parseres)
 516             return parseres;
 517     }
 518     SvPV_force(PL_formtarget, len);
 519     if (DO_UTF8(PL_formtarget))
 520         targ_is_utf8 = TRUE;
 521     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 522     t += len;
 523     f = SvPV_const(tmpForm, len);
 524     /* need to jump to the next word */
 525     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 526
 527     for (;;) {
 528         DEBUG_f( {
 529             const char *name = "???";
 530             arg = -1;
 531             switch (*fpc) {
 532             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 533             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 534             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 535             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 536             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 537
 538             case FF_CHECKNL:    name = "CHECKNL";       break;
 539             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 540             case FF_SPACE:      name = "SPACE";         break;
 541             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 542             case FF_ITEM:       name = "ITEM";          break;
 543             case FF_CHOP:       name = "CHOP";          break;
 544             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 545             case FF_NEWLINE:    name = "NEWLINE";       break;
 546             case FF_MORE:       name = "MORE";          break;
 547             case FF_LINEMARK:   name = "LINEMARK";      break;
 548             case FF_END:        name = "END";           break;
 549             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 550             case FF_LINESNGL:   name = "LINESNGL";      break;
 551             }
 552             if (arg >= 0)
 553                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 554             else
 555                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 556         } );
 557         switch (*fpc++) {
 558         case FF_LINEMARK:
 559             linemark = t;
 560             lines++;
 561             gotsome = FALSE;
 562             break;
 563
 564         case FF_LITERAL:
 565             arg = *fpc++;
 566             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 567                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 568                 *t = '\0';
 569                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 570                 t = SvEND(PL_formtarget);
 571                 f += arg;
 572                 break;
 573             }
 574             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 575                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 576                 *t = '\0';
 577                 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 578                 t = SvEND(PL_formtarget);
 579                 targ_is_utf8 = TRUE;
 580             }
 581             while (arg--)
 582                 *t++ = *f++;
 583             break;
 584
 585         case FF_SKIP:
 586             f += *fpc++;
 587             break;
 588
 589         case FF_FETCH:
 590             arg = *fpc++;
 591             f += arg;
 592             fieldsize = arg;
 593
 594             if (MARK < SP)
 595                 sv = *++MARK;
 596             else {
 597                 sv = &PL_sv_no;
 598                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 599             }
 600             break;
 601
 602         case FF_CHECKNL:
 603             {
 604                 const char *send;
 605                 const char *s = item = SvPV_const(sv, len);
 606                 itemsize = len;
 607                 if (DO_UTF8(sv)) {
 608                     itemsize = sv_len_utf8(sv);
 609                     if (itemsize != (I32)len) {
 610                         I32 itembytes;
 611                         if (itemsize > fieldsize) {
 612                             itemsize = fieldsize;
 613                             itembytes = itemsize;
 614                             sv_pos_u2b(sv, &itembytes, 0);
 615                         }
 616                         else
 617                             itembytes = len;
 618                         send = chophere = s + itembytes;
 619                         while (s < send) {
 620                             if (*s & ~31)
 621                                 gotsome = TRUE;
 622                             else if (*s == '\n')
 623                                 break;
 624                             s++;
 625                         }
 626                         item_is_utf8 = TRUE;
 627                         itemsize = s - item;
 628                         sv_pos_b2u(sv, &itemsize);
 629                         break;
 630                     }
 631                 }
 632                 item_is_utf8 = FALSE;
 633                 if (itemsize > fieldsize)
 634                     itemsize = fieldsize;
 635                 send = chophere = s + itemsize;
 636                 while (s < send) {
 637                     if (*s & ~31)
 638                         gotsome = TRUE;
 639                     else if (*s == '\n')
 640                         break;
 641                     s++;
 642                 }
 643                 itemsize = s - item;
 644                 break;
 645             }
 646
 647         case FF_CHECKCHOP:
 648             {
 649                 const char *s = item = SvPV_const(sv, len);
 650                 itemsize = len;
 651                 if (DO_UTF8(sv)) {
 652                     itemsize = sv_len_utf8(sv);
 653                     if (itemsize != (I32)len) {
 654                         I32 itembytes;
 655                         if (itemsize <= fieldsize) {
 656                             const char *send = chophere = s + itemsize;
 657                             while (s < send) {
 658                                 if (*s == '\r') {
 659                                     itemsize = s - item;
 660                                     chophere = s;
 661                                     break;
 662                                 }
 663                                 if (*s++ & ~31)
 664                                     gotsome = TRUE;
 665                             }
 666                         }
 667                         else {
 668                             const char *send;
 669                             itemsize = fieldsize;
 670                             itembytes = itemsize;
 671                             sv_pos_u2b(sv, &itembytes, 0);
 672                             send = chophere = s + itembytes;
 673                             while (s < send || (s == send && isSPACE(*s))) {
 674                                 if (isSPACE(*s)) {
 675                                     if (chopspace)
 676                                         chophere = s;
 677                                     if (*s == '\r')
 678                                         break;
 679                                 }
 680                                 else {
 681                                     if (*s & ~31)
 682                                         gotsome = TRUE;
 683                                     if (strchr(PL_chopset, *s))
 684                                         chophere = s + 1;
 685                                 }
 686                                 s++;
 687                             }
 688                             itemsize = chophere - item;
 689                             sv_pos_b2u(sv, &itemsize);
 690                         }
 691                         item_is_utf8 = TRUE;
 692                         break;
 693                     }
 694                 }
 695                 item_is_utf8 = FALSE;
 696                 if (itemsize <= fieldsize) {
 697                     const char *const send = chophere = s + itemsize;
 698                     while (s < send) {
 699                         if (*s == '\r') {
 700                             itemsize = s - item;
 701                             chophere = s;
 702                             break;
 703                         }
 704                         if (*s++ & ~31)
 705                             gotsome = TRUE;
 706                     }
 707                 }
 708                 else {
 709                     const char *send;
 710                     itemsize = fieldsize;
 711                     send = chophere = s + itemsize;
 712                     while (s < send || (s == send && isSPACE(*s))) {
 713                         if (isSPACE(*s)) {
 714                             if (chopspace)
 715                                 chophere = s;
 716                             if (*s == '\r')
 717                                 break;
 718                         }
 719                         else {
 720                             if (*s & ~31)
 721                                 gotsome = TRUE;
 722                             if (strchr(PL_chopset, *s))
 723                                 chophere = s + 1;
 724                         }
 725                         s++;
 726                     }
 727                     itemsize = chophere - item;
 728                 }
 729                 break;
 730             }
 731
 732         case FF_SPACE:
 733             arg = fieldsize - itemsize;
 734             if (arg) {
 735                 fieldsize -= arg;
 736                 while (arg-- > 0)
 737                     *t++ = ' ';
 738             }
 739             break;
 740
 741         case FF_HALFSPACE:
 742             arg = fieldsize - itemsize;
 743             if (arg) {
 744                 arg /= 2;
 745                 fieldsize -= arg;
 746                 while (arg-- > 0)
 747                     *t++ = ' ';
 748             }
 749             break;
 750
 751         case FF_ITEM:
 752             {
 753                 const char *s = item;
 754                 arg = itemsize;
 755                 if (item_is_utf8) {
 756                     if (!targ_is_utf8) {
 757                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 758                         *t = '\0';
 759                         sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
 760                                                                     fudge + 1);
 761                         t = SvEND(PL_formtarget);
 762                         targ_is_utf8 = TRUE;
 763                     }
 764                     while (arg--) {
 765                         if (UTF8_IS_CONTINUED(*s)) {
 766                             STRLEN skip = UTF8SKIP(s);
 767                             switch (skip) {
 768                             default:
 769                                 Move(s,t,skip,char);
 770                                 s += skip;
 771                                 t += skip;
 772                                 break;
 773                             case 7: *t++ = *s++;
 774                             case 6: *t++ = *s++;
 775                             case 5: *t++ = *s++;
 776                             case 4: *t++ = *s++;
 777                             case 3: *t++ = *s++;
 778                             case 2: *t++ = *s++;
 779                             case 1: *t++ = *s++;
 780                             }
 781                         }
 782                         else {
 783                             if ( !((*t++ = *s++) & ~31) )
 784                                 t[-1] = ' ';
 785                         }
 786                     }
 787                     break;
 788                 }
 789                 if (targ_is_utf8 && !item_is_utf8) {
 790                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 791                     *t = '\0';
 792                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 793                     for (; t < SvEND(PL_formtarget); t++) {
 794 #ifdef EBCDIC
 795                         const int ch = *t;
 796                         if (iscntrl(ch))
 797 #else
 798                             if (!(*t & ~31))
 799 #endif
 800                                 *t = ' ';
 801                     }
 802                     break;
 803                 }
 804                 while (arg--) {
 805 #ifdef EBCDIC
 806                     const int ch = *t++ = *s++;
 807                     if (iscntrl(ch))
 808 #else
 809                         if ( !((*t++ = *s++) & ~31) )
 810 #endif
 811                             t[-1] = ' ';
 812                 }
 813                 break;
 814             }
 815
 816         case FF_CHOP:
 817             {
 818                 const char *s = chophere;
 819                 if (chopspace) {
 820                     while (isSPACE(*s))
 821                         s++;
 822                 }
 823                 sv_chop(sv,s);
 824                 SvSETMAGIC(sv);
 825                 break;
 826             }
 827
 828         case FF_LINESNGL:
 829             chopspace = 0;
 830         case FF_LINEGLOB:
 831             {
 832                 const bool oneline = fpc[-1] == FF_LINESNGL;
 833                 const char *s = item = SvPV_const(sv, len);
 834                 item_is_utf8 = DO_UTF8(sv);
 835                 itemsize = len;
 836                 if (itemsize) {
 837                     STRLEN to_copy = itemsize;
 838                     const char *const send = s + len;
 839                     const U8 *source = (const U8 *) s;
 840                     U8 *tmp = NULL;
 841
 842                     gotsome = TRUE;
 843                     chophere = s + itemsize;
 844                     while (s < send) {
 845                         if (*s++ == '\n') {
 846                             if (oneline) {
 847                                 to_copy = s - SvPVX_const(sv) - 1;
 848                                 chophere = s;
 849                                 break;
 850                             } else {
 851                                 if (s == send) {
 852                                     itemsize--;
 853                                     to_copy--;
 854                                 } else
 855                                     lines++;
 856                             }
 857                         }
 858                     }
 859                     if (targ_is_utf8 && !item_is_utf8) {
 860                         source = tmp = bytes_to_utf8(source, &to_copy);
 861                         SvCUR_set(PL_formtarget,
 862                                   t - SvPVX_const(PL_formtarget));
 863                     } else {
 864                         if (item_is_utf8 && !targ_is_utf8) {
 865                             /* Upgrade targ to UTF8, and then we reduce it to
 866                                a problem we have a simple solution for.  */
 867                             SvCUR_set(PL_formtarget,
 868                                       t - SvPVX_const(PL_formtarget));
 869                             targ_is_utf8 = TRUE;
 870                             /* Don't need get magic.  */
 871                             sv_utf8_upgrade_nomg(PL_formtarget);
 872                         } else {
 873                             SvCUR_set(PL_formtarget,
 874                                       t - SvPVX_const(PL_formtarget));
 875                         }
 876
 877                         /* Easy. They agree.  */
 878                         assert (item_is_utf8 == targ_is_utf8);
 879                     }
 880                     SvGROW(PL_formtarget,
 881                            SvCUR(PL_formtarget) + to_copy + fudge + 1);
 882                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 883
 884                     Copy(source, t, to_copy, char);
 885                     t += to_copy;
 886                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 887                     if (item_is_utf8) {
 888                         if (SvGMAGICAL(sv)) {
 889                             /* Mustn't call sv_pos_b2u() as it does a second
 890                                mg_get(). Is this a bug? Do we need a _flags()
 891                                variant? */
 892                             itemsize = utf8_length(source, source + itemsize);
 893                         } else {
 894                             sv_pos_b2u(sv, &itemsize);
 895                         }
 896                         assert(!tmp);
 897                     } else if (tmp) {
 898                         Safefree(tmp);
 899                     }
 900                 }
 901                 break;
 902             }
 903
 904         case FF_0DECIMAL:
 905             arg = *fpc++;
 906 #if defined(USE_LONG_DOUBLE)
 907             fmt = (const char *)
 908                 ((arg & 256) ?
 909                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 910 #else
 911             fmt = (const char *)
 912                 ((arg & 256) ?
 913                  "%#0*.*f"              : "%0*.*f");
 914 #endif
 915             goto ff_dec;
 916         case FF_DECIMAL:
 917             arg = *fpc++;
 918 #if defined(USE_LONG_DOUBLE)
 919             fmt = (const char *)
 920                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 921 #else
 922             fmt = (const char *)
 923                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 924 #endif
 925         ff_dec:
 926             /* If the field is marked with ^ and the value is undefined,
 927                blank it out. */
 928             if ((arg & 512) && !SvOK(sv)) {
 929                 arg = fieldsize;
 930                 while (arg--)
 931                     *t++ = ' ';
 932                 break;
 933             }
 934             gotsome = TRUE;
 935             value = SvNV(sv);
 936             /* overflow evidence */
 937             if (num_overflow(value, fieldsize, arg)) {
 938                 arg = fieldsize;
 939                 while (arg--)
 940                     *t++ = '#';
 941                 break;
 942             }
 943             /* Formats aren't yet marked for locales, so assume "yes". */
 944             {
 945                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 946                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 947                 RESTORE_NUMERIC_STANDARD();
 948             }
 949             t += fieldsize;
 950             break;
 951
 952         case FF_NEWLINE:
 953             f++;
 954             while (t-- > linemark && *t == ' ') ;
 955             t++;
 956             *t++ = '\n';
 957             break;
 958
 959         case FF_BLANK:
 960             arg = *fpc++;
 961             if (gotsome) {
 962                 if (arg) {              /* repeat until fields exhausted? */
 963                     *t = '\0';
 964                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 965                     lines += FmLINES(PL_formtarget);
 966                     if (targ_is_utf8)
 967                         SvUTF8_on(PL_formtarget);
 968                     FmLINES(PL_formtarget) = lines;
 969                     SP = ORIGMARK;
 970                     RETURNOP(cLISTOP->op_first);
 971                 }
 972             }
 973             else {
 974                 t = linemark;
 975                 lines--;
 976             }
 977             break;
 978
 979         case FF_MORE:
 980             {
 981                 const char *s = chophere;
 982                 const char *send = item + len;
 983                 if (chopspace) {
 984                     while (isSPACE(*s) && (s < send))
 985                         s++;
 986                 }
 987                 if (s < send) {
 988                     char *s1;
 989                     arg = fieldsize - itemsize;
 990                     if (arg) {
 991                         fieldsize -= arg;
 992                         while (arg-- > 0)
 993                             *t++ = ' ';
 994                     }
 995                     s1 = t - 3;
 996                     if (strnEQ(s1,"   ",3)) {
 997                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 998                             s1--;
 999                     }
1000                     *s1++ = '.';
1001                     *s1++ = '.';
1002                     *s1++ = '.';
1003                 }
1004                 break;
1005             }
1006         case FF_END:
1007             *t = '\0';
1008             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1009             if (targ_is_utf8)
1010                 SvUTF8_on(PL_formtarget);
1011             FmLINES(PL_formtarget) += lines;
1012             SP = ORIGMARK;
1013             RETPUSHYES;
1014         }
1015     }
1016 }
1017
1018 PP(pp_grepstart)
1019 {
1020     dVAR; dSP;
1021     SV *src;
1022
1023     if (PL_stack_base + *PL_markstack_ptr == SP) {
1024         (void)POPMARK;
1025         if (GIMME_V == G_SCALAR)
1026             mXPUSHi(0);
1027         RETURNOP(PL_op->op_next->op_next);
1028     }
1029     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1030     pp_pushmark();                              /* push dst */
1031     pp_pushmark();                              /* push src */
1032     ENTER_with_name("grep");                                    /* enter outer scope */
1033
1034     SAVETMPS;
1035     if (PL_op->op_private & OPpGREP_LEX)
1036         SAVESPTR(PAD_SVl(PL_op->op_targ));
1037     else
1038         SAVE_DEFSV;
1039     ENTER_with_name("grep_item");                                       /* enter inner scope */
1040     SAVEVPTR(PL_curpm);
1041
1042     src = PL_stack_base[*PL_markstack_ptr];
1043     SvTEMP_off(src);
1044     if (PL_op->op_private & OPpGREP_LEX)
1045         PAD_SVl(PL_op->op_targ) = src;
1046     else
1047         DEFSV_set(src);
1048
1049     PUTBACK;
1050     if (PL_op->op_type == OP_MAPSTART)
1051         pp_pushmark();                  /* push top */
1052     return ((LOGOP*)PL_op->op_next)->op_other;
1053 }
1054
1055 PP(pp_mapwhile)
1056 {
1057     dVAR; dSP;
1058     const I32 gimme = GIMME_V;
1059     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1060     I32 count;
1061     I32 shift;
1062     SV** src;
1063     SV** dst;
1064
1065     /* first, move source pointer to the next item in the source list */
1066     ++PL_markstack_ptr[-1];
1067
1068     /* if there are new items, push them into the destination list */
1069     if (items && gimme != G_VOID) {
1070         /* might need to make room back there first */
1071         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1072             /* XXX this implementation is very pessimal because the stack
1073              * is repeatedly extended for every set of items.  Is possible
1074              * to do this without any stack extension or copying at all
1075              * by maintaining a separate list over which the map iterates
1076              * (like foreach does). --gsar */
1077
1078             /* everything in the stack after the destination list moves
1079              * towards the end the stack by the amount of room needed */
1080             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1081
1082             /* items to shift up (accounting for the moved source pointer) */
1083             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1084
1085             /* This optimization is by Ben Tilly and it does
1086              * things differently from what Sarathy (gsar)
1087              * is describing.  The downside of this optimization is
1088              * that leaves "holes" (uninitialized and hopefully unused areas)
1089              * to the Perl stack, but on the other hand this
1090              * shouldn't be a problem.  If Sarathy's idea gets
1091              * implemented, this optimization should become
1092              * irrelevant.  --jhi */
1093             if (shift < count)
1094                 shift = count; /* Avoid shifting too often --Ben Tilly */
1095
1096             EXTEND(SP,shift);
1097             src = SP;
1098             dst = (SP += shift);
1099             PL_markstack_ptr[-1] += shift;
1100             *PL_markstack_ptr += shift;
1101             while (count--)
1102                 *dst-- = *src--;
1103         }
1104         /* copy the new items down to the destination list */
1105         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1106         if (gimme == G_ARRAY) {
1107             while (items-- > 0)
1108                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1109         }
1110         else {
1111             /* scalar context: we don't care about which values map returns
1112              * (we use undef here). And so we certainly don't want to do mortal
1113              * copies of meaningless values. */
1114             while (items-- > 0) {
1115                 (void)POPs;
1116                 *dst-- = &PL_sv_undef;
1117             }
1118         }
1119     }
1120     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1121
1122     /* All done yet? */
1123     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1124
1125         (void)POPMARK;                          /* pop top */
1126         LEAVE_with_name("grep");                                        /* exit outer scope */
1127         (void)POPMARK;                          /* pop src */
1128         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1129         (void)POPMARK;                          /* pop dst */
1130         SP = PL_stack_base + POPMARK;           /* pop original mark */
1131         if (gimme == G_SCALAR) {
1132             if (PL_op->op_private & OPpGREP_LEX) {
1133                 SV* sv = sv_newmortal();
1134                 sv_setiv(sv, items);
1135                 PUSHs(sv);
1136             }
1137             else {
1138                 dTARGET;
1139                 XPUSHi(items);
1140             }
1141         }
1142         else if (gimme == G_ARRAY)
1143             SP += items;
1144         RETURN;
1145     }
1146     else {
1147         SV *src;
1148
1149         ENTER_with_name("grep_item");                                   /* enter inner scope */
1150         SAVEVPTR(PL_curpm);
1151
1152         /* set $_ to the new source item */
1153         src = PL_stack_base[PL_markstack_ptr[-1]];
1154         SvTEMP_off(src);
1155         if (PL_op->op_private & OPpGREP_LEX)
1156             PAD_SVl(PL_op->op_targ) = src;
1157         else
1158             DEFSV_set(src);
1159
1160         RETURNOP(cLOGOP->op_other);
1161     }
1162 }
1163
1164 /* Range stuff. */
1165
1166 PP(pp_range)
1167 {
1168     dVAR;
1169     if (GIMME == G_ARRAY)
1170         return NORMAL;
1171     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1172         return cLOGOP->op_other;
1173     else
1174         return NORMAL;
1175 }
1176
1177 PP(pp_flip)
1178 {
1179     dVAR;
1180     dSP;
1181
1182     if (GIMME == G_ARRAY) {
1183         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1184     }
1185     else {
1186         dTOPss;
1187         SV * const targ = PAD_SV(PL_op->op_targ);
1188         int flip = 0;
1189
1190         if (PL_op->op_private & OPpFLIP_LINENUM) {
1191             if (GvIO(PL_last_in_gv)) {
1192                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1193             }
1194             else {
1195                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1196                 if (gv && GvSV(gv))
1197                     flip = SvIV(sv) == SvIV(GvSV(gv));
1198             }
1199         } else {
1200             flip = SvTRUE(sv);
1201         }
1202         if (flip) {
1203             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1204             if (PL_op->op_flags & OPf_SPECIAL) {
1205                 sv_setiv(targ, 1);
1206                 SETs(targ);
1207                 RETURN;
1208             }
1209             else {
1210                 sv_setiv(targ, 0);
1211                 SP--;
1212                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1213             }
1214         }
1215         sv_setpvs(TARG, "");
1216         SETs(targ);
1217         RETURN;
1218     }
1219 }
1220
1221 /* This code tries to decide if "$left .. $right" should use the
1222    magical string increment, or if the range is numeric (we make
1223    an exception for .."0" [#18165]). AMS 20021031. */
1224
1225 #define RANGE_IS_NUMERIC(left,right) ( \
1226         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1227         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1228         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1229           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1230          && (!SvOK(right) || looks_like_number(right))))
1231
1232 PP(pp_flop)
1233 {
1234     dVAR; dSP;
1235
1236     if (GIMME == G_ARRAY) {
1237         dPOPPOPssrl;
1238
1239         SvGETMAGIC(left);
1240         SvGETMAGIC(right);
1241
1242         if (RANGE_IS_NUMERIC(left,right)) {
1243             register IV i, j;
1244             IV max;
1245             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1246                 (SvOK(right) && SvNV(right) > IV_MAX))
1247                 DIE(aTHX_ "Range iterator outside integer range");
1248             i = SvIV(left);
1249             max = SvIV(right);
1250             if (max >= i) {
1251                 j = max - i + 1;
1252                 EXTEND_MORTAL(j);
1253                 EXTEND(SP, j);
1254             }
1255             else
1256                 j = 0;
1257             while (j--) {
1258                 SV * const sv = sv_2mortal(newSViv(i++));
1259                 PUSHs(sv);
1260             }
1261         }
1262         else {
1263             SV * const final = sv_mortalcopy(right);
1264             STRLEN len;
1265             const char * const tmps = SvPV_const(final, len);
1266
1267             SV *sv = sv_mortalcopy(left);
1268             SvPV_force_nolen(sv);
1269             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1270                 XPUSHs(sv);
1271                 if (strEQ(SvPVX_const(sv),tmps))
1272                     break;
1273                 sv = sv_2mortal(newSVsv(sv));
1274                 sv_inc(sv);
1275             }
1276         }
1277     }
1278     else {
1279         dTOPss;
1280         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1281         int flop = 0;
1282         sv_inc(targ);
1283
1284         if (PL_op->op_private & OPpFLIP_LINENUM) {
1285             if (GvIO(PL_last_in_gv)) {
1286                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1287             }
1288             else {
1289                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1290                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1291             }
1292         }
1293         else {
1294             flop = SvTRUE(sv);
1295         }
1296
1297         if (flop) {
1298             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1299             sv_catpvs(targ, "E0");
1300         }
1301         SETs(targ);
1302     }
1303
1304     RETURN;
1305 }
1306
1307 /* Control. */
1308
1309 static const char * const context_name[] = {
1310     "pseudo-block",
1311     NULL, /* CXt_WHEN never actually needs "block" */
1312     NULL, /* CXt_BLOCK never actually needs "block" */
1313     NULL, /* CXt_GIVEN never actually needs "block" */
1314     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1315     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1316     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1317     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1318     "subroutine",
1319     "format",
1320     "eval",
1321     "substitution",
1322 };
1323
1324 STATIC I32
1325 S_dopoptolabel(pTHX_ const char *label)
1326 {
1327     dVAR;
1328     register I32 i;
1329
1330     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1331
1332     for (i = cxstack_ix; i >= 0; i--) {
1333         register const PERL_CONTEXT * const cx = &cxstack[i];
1334         switch (CxTYPE(cx)) {
1335         case CXt_SUBST:
1336         case CXt_SUB:
1337         case CXt_FORMAT:
1338         case CXt_EVAL:
1339         case CXt_NULL:
1340             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1341                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1342             if (CxTYPE(cx) == CXt_NULL)
1343                 return -1;
1344             break;
1345         case CXt_LOOP_LAZYIV:
1346         case CXt_LOOP_LAZYSV:
1347         case CXt_LOOP_FOR:
1348         case CXt_LOOP_PLAIN:
1349           {
1350             const char *cx_label = CxLABEL(cx);
1351             if (!cx_label || strNE(label, cx_label) ) {
1352                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1353                         (long)i, cx_label));
1354                 continue;
1355             }
1356             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1357             return i;
1358           }
1359         }
1360     }
1361     return i;
1362 }
1363
1364
1365
1366 I32
1367 Perl_dowantarray(pTHX)
1368 {
1369     dVAR;
1370     const I32 gimme = block_gimme();
1371     return (gimme == G_VOID) ? G_SCALAR : gimme;
1372 }
1373
1374 I32
1375 Perl_block_gimme(pTHX)
1376 {
1377     dVAR;
1378     const I32 cxix = dopoptosub(cxstack_ix);
1379     if (cxix < 0)
1380         return G_VOID;
1381
1382     switch (cxstack[cxix].blk_gimme) {
1383     case G_VOID:
1384         return G_VOID;
1385     case G_SCALAR:
1386         return G_SCALAR;
1387     case G_ARRAY:
1388         return G_ARRAY;
1389     default:
1390         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1391         /* NOTREACHED */
1392         return 0;
1393     }
1394 }
1395
1396 I32
1397 Perl_is_lvalue_sub(pTHX)
1398 {
1399     dVAR;
1400     const I32 cxix = dopoptosub(cxstack_ix);
1401     assert(cxix >= 0);  /* We should only be called from inside subs */
1402
1403     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1404         return CxLVAL(cxstack + cxix);
1405     else
1406         return 0;
1407 }
1408
1409 STATIC I32
1410 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1411 {
1412     dVAR;
1413     I32 i;
1414
1415     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1416
1417     for (i = startingblock; i >= 0; i--) {
1418         register const PERL_CONTEXT * const cx = &cxstk[i];
1419         switch (CxTYPE(cx)) {
1420         default:
1421             continue;
1422         case CXt_EVAL:
1423         case CXt_SUB:
1424         case CXt_FORMAT:
1425             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1426             return i;
1427         }
1428     }
1429     return i;
1430 }
1431
1432 STATIC I32
1433 S_dopoptoeval(pTHX_ I32 startingblock)
1434 {
1435     dVAR;
1436     I32 i;
1437     for (i = startingblock; i >= 0; i--) {
1438         register const PERL_CONTEXT *cx = &cxstack[i];
1439         switch (CxTYPE(cx)) {
1440         default:
1441             continue;
1442         case CXt_EVAL:
1443             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1444             return i;
1445         }
1446     }
1447     return i;
1448 }
1449
1450 STATIC I32
1451 S_dopoptoloop(pTHX_ I32 startingblock)
1452 {
1453     dVAR;
1454     I32 i;
1455     for (i = startingblock; i >= 0; i--) {
1456         register const PERL_CONTEXT * const cx = &cxstack[i];
1457         switch (CxTYPE(cx)) {
1458         case CXt_SUBST:
1459         case CXt_SUB:
1460         case CXt_FORMAT:
1461         case CXt_EVAL:
1462         case CXt_NULL:
1463             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1464                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1465             if ((CxTYPE(cx)) == CXt_NULL)
1466                 return -1;
1467             break;
1468         case CXt_LOOP_LAZYIV:
1469         case CXt_LOOP_LAZYSV:
1470         case CXt_LOOP_FOR:
1471         case CXt_LOOP_PLAIN:
1472             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1473             return i;
1474         }
1475     }
1476     return i;
1477 }
1478
1479 STATIC I32
1480 S_dopoptogiven(pTHX_ I32 startingblock)
1481 {
1482     dVAR;
1483     I32 i;
1484     for (i = startingblock; i >= 0; i--) {
1485         register const PERL_CONTEXT *cx = &cxstack[i];
1486         switch (CxTYPE(cx)) {
1487         default:
1488             continue;
1489         case CXt_GIVEN:
1490             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1491             return i;
1492         case CXt_LOOP_PLAIN:
1493             assert(!CxFOREACHDEF(cx));
1494             break;
1495         case CXt_LOOP_LAZYIV:
1496         case CXt_LOOP_LAZYSV:
1497         case CXt_LOOP_FOR:
1498             if (CxFOREACHDEF(cx)) {
1499                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1500                 return i;
1501             }
1502         }
1503     }
1504     return i;
1505 }
1506
1507 STATIC I32
1508 S_dopoptowhen(pTHX_ I32 startingblock)
1509 {
1510     dVAR;
1511     I32 i;
1512     for (i = startingblock; i >= 0; i--) {
1513         register const PERL_CONTEXT *cx = &cxstack[i];
1514         switch (CxTYPE(cx)) {
1515         default:
1516             continue;
1517         case CXt_WHEN:
1518             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1519             return i;
1520         }
1521     }
1522     return i;
1523 }
1524
1525 void
1526 Perl_dounwind(pTHX_ I32 cxix)
1527 {
1528     dVAR;
1529     I32 optype;
1530
1531     while (cxstack_ix > cxix) {
1532         SV *sv;
1533         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1534         DEBUG_CX("UNWIND");                                             \
1535         /* Note: we don't need to restore the base context info till the end. */
1536         switch (CxTYPE(cx)) {
1537         case CXt_SUBST:
1538             POPSUBST(cx);
1539             continue;  /* not break */
1540         case CXt_SUB:
1541             POPSUB(cx,sv);
1542             LEAVESUB(sv);
1543             break;
1544         case CXt_EVAL:
1545             POPEVAL(cx);
1546             break;
1547         case CXt_LOOP_LAZYIV:
1548         case CXt_LOOP_LAZYSV:
1549         case CXt_LOOP_FOR:
1550         case CXt_LOOP_PLAIN:
1551             POPLOOP(cx);
1552             break;
1553         case CXt_NULL:
1554             break;
1555         case CXt_FORMAT:
1556             POPFORMAT(cx);
1557             break;
1558         }
1559         cxstack_ix--;
1560     }
1561     PERL_UNUSED_VAR(optype);
1562 }
1563
1564 void
1565 Perl_qerror(pTHX_ SV *err)
1566 {
1567     dVAR;
1568
1569     PERL_ARGS_ASSERT_QERROR;
1570
1571     if (PL_in_eval)
1572         sv_catsv(ERRSV, err);
1573     else if (PL_errors)
1574         sv_catsv(PL_errors, err);
1575     else
1576         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1577     if (PL_parser)
1578         ++PL_parser->error_count;
1579 }
1580
1581 void
1582 Perl_die_unwind(pTHX_ SV *msv)
1583 {
1584     dVAR;
1585     SV *exceptsv = sv_mortalcopy(msv);
1586     U8 in_eval = PL_in_eval;
1587     PERL_ARGS_ASSERT_DIE_UNWIND;
1588
1589     if (in_eval) {
1590         I32 cxix;
1591         I32 gimme;
1592
1593         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1594                && PL_curstackinfo->si_prev)
1595         {
1596             dounwind(-1);
1597             POPSTACK;
1598         }
1599
1600         if (cxix >= 0) {
1601             I32 optype;
1602             SV *namesv;
1603             register PERL_CONTEXT *cx;
1604             SV **newsp;
1605
1606             if (cxix < cxstack_ix)
1607                 dounwind(cxix);
1608
1609             POPBLOCK(cx,PL_curpm);
1610             if (CxTYPE(cx) != CXt_EVAL) {
1611                 STRLEN msglen;
1612                 const char* message = SvPVx_const(exceptsv, msglen);
1613                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1614                 PerlIO_write(Perl_error_log, message, msglen);
1615                 my_exit(1);
1616             }
1617             POPEVAL(cx);
1618             namesv = cx->blk_eval.old_namesv;
1619
1620             if (gimme == G_SCALAR)
1621                 *++newsp = &PL_sv_undef;
1622             PL_stack_sp = newsp;
1623
1624             LEAVE;
1625
1626             /* LEAVE could clobber PL_curcop (see save_re_context())
1627              * XXX it might be better to find a way to avoid messing with
1628              * PL_curcop in save_re_context() instead, but this is a more
1629              * minimal fix --GSAR */
1630             PL_curcop = cx->blk_oldcop;
1631
1632             if (optype == OP_REQUIRE) {
1633                 const char* const msg = SvPVx_nolen_const(exceptsv);
1634                 (void)hv_store(GvHVn(PL_incgv),
1635                                SvPVX_const(namesv), SvCUR(namesv),
1636                                &PL_sv_undef, 0);
1637                 /* note that unlike pp_entereval, pp_require isn't
1638                  * supposed to trap errors. So now that we've popped the
1639                  * EVAL that pp_require pushed, and processed the error
1640                  * message, rethrow the error */
1641                 Perl_croak(aTHX_ "%sCompilation failed in require",
1642                            *msg ? msg : "Unknown error\n");
1643             }
1644             if (in_eval & EVAL_KEEPERR) {
1645                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1646                                SvPV_nolen_const(exceptsv));
1647             }
1648             else {
1649                 sv_setsv(ERRSV, exceptsv);
1650             }
1651             assert(CxTYPE(cx) == CXt_EVAL);
1652             PL_restartjmpenv = cx->blk_eval.cur_top_env;
1653             PL_restartop = cx->blk_eval.retop;
1654             JMPENV_JUMP(3);
1655             /* NOTREACHED */
1656         }
1657     }
1658
1659     write_to_stderr(exceptsv);
1660     my_failure_exit();
1661     /* NOTREACHED */
1662 }
1663
1664 PP(pp_xor)
1665 {
1666     dVAR; dSP; dPOPTOPssrl;
1667     if (SvTRUE(left) != SvTRUE(right))
1668         RETSETYES;
1669     else
1670         RETSETNO;
1671 }
1672
1673 /*
1674 =for apidoc caller_cx
1675
1676 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1677 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1678 information returned to Perl by C<caller>. Note that XSUBs don't get a
1679 stack frame, so C<caller_cx(0, NULL)> will return information for the
1680 immediately-surrounding Perl code.
1681
1682 This function skips over the automatic calls to C<&DB::sub> made on the
1683 behalf of the debugger. If the stack frame requested was a sub called by
1684 C<DB::sub>, the return value will be the frame for the call to
1685 C<DB::sub>, since that has the correct line number/etc. for the call
1686 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1687 frame for the sub call itself.
1688
1689 =cut
1690 */
1691
1692 const PERL_CONTEXT *
1693 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1694 {
1695     register I32 cxix = dopoptosub(cxstack_ix);
1696     register const PERL_CONTEXT *cx;
1697     register const PERL_CONTEXT *ccstack = cxstack;
1698     const PERL_SI *top_si = PL_curstackinfo;
1699
1700     for (;;) {
1701         /* we may be in a higher stacklevel, so dig down deeper */
1702         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1703             top_si = top_si->si_prev;
1704             ccstack = top_si->si_cxstack;
1705             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1706         }
1707         if (cxix < 0)
1708             return NULL;
1709         /* caller() should not report the automatic calls to &DB::sub */
1710         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1711                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1712             count++;
1713         if (!count--)
1714             break;
1715         cxix = dopoptosub_at(ccstack, cxix - 1);
1716     }
1717
1718     cx = &ccstack[cxix];
1719     if (dbcxp) *dbcxp = cx;
1720
1721     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1722         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1723         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1724            field below is defined for any cx. */
1725         /* caller() should not report the automatic calls to &DB::sub */
1726         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1727             cx = &ccstack[dbcxix];
1728     }
1729
1730     return cx;
1731 }
1732
1733 PP(pp_caller)
1734 {
1735     dVAR;
1736     dSP;
1737     register const PERL_CONTEXT *cx;
1738     const PERL_CONTEXT *dbcx;
1739     I32 gimme;
1740     const char *stashname;
1741     I32 count = 0;
1742
1743     if (MAXARG)
1744         count = POPi;
1745
1746     cx = caller_cx(count, &dbcx);
1747     if (!cx) {
1748         if (GIMME != G_ARRAY) {
1749             EXTEND(SP, 1);
1750             RETPUSHUNDEF;
1751         }
1752         RETURN;
1753     }
1754
1755     stashname = CopSTASHPV(cx->blk_oldcop);
1756     if (GIMME != G_ARRAY) {
1757         EXTEND(SP, 1);
1758         if (!stashname)
1759             PUSHs(&PL_sv_undef);
1760         else {
1761             dTARGET;
1762             sv_setpv(TARG, stashname);
1763             PUSHs(TARG);
1764         }
1765         RETURN;
1766     }
1767
1768     EXTEND(SP, 11);
1769
1770     if (!stashname)
1771         PUSHs(&PL_sv_undef);
1772     else
1773         mPUSHs(newSVpv(stashname, 0));
1774     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1775     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1776     if (!MAXARG)
1777         RETURN;
1778     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1779         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1780         /* So is ccstack[dbcxix]. */
1781         if (isGV(cvgv)) {
1782             SV * const sv = newSV(0);
1783             gv_efullname3(sv, cvgv, NULL);
1784             mPUSHs(sv);
1785             PUSHs(boolSV(CxHASARGS(cx)));
1786         }
1787         else {
1788             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1789             PUSHs(boolSV(CxHASARGS(cx)));
1790         }
1791     }
1792     else {
1793         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1794         mPUSHi(0);
1795     }
1796     gimme = (I32)cx->blk_gimme;
1797     if (gimme == G_VOID)
1798         PUSHs(&PL_sv_undef);
1799     else
1800         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1801     if (CxTYPE(cx) == CXt_EVAL) {
1802         /* eval STRING */
1803         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1804             PUSHs(cx->blk_eval.cur_text);
1805             PUSHs(&PL_sv_no);
1806         }
1807         /* require */
1808         else if (cx->blk_eval.old_namesv) {
1809             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1810             PUSHs(&PL_sv_yes);
1811         }
1812         /* eval BLOCK (try blocks have old_namesv == 0) */
1813         else {
1814             PUSHs(&PL_sv_undef);
1815             PUSHs(&PL_sv_undef);
1816         }
1817     }
1818     else {
1819         PUSHs(&PL_sv_undef);
1820         PUSHs(&PL_sv_undef);
1821     }
1822     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1823         && CopSTASH_eq(PL_curcop, PL_debstash))
1824     {
1825         AV * const ary = cx->blk_sub.argarray;
1826         const int off = AvARRAY(ary) - AvALLOC(ary);
1827
1828         if (!PL_dbargs)
1829             Perl_init_dbargs(aTHX);
1830
1831         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1832             av_extend(PL_dbargs, AvFILLp(ary) + off);
1833         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1834         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1835     }
1836     /* XXX only hints propagated via op_private are currently
1837      * visible (others are not easily accessible, since they
1838      * use the global PL_hints) */
1839     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1840     {
1841         SV * mask ;
1842         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1843
1844         if  (old_warnings == pWARN_NONE ||
1845                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1846             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1847         else if (old_warnings == pWARN_ALL ||
1848                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1849             /* Get the bit mask for $warnings::Bits{all}, because
1850              * it could have been extended by warnings::register */
1851             SV **bits_all;
1852             HV * const bits = get_hv("warnings::Bits", 0);
1853             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1854                 mask = newSVsv(*bits_all);
1855             }
1856             else {
1857                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1858             }
1859         }
1860         else
1861             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1862         mPUSHs(mask);
1863     }
1864
1865     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1866           sv_2mortal(newRV_noinc(
1867                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1868                                               cx->blk_oldcop->cop_hints_hash))))
1869           : &PL_sv_undef);
1870     RETURN;
1871 }
1872
1873 PP(pp_reset)
1874 {
1875     dVAR;
1876     dSP;
1877     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1878     sv_reset(tmps, CopSTASH(PL_curcop));
1879     PUSHs(&PL_sv_yes);
1880     RETURN;
1881 }
1882
1883 /* like pp_nextstate, but used instead when the debugger is active */
1884
1885 PP(pp_dbstate)
1886 {
1887     dVAR;
1888     PL_curcop = (COP*)PL_op;
1889     TAINT_NOT;          /* Each statement is presumed innocent */
1890     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1891     FREETMPS;
1892
1893     PERL_ASYNC_CHECK();
1894
1895     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1896             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1897     {
1898         dSP;
1899         register PERL_CONTEXT *cx;
1900         const I32 gimme = G_ARRAY;
1901         U8 hasargs;
1902         GV * const gv = PL_DBgv;
1903         register CV * const cv = GvCV(gv);
1904
1905         if (!cv)
1906             DIE(aTHX_ "No DB::DB routine defined");
1907
1908         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1909             /* don't do recursive DB::DB call */
1910             return NORMAL;
1911
1912         ENTER;
1913         SAVETMPS;
1914
1915         SAVEI32(PL_debug);
1916         SAVESTACK_POS();
1917         PL_debug = 0;
1918         hasargs = 0;
1919         SPAGAIN;
1920
1921         if (CvISXSUB(cv)) {
1922             CvDEPTH(cv)++;
1923             PUSHMARK(SP);
1924             (void)(*CvXSUB(cv))(aTHX_ cv);
1925             CvDEPTH(cv)--;
1926             FREETMPS;
1927             LEAVE;
1928             return NORMAL;
1929         }
1930         else {
1931             PUSHBLOCK(cx, CXt_SUB, SP);
1932             PUSHSUB_DB(cx);
1933             cx->blk_sub.retop = PL_op->op_next;
1934             CvDEPTH(cv)++;
1935             SAVECOMPPAD();
1936             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1937             RETURNOP(CvSTART(cv));
1938         }
1939     }
1940     else
1941         return NORMAL;
1942 }
1943
1944 PP(pp_enteriter)
1945 {
1946     dVAR; dSP; dMARK;
1947     register PERL_CONTEXT *cx;
1948     const I32 gimme = GIMME_V;
1949     SV **svp;
1950     U8 cxtype = CXt_LOOP_FOR;
1951 #ifdef USE_ITHREADS
1952     PAD *iterdata;
1953 #endif
1954
1955     ENTER_with_name("loop1");
1956     SAVETMPS;
1957
1958     if (PL_op->op_targ) {
1959         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1960             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1961             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1962                     SVs_PADSTALE, SVs_PADSTALE);
1963         }
1964         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1965 #ifndef USE_ITHREADS
1966         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1967 #else
1968         iterdata = NULL;
1969 #endif
1970     }
1971     else {
1972         GV * const gv = MUTABLE_GV(POPs);
1973         svp = &GvSV(gv);                        /* symbol table variable */
1974         SAVEGENERICSV(*svp);
1975         *svp = newSV(0);
1976 #ifdef USE_ITHREADS
1977         iterdata = (PAD*)gv;
1978 #endif
1979     }
1980
1981     if (PL_op->op_private & OPpITER_DEF)
1982         cxtype |= CXp_FOR_DEF;
1983
1984     ENTER_with_name("loop2");
1985
1986     PUSHBLOCK(cx, cxtype, SP);
1987 #ifdef USE_ITHREADS
1988     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1989 #else
1990     PUSHLOOP_FOR(cx, svp, MARK, 0);
1991 #endif
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         call_list(PL_scopestack_ix, PL_unitcheckav);
3268
3269     /* compiled okay, so do it */
3270
3271     CvDEPTH(PL_compcv) = 1;
3272     SP = PL_stack_base + POPMARK;               /* pop original mark */
3273     PL_op = saveop;                     /* The caller may need it. */
3274     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3275
3276     PUTBACK;
3277     return TRUE;
3278 }
3279
3280 STATIC PerlIO *
3281 S_check_type_and_open(pTHX_ const char *name)
3282 {
3283     Stat_t st;
3284     const int st_rc = PerlLIO_stat(name, &st);
3285
3286     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3287
3288     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3289         return NULL;
3290     }
3291
3292     return PerlIO_open(name, PERL_SCRIPT_MODE);
3293 }
3294
3295 #ifndef PERL_DISABLE_PMC
3296 STATIC PerlIO *
3297 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3298 {
3299     PerlIO *fp;
3300
3301     PERL_ARGS_ASSERT_DOOPEN_PM;
3302
3303     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3304         SV *const pmcsv = newSV(namelen + 2);
3305         char *const pmc = SvPVX(pmcsv);
3306         Stat_t pmcstat;
3307
3308         memcpy(pmc, name, namelen);
3309         pmc[namelen] = 'c';
3310         pmc[namelen + 1] = '\0';
3311
3312         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3313             fp = check_type_and_open(name);
3314         }
3315         else {
3316             fp = check_type_and_open(pmc);
3317         }
3318         SvREFCNT_dec(pmcsv);
3319     }
3320     else {
3321         fp = check_type_and_open(name);
3322     }
3323     return fp;
3324 }
3325 #else
3326 #  define doopen_pm(name, namelen) check_type_and_open(name)
3327 #endif /* !PERL_DISABLE_PMC */
3328
3329 PP(pp_require)
3330 {
3331     dVAR; dSP;
3332     register PERL_CONTEXT *cx;
3333     SV *sv;
3334     const char *name;
3335     STRLEN len;
3336     char * unixname;
3337     STRLEN unixlen;
3338 #ifdef VMS
3339     int vms_unixname = 0;
3340 #endif
3341     const char *tryname = NULL;
3342     SV *namesv = NULL;
3343     const I32 gimme = GIMME_V;
3344     int filter_has_file = 0;
3345     PerlIO *tryrsfp = NULL;
3346     SV *filter_cache = NULL;
3347     SV *filter_state = NULL;
3348     SV *filter_sub = NULL;
3349     SV *hook_sv = NULL;
3350     SV *encoding;
3351     OP *op;
3352
3353     sv = POPs;
3354     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3355         sv = new_version(sv);
3356         if (!sv_derived_from(PL_patchlevel, "version"))
3357             upg_version(PL_patchlevel, TRUE);
3358         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3359             if ( vcmp(sv,PL_patchlevel) <= 0 )
3360                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3361                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3362         }
3363         else {
3364             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3365                 I32 first = 0;
3366                 AV *lav;
3367                 SV * const req = SvRV(sv);
3368                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3369
3370                 /* get the left hand term */
3371                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3372
3373                 first  = SvIV(*av_fetch(lav,0,0));
3374                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3375                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3376                     || av_len(lav) > 1               /* FP with > 3 digits */
3377                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3378                    ) {
3379                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3380                         "%"SVf", stopped", SVfARG(vnormal(req)),
3381                         SVfARG(vnormal(PL_patchlevel)));
3382                 }
3383                 else { /* probably 'use 5.10' or 'use 5.8' */
3384                     SV *hintsv;
3385                     I32 second = 0;
3386
3387                     if (av_len(lav)>=1)
3388                         second = SvIV(*av_fetch(lav,1,0));
3389
3390                     second /= second >= 600  ? 100 : 10;
3391                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3392                                            (int)first, (int)second);
3393                     upg_version(hintsv, TRUE);
3394
3395                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3396                         "--this is only %"SVf", stopped",
3397                         SVfARG(vnormal(req)),
3398                         SVfARG(vnormal(sv_2mortal(hintsv))),
3399                         SVfARG(vnormal(PL_patchlevel)));
3400                 }
3401             }
3402         }
3403
3404         /* We do this only with "use", not "require" or "no". */
3405         if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3406             /* If we request a version >= 5.9.5, load feature.pm with the
3407              * feature bundle that corresponds to the required version. */
3408             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3409                 SV *const importsv = vnormal(sv);
3410                 *SvPVX_mutable(importsv) = ':';
3411                 ENTER_with_name("load_feature");
3412                 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3413                 LEAVE_with_name("load_feature");
3414             }
3415             /* If a version >= 5.11.0 is requested, strictures are on by default! */
3416             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3417                 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3418             }
3419         }
3420
3421         RETPUSHYES;
3422     }
3423     name = SvPV_const(sv, len);
3424     if (!(name && len > 0 && *name))
3425         DIE(aTHX_ "Null filename used");
3426     TAINT_PROPER("require");
3427
3428
3429 #ifdef VMS
3430     /* The key in the %ENV hash is in the syntax of file passed as the argument
3431      * usually this is in UNIX format, but sometimes in VMS format, which
3432      * can result in a module being pulled in more than once.
3433      * To prevent this, the key must be stored in UNIX format if the VMS
3434      * name can be translated to UNIX.
3435      */
3436     if ((unixname = tounixspec(name, NULL)) != NULL) {
3437         unixlen = strlen(unixname);
3438         vms_unixname = 1;
3439     }
3440     else
3441 #endif
3442     {
3443         /* if not VMS or VMS name can not be translated to UNIX, pass it
3444          * through.
3445          */
3446         unixname = (char *) name;
3447         unixlen = len;
3448     }
3449     if (PL_op->op_type == OP_REQUIRE) {
3450         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3451                                           unixname, unixlen, 0);
3452         if ( svp ) {
3453             if (*svp != &PL_sv_undef)
3454                 RETPUSHYES;
3455             else
3456                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3457                             "Compilation failed in require", unixname);
3458         }
3459     }
3460
3461     /* prepare to compile file */
3462
3463     if (path_is_absolute(name)) {
3464         tryname = name;
3465         tryrsfp = doopen_pm(name, len);
3466     }
3467     if (!tryrsfp) {
3468         AV * const ar = GvAVn(PL_incgv);
3469         I32 i;
3470 #ifdef VMS
3471         if (vms_unixname)
3472 #endif
3473         {
3474             namesv = newSV_type(SVt_PV);
3475             for (i = 0; i <= AvFILL(ar); i++) {
3476                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3477
3478                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3479                     mg_get(dirsv);
3480                 if (SvROK(dirsv)) {
3481                     int count;
3482                     SV **svp;
3483                     SV *loader = dirsv;
3484
3485                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3486                         && !sv_isobject(loader))
3487                     {
3488                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3489                     }
3490
3491                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3492                                    PTR2UV(SvRV(dirsv)), name);
3493                     tryname = SvPVX_const(namesv);
3494                     tryrsfp = NULL;
3495
3496                     ENTER_with_name("call_INC");
3497                     SAVETMPS;
3498                     EXTEND(SP, 2);
3499
3500                     PUSHMARK(SP);
3501                     PUSHs(dirsv);
3502                     PUSHs(sv);
3503                     PUTBACK;
3504                     if (sv_isobject(loader))
3505                         count = call_method("INC", G_ARRAY);
3506                     else
3507                         count = call_sv(loader, G_ARRAY);
3508                     SPAGAIN;
3509
3510                     if (count > 0) {
3511                         int i = 0;
3512                         SV *arg;
3513
3514                         SP -= count - 1;
3515                         arg = SP[i++];
3516
3517                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3518                             && !isGV_with_GP(SvRV(arg))) {
3519                             filter_cache = SvRV(arg);
3520                             SvREFCNT_inc_simple_void_NN(filter_cache);
3521
3522                             if (i < count) {
3523                                 arg = SP[i++];
3524                             }
3525                         }
3526
3527                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3528                             arg = SvRV(arg);
3529                         }
3530
3531                         if (isGV_with_GP(arg)) {
3532                             IO * const io = GvIO((const GV *)arg);
3533
3534                             ++filter_has_file;
3535
3536                             if (io) {
3537                                 tryrsfp = IoIFP(io);
3538                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3539                                     PerlIO_close(IoOFP(io));
3540                                 }
3541                                 IoIFP(io) = NULL;
3542                                 IoOFP(io) = NULL;
3543                             }
3544
3545                             if (i < count) {
3546                                 arg = SP[i++];
3547                             }
3548                         }
3549
3550                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3551                             filter_sub = arg;
3552                             SvREFCNT_inc_simple_void_NN(filter_sub);
3553
3554                             if (i < count) {
3555                                 filter_state = SP[i];
3556                                 SvREFCNT_inc_simple_void(filter_state);
3557                             }
3558                         }
3559
3560                         if (!tryrsfp && (filter_cache || filter_sub)) {
3561                             tryrsfp = PerlIO_open(BIT_BUCKET,
3562                                                   PERL_SCRIPT_MODE);
3563                         }
3564                         SP--;
3565                     }
3566
3567                     PUTBACK;
3568                     FREETMPS;
3569                     LEAVE_with_name("call_INC");
3570
3571                     /* Adjust file name if the hook has set an %INC entry.
3572                        This needs to happen after the FREETMPS above.  */
3573                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3574                     if (svp)
3575                         tryname = SvPV_nolen_const(*svp);
3576
3577                     if (tryrsfp) {
3578                         hook_sv = dirsv;
3579                         break;
3580                     }
3581
3582                     filter_has_file = 0;
3583                     if (filter_cache) {
3584                         SvREFCNT_dec(filter_cache);
3585                         filter_cache = NULL;
3586                     }
3587                     if (filter_state) {
3588                         SvREFCNT_dec(filter_state);
3589                         filter_state = NULL;
3590                     }
3591                     if (filter_sub) {
3592                         SvREFCNT_dec(filter_sub);
3593                         filter_sub = NULL;
3594                     }
3595                 }
3596                 else {
3597                   if (!path_is_absolute(name)
3598                   ) {
3599                     const char *dir;
3600                     STRLEN dirlen;
3601
3602                     if (SvOK(dirsv)) {
3603                         dir = SvPV_const(dirsv, dirlen);
3604                     } else {
3605                         dir = "";
3606                         dirlen = 0;
3607                     }
3608
3609 #ifdef VMS
3610                     char *unixdir;
3611                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3612                         continue;
3613                     sv_setpv(namesv, unixdir);
3614                     sv_catpv(namesv, unixname);
3615 #else
3616 #  ifdef __SYMBIAN32__
3617                     if (PL_origfilename[0] &&
3618                         PL_origfilename[1] == ':' &&
3619                         !(dir[0] && dir[1] == ':'))
3620                         Perl_sv_setpvf(aTHX_ namesv,
3621                                        "%c:%s\\%s",
3622                                        PL_origfilename[0],
3623                                        dir, name);
3624                     else
3625                         Perl_sv_setpvf(aTHX_ namesv,
3626                                        "%s\\%s",
3627                                        dir, name);
3628 #  else
3629                     /* The equivalent of
3630                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3631                        but without the need to parse the format string, or
3632                        call strlen on either pointer, and with the correct
3633                        allocation up front.  */
3634                     {
3635                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3636
3637                         memcpy(tmp, dir, dirlen);
3638                         tmp +=dirlen;
3639                         *tmp++ = '/';
3640                         /* name came from an SV, so it will have a '\0' at the
3641                            end that we can copy as part of this memcpy().  */
3642                         memcpy(tmp, name, len + 1);
3643
3644                         SvCUR_set(namesv, dirlen + len + 1);
3645
3646                         /* Don't even actually have to turn SvPOK_on() as we
3647                            access it directly with SvPVX() below.  */
3648                     }
3649 #  endif
3650 #endif
3651                     TAINT_PROPER("require");
3652                     tryname = SvPVX_const(namesv);
3653                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3654                     if (tryrsfp) {
3655                         if (tryname[0] == '.' && tryname[1] == '/') {
3656                             ++tryname;
3657                             while (*++tryname == '/');
3658                         }
3659                         break;
3660                     }
3661                     else if (errno == EMFILE)
3662                         /* no point in trying other paths if out of handles */
3663                         break;
3664                   }
3665                 }
3666             }
3667         }
3668     }
3669     if (tryrsfp) {
3670         SAVECOPFILE_FREE(&PL_compiling);
3671         CopFILE_set(&PL_compiling, tryname);
3672     }
3673     SvREFCNT_dec(namesv);
3674     if (!tryrsfp) {
3675         if (PL_op->op_type == OP_REQUIRE) {
3676             if(errno == EMFILE) {
3677                 /* diag_listed_as: Can't locate %s */
3678                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3679             } else {
3680                 if (namesv) {                   /* did we lookup @INC? */
3681                     AV * const ar = GvAVn(PL_incgv);
3682                     I32 i;
3683                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3684                     for (i = 0; i <= AvFILL(ar); i++) {
3685                         sv_catpvs(inc, " ");
3686                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3687                     }
3688
3689                     /* diag_listed_as: Can't locate %s */
3690                     DIE(aTHX_
3691                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3692                         name,
3693                         (memEQ(name + len - 2, ".h", 3)
3694                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3695                         (memEQ(name + len - 3, ".ph", 4)
3696                          ? " (did you run h2ph?)" : ""),
3697                         inc
3698                         );
3699                 }
3700             }
3701             DIE(aTHX_ "Can't locate %s", name);
3702         }
3703
3704         RETPUSHUNDEF;
3705     }
3706     else
3707         SETERRNO(0, SS_NORMAL);
3708
3709     /* Assume success here to prevent recursive requirement. */
3710     /* name is never assigned to again, so len is still strlen(name)  */
3711     /* Check whether a hook in @INC has already filled %INC */
3712     if (!hook_sv) {
3713         (void)hv_store(GvHVn(PL_incgv),
3714                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3715     } else {
3716         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3717         if (!svp)
3718             (void)hv_store(GvHVn(PL_incgv),
3719                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3720     }
3721
3722     ENTER_with_name("eval");
3723     SAVETMPS;
3724     lex_start(NULL, tryrsfp, TRUE);
3725
3726     SAVEHINTS();
3727     PL_hints = 0;
3728     hv_clear(GvHV(PL_hintgv));
3729
3730     SAVECOMPILEWARNINGS();
3731     if (PL_dowarn & G_WARN_ALL_ON)
3732         PL_compiling.cop_warnings = pWARN_ALL ;
3733     else if (PL_dowarn & G_WARN_ALL_OFF)
3734         PL_compiling.cop_warnings = pWARN_NONE ;
3735     else
3736         PL_compiling.cop_warnings = pWARN_STD ;
3737
3738     if (filter_sub || filter_cache) {
3739         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3740            than hanging another SV from it. In turn, filter_add() optionally
3741            takes the SV to use as the filter (or creates a new SV if passed
3742            NULL), so simply pass in whatever value filter_cache has.  */
3743         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3744         IoLINES(datasv) = filter_has_file;
3745         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3746         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3747     }
3748
3749     /* switch to eval mode */
3750     PUSHBLOCK(cx, CXt_EVAL, SP);
3751     PUSHEVAL(cx, name);
3752     cx->blk_eval.retop = PL_op->op_next;
3753
3754     SAVECOPLINE(&PL_compiling);
3755     CopLINE_set(&PL_compiling, 0);
3756
3757     PUTBACK;
3758
3759     /* Store and reset encoding. */
3760     encoding = PL_encoding;
3761     PL_encoding = NULL;
3762
3763     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3764         op = DOCATCH(PL_eval_start);
3765     else
3766         op = PL_op->op_next;
3767
3768     /* Restore encoding. */
3769     PL_encoding = encoding;
3770
3771     return op;
3772 }
3773
3774 /* This is a op added to hold the hints hash for
3775    pp_entereval. The hash can be modified by the code
3776    being eval'ed, so we return a copy instead. */
3777
3778 PP(pp_hintseval)
3779 {
3780     dVAR;
3781     dSP;
3782     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3783     RETURN;
3784 }
3785
3786
3787 PP(pp_entereval)
3788 {
3789     dVAR; dSP;
3790     register PERL_CONTEXT *cx;
3791     SV *sv;
3792     const I32 gimme = GIMME_V;
3793     const U32 was = PL_breakable_sub_gen;
3794     char tbuf[TYPE_DIGITS(long) + 12];
3795     char *tmpbuf = tbuf;
3796     STRLEN len;
3797     CV* runcv;
3798     U32 seq;
3799     HV *saved_hh = NULL;
3800
3801     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3802         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3803     }
3804     sv = POPs;
3805     if (!SvPOK(sv)) {
3806         /* make sure we've got a plain PV (no overload etc) before testing
3807          * for taint. Making a copy here is probably overkill, but better
3808          * safe than sorry */
3809         STRLEN len;
3810         const char * const p = SvPV_const(sv, len);
3811
3812         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3813     }
3814
3815     TAINT_IF(SvTAINTED(sv));
3816     TAINT_PROPER("eval");
3817
3818     ENTER_with_name("eval");
3819     lex_start(sv, NULL, FALSE);
3820     SAVETMPS;
3821
3822     /* switch to eval mode */
3823
3824     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3825         SV * const temp_sv = sv_newmortal();
3826         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3827                        (unsigned long)++PL_evalseq,
3828                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3829         tmpbuf = SvPVX(temp_sv);
3830         len = SvCUR(temp_sv);
3831     }
3832     else
3833         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3834     SAVECOPFILE_FREE(&PL_compiling);
3835     CopFILE_set(&PL_compiling, tmpbuf+2);
3836     SAVECOPLINE(&PL_compiling);
3837     CopLINE_set(&PL_compiling, 1);
3838     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3839        deleting the eval's FILEGV from the stash before gv_check() runs
3840        (i.e. before run-time proper). To work around the coredump that
3841        ensues, we always turn GvMULTI_on for any globals that were
3842        introduced within evals. See force_ident(). GSAR 96-10-12 */
3843     SAVEHINTS();
3844     PL_hints = PL_op->op_targ;
3845     if (saved_hh) {
3846         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3847         SvREFCNT_dec(GvHV(PL_hintgv));
3848         GvHV(PL_hintgv) = saved_hh;
3849     }
3850     SAVECOMPILEWARNINGS();
3851     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3852     if (PL_compiling.cop_hints_hash) {
3853         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3854     }
3855     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3856         /* The label, if present, is the first entry on the chain. So rather
3857            than writing a blank label in front of it (which involves an
3858            allocation), just use the next entry in the chain.  */
3859         PL_compiling.cop_hints_hash
3860             = PL_curcop->cop_hints_hash->refcounted_he_next;
3861         /* Check the assumption that this removed the label.  */
3862         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3863     }
3864     else
3865         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3866     if (PL_compiling.cop_hints_hash) {
3867         HINTS_REFCNT_LOCK;
3868         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3869         HINTS_REFCNT_UNLOCK;
3870     }
3871     /* special case: an eval '' executed within the DB package gets lexically
3872      * placed in the first non-DB CV rather than the current CV - this
3873      * allows the debugger to execute code, find lexicals etc, in the
3874      * scope of the code being debugged. Passing &seq gets find_runcv
3875      * to do the dirty work for us */
3876     runcv = find_runcv(&seq);
3877
3878     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3879     PUSHEVAL(cx, 0);
3880     cx->blk_eval.retop = PL_op->op_next;
3881
3882     /* prepare to compile string */
3883
3884     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3885         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3886     PUTBACK;
3887
3888     if (doeval(gimme, NULL, runcv, seq)) {
3889         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3890             ? (PERLDB_LINE || PERLDB_SAVESRC)
3891             :  PERLDB_SAVESRC_NOSUBS) {
3892             /* Retain the filegv we created.  */
3893         } else {
3894             char *const safestr = savepvn(tmpbuf, len);
3895             SAVEDELETE(PL_defstash, safestr, len);
3896         }
3897         return DOCATCH(PL_eval_start);
3898     } else {
3899         /* We have already left the scope set up earler thanks to the LEAVE
3900            in doeval().  */
3901         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3902             ? (PERLDB_LINE || PERLDB_SAVESRC)
3903             :  PERLDB_SAVESRC_INVALID) {
3904             /* Retain the filegv we created.  */
3905         } else {
3906             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3907         }
3908         return PL_op->op_next;
3909     }
3910 }
3911
3912 PP(pp_leaveeval)
3913 {
3914     dVAR; dSP;
3915     register SV **mark;
3916     SV **newsp;
3917     PMOP *newpm;
3918     I32 gimme;
3919     register PERL_CONTEXT *cx;
3920     OP *retop;
3921     const U8 save_flags = PL_op -> op_flags;
3922     I32 optype;
3923     SV *namesv;
3924
3925     POPBLOCK(cx,newpm);
3926     POPEVAL(cx);
3927     namesv = cx->blk_eval.old_namesv;
3928     retop = cx->blk_eval.retop;
3929
3930     TAINT_NOT;
3931     if (gimme == G_VOID)
3932         MARK = newsp;
3933     else if (gimme == G_SCALAR) {
3934         MARK = newsp + 1;
3935         if (MARK <= SP) {
3936             if (SvFLAGS(TOPs) & SVs_TEMP)
3937                 *MARK = TOPs;
3938             else
3939                 *MARK = sv_mortalcopy(TOPs);
3940         }
3941         else {
3942             MEXTEND(mark,0);
3943             *MARK = &PL_sv_undef;
3944         }
3945         SP = MARK;
3946     }
3947     else {
3948         /* in case LEAVE wipes old return values */
3949         for (mark = newsp + 1; mark <= SP; mark++) {
3950             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3951                 *mark = sv_mortalcopy(*mark);
3952                 TAINT_NOT;      /* Each item is independent */
3953             }
3954         }
3955     }
3956     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3957
3958 #ifdef DEBUGGING
3959     assert(CvDEPTH(PL_compcv) == 1);
3960 #endif
3961     CvDEPTH(PL_compcv) = 0;
3962     lex_end();
3963
3964     if (optype == OP_REQUIRE &&
3965         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3966     {
3967         /* Unassume the success we assumed earlier. */
3968         (void)hv_delete(GvHVn(PL_incgv),
3969                         SvPVX_const(namesv), SvCUR(namesv),
3970                         G_DISCARD);
3971         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3972                                SVfARG(namesv));
3973         /* die_unwind() did LEAVE, or we won't be here */
3974     }
3975     else {
3976         LEAVE_with_name("eval");
3977         if (!(save_flags & OPf_SPECIAL)) {
3978             CLEAR_ERRSV();
3979         }
3980     }
3981
3982     RETURNOP(retop);
3983 }
3984
3985 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3986    close to the related Perl_create_eval_scope.  */
3987 void
3988 Perl_delete_eval_scope(pTHX)
3989 {
3990     SV **newsp;
3991     PMOP *newpm;
3992     I32 gimme;
3993     register PERL_CONTEXT *cx;
3994     I32 optype;
3995
3996     POPBLOCK(cx,newpm);
3997     POPEVAL(cx);
3998     PL_curpm = newpm;
3999     LEAVE_with_name("eval_scope");
4000     PERL_UNUSED_VAR(newsp);
4001     PERL_UNUSED_VAR(gimme);
4002     PERL_UNUSED_VAR(optype);
4003 }
4004
4005 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4006    also needed by Perl_fold_constants.  */
4007 PERL_CONTEXT *
4008 Perl_create_eval_scope(pTHX_ U32 flags)
4009 {
4010     PERL_CONTEXT *cx;
4011     const I32 gimme = GIMME_V;
4012
4013     ENTER_with_name("eval_scope");
4014     SAVETMPS;
4015
4016     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4017     PUSHEVAL(cx, 0);
4018
4019     PL_in_eval = EVAL_INEVAL;
4020     if (flags & G_KEEPERR)
4021         PL_in_eval |= EVAL_KEEPERR;
4022     else
4023         CLEAR_ERRSV();
4024     if (flags & G_FAKINGEVAL) {
4025         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4026     }
4027     return cx;
4028 }
4029
4030 PP(pp_entertry)
4031 {
4032     dVAR;
4033     PERL_CONTEXT * const cx = create_eval_scope(0);
4034     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4035     return DOCATCH(PL_op->op_next);
4036 }
4037
4038 PP(pp_leavetry)
4039 {
4040     dVAR; dSP;
4041     SV **newsp;
4042     PMOP *newpm;
4043     I32 gimme;
4044     register PERL_CONTEXT *cx;
4045     I32 optype;
4046
4047     POPBLOCK(cx,newpm);
4048     POPEVAL(cx);
4049     PERL_UNUSED_VAR(optype);
4050
4051     TAINT_NOT;
4052     if (gimme == G_VOID)
4053         SP = newsp;
4054     else if (gimme == G_SCALAR) {
4055         register SV **mark;
4056         MARK = newsp + 1;
4057         if (MARK <= SP) {
4058             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4059                 *MARK = TOPs;
4060             else
4061                 *MARK = sv_mortalcopy(TOPs);
4062         }
4063         else {
4064             MEXTEND(mark,0);
4065             *MARK = &PL_sv_undef;
4066         }
4067         SP = MARK;
4068     }
4069     else {
4070         /* in case LEAVE wipes old return values */
4071         register SV **mark;
4072         for (mark = newsp + 1; mark <= SP; mark++) {
4073             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4074                 *mark = sv_mortalcopy(*mark);
4075                 TAINT_NOT;      /* Each item is independent */
4076             }
4077         }
4078     }
4079     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4080
4081     LEAVE_with_name("eval_scope");
4082     CLEAR_ERRSV();
4083     RETURN;
4084 }
4085
4086 PP(pp_entergiven)
4087 {
4088     dVAR; dSP;
4089     register PERL_CONTEXT *cx;
4090     const I32 gimme = GIMME_V;
4091
4092     ENTER_with_name("given");
4093     SAVETMPS;
4094
4095     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4096
4097     PUSHBLOCK(cx, CXt_GIVEN, SP);
4098     PUSHGIVEN(cx);
4099
4100     RETURN;
4101 }
4102
4103 PP(pp_leavegiven)
4104 {
4105     dVAR; dSP;
4106     register PERL_CONTEXT *cx;
4107     I32 gimme;
4108     SV **newsp;
4109     PMOP *newpm;
4110     PERL_UNUSED_CONTEXT;
4111
4112     POPBLOCK(cx,newpm);
4113     assert(CxTYPE(cx) == CXt_GIVEN);
4114
4115     TAINT_NOT;
4116     if (gimme == G_VOID)
4117         SP = newsp;
4118     else if (gimme == G_SCALAR) {
4119         register SV **mark;
4120         MARK = newsp + 1;
4121         if (MARK <= SP) {
4122             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4123                 *MARK = TOPs;
4124             else
4125                 *MARK = sv_mortalcopy(TOPs);
4126         }
4127         else {
4128             MEXTEND(mark,0);
4129             *MARK = &PL_sv_undef;
4130         }
4131         SP = MARK;
4132     }
4133     else {
4134         /* in case LEAVE wipes old return values */
4135         register SV **mark;
4136         for (mark = newsp + 1; mark <= SP; mark++) {
4137             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4138                 *mark = sv_mortalcopy(*mark);
4139                 TAINT_NOT;      /* Each item is independent */
4140             }
4141         }
4142     }
4143     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4144
4145     LEAVE_with_name("given");
4146     RETURN;
4147 }
4148
4149 /* Helper routines used by pp_smartmatch */
4150 STATIC PMOP *
4151 S_make_matcher(pTHX_ REGEXP *re)
4152 {
4153     dVAR;
4154     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4155
4156     PERL_ARGS_ASSERT_MAKE_MATCHER;
4157
4158     PM_SETRE(matcher, ReREFCNT_inc(re));
4159
4160     SAVEFREEOP((OP *) matcher);
4161     ENTER_with_name("matcher"); SAVETMPS;
4162     SAVEOP();
4163     return matcher;
4164 }
4165
4166 STATIC bool
4167 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4168 {
4169     dVAR;
4170     dSP;
4171
4172     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4173
4174     PL_op = (OP *) matcher;
4175     XPUSHs(sv);
4176     PUTBACK;
4177     (void) pp_match();
4178     SPAGAIN;
4179     return (SvTRUEx(POPs));
4180 }
4181
4182 STATIC void
4183 S_destroy_matcher(pTHX_ PMOP *matcher)
4184 {
4185     dVAR;
4186
4187     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4188     PERL_UNUSED_ARG(matcher);
4189
4190     FREETMPS;
4191     LEAVE_with_name("matcher");
4192 }
4193
4194 /* Do a smart match */
4195 PP(pp_smartmatch)
4196 {
4197     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4198     return do_smartmatch(NULL, NULL);
4199 }
4200
4201 /* This version of do_smartmatch() implements the
4202  * table of smart matches that is found in perlsyn.
4203  */
4204 STATIC OP *
4205 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4206 {
4207     dVAR;
4208     dSP;
4209
4210     bool object_on_left = FALSE;
4211     SV *e = TOPs;       /* e is for 'expression' */
4212     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4213
4214     /* Take care only to invoke mg_get() once for each argument.
4215      * Currently we do this by copying the SV if it's magical. */
4216     if (d) {
4217         if (SvGMAGICAL(d))
4218             d = sv_mortalcopy(d);
4219     }
4220     else
4221         d = &PL_sv_undef;
4222
4223     assert(e);
4224     if (SvGMAGICAL(e))
4225         e = sv_mortalcopy(e);
4226
4227     /* First of all, handle overload magic of the rightmost argument */
4228     if (SvAMAGIC(e)) {
4229         SV * tmpsv;
4230         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4231         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4232
4233         tmpsv = amagic_call(d, e, smart_amg, 0);
4234         if (tmpsv) {
4235             SPAGAIN;
4236             (void)POPs;
4237             SETs(tmpsv);
4238             RETURN;
4239         }
4240         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4241     }
4242
4243     SP -= 2;    /* Pop the values */
4244
4245
4246     /* ~~ undef */
4247     if (!SvOK(e)) {
4248         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4249         if (SvOK(d))
4250             RETPUSHNO;
4251         else
4252             RETPUSHYES;
4253     }
4254
4255     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4256         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4257         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4258     }
4259     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4260         object_on_left = TRUE;
4261
4262     /* ~~ sub */
4263     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4264         I32 c;
4265         if (object_on_left) {
4266             goto sm_any_sub; /* Treat objects like scalars */
4267         }
4268         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4269             /* Test sub truth for each key */
4270             HE *he;
4271             bool andedresults = TRUE;
4272             HV *hv = (HV*) SvRV(d);
4273             I32 numkeys = hv_iterinit(hv);
4274             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4275             if (numkeys == 0)
4276                 RETPUSHYES;
4277             while ( (he = hv_iternext(hv)) ) {
4278                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4279                 ENTER_with_name("smartmatch_hash_key_test");
4280                 SAVETMPS;
4281                 PUSHMARK(SP);
4282                 PUSHs(hv_iterkeysv(he));
4283                 PUTBACK;
4284                 c = call_sv(e, G_SCALAR);
4285                 SPAGAIN;
4286                 if (c == 0)
4287                     andedresults = FALSE;
4288                 else
4289                     andedresults = SvTRUEx(POPs) && andedresults;
4290                 FREETMPS;
4291                 LEAVE_with_name("smartmatch_hash_key_test");
4292             }
4293             if (andedresults)
4294                 RETPUSHYES;
4295             else
4296                 RETPUSHNO;
4297         }
4298         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4299             /* Test sub truth for each element */
4300             I32 i;
4301             bool andedresults = TRUE;
4302             AV *av = (AV*) SvRV(d);
4303             const I32 len = av_len(av);
4304             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4305             if (len == -1)
4306                 RETPUSHYES;
4307             for (i = 0; i <= len; ++i) {
4308                 SV * const * const svp = av_fetch(av, i, FALSE);
4309                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4310                 ENTER_with_name("smartmatch_array_elem_test");
4311                 SAVETMPS;
4312                 PUSHMARK(SP);
4313                 if (svp)
4314                     PUSHs(*svp);
4315                 PUTBACK;
4316                 c = call_sv(e, G_SCALAR);
4317                 SPAGAIN;
4318                 if (c == 0)
4319                     andedresults = FALSE;
4320                 else
4321                     andedresults = SvTRUEx(POPs) && andedresults;
4322                 FREETMPS;
4323                 LEAVE_with_name("smartmatch_array_elem_test");
4324             }
4325             if (andedresults)
4326                 RETPUSHYES;
4327             else
4328                 RETPUSHNO;
4329         }
4330         else {
4331           sm_any_sub:
4332             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4333             ENTER_with_name("smartmatch_coderef");
4334             SAVETMPS;
4335             PUSHMARK(SP);
4336             PUSHs(d);
4337             PUTBACK;
4338             c = call_sv(e, G_SCALAR);
4339             SPAGAIN;
4340             if (c == 0)
4341                 PUSHs(&PL_sv_no);
4342             else if (SvTEMP(TOPs))
4343                 SvREFCNT_inc_void(TOPs);
4344             FREETMPS;
4345             LEAVE_with_name("smartmatch_coderef");
4346             RETURN;
4347         }
4348     }
4349     /* ~~ %hash */
4350     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4351         if (object_on_left) {
4352             goto sm_any_hash; /* Treat objects like scalars */
4353         }
4354         else if (!SvOK(d)) {
4355             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4356             RETPUSHNO;
4357         }
4358         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4359             /* Check that the key-sets are identical */
4360             HE *he;
4361             HV *other_hv = MUTABLE_HV(SvRV(d));
4362             bool tied = FALSE;
4363             bool other_tied = FALSE;
4364             U32 this_key_count  = 0,
4365                 other_key_count = 0;
4366             HV *hv = MUTABLE_HV(SvRV(e));
4367
4368             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4369             /* Tied hashes don't know how many keys they have. */
4370             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4371                 tied = TRUE;
4372             }
4373             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4374                 HV * const temp = other_hv;
4375                 other_hv = hv;
4376                 hv = temp;
4377                 tied = TRUE;
4378             }
4379             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4380                 other_tied = TRUE;
4381
4382             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4383                 RETPUSHNO;
4384
4385             /* The hashes have the same number of keys, so it suffices
4386                to check that one is a subset of the other. */
4387             (void) hv_iterinit(hv);
4388             while ( (he = hv_iternext(hv)) ) {
4389                 SV *key = hv_iterkeysv(he);
4390
4391                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4392                 ++ this_key_count;
4393
4394                 if(!hv_exists_ent(other_hv, key, 0)) {
4395                     (void) hv_iterinit(hv);     /* reset iterator */
4396                     RETPUSHNO;
4397                 }
4398             }
4399
4400             if (other_tied) {
4401                 (void) hv_iterinit(other_hv);
4402                 while ( hv_iternext(other_hv) )
4403                     ++other_key_count;
4404             }
4405             else
4406                 other_key_count = HvUSEDKEYS(other_hv);
4407
4408             if (this_key_count != other_key_count)
4409                 RETPUSHNO;
4410             else
4411                 RETPUSHYES;
4412         }
4413         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4414             AV * const other_av = MUTABLE_AV(SvRV(d));
4415             const I32 other_len = av_len(other_av) + 1;
4416             I32 i;
4417             HV *hv = MUTABLE_HV(SvRV(e));
4418
4419             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4420             for (i = 0; i < other_len; ++i) {
4421                 SV ** const svp = av_fetch(other_av, i, FALSE);
4422                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4423                 if (svp) {      /* ??? When can this not happen? */
4424                     if (hv_exists_ent(hv, *svp, 0))
4425                         RETPUSHYES;
4426                 }
4427             }
4428             RETPUSHNO;
4429         }
4430         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4431             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4432           sm_regex_hash:
4433             {
4434                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4435                 HE *he;
4436                 HV *hv = MUTABLE_HV(SvRV(e));
4437
4438                 (void) hv_iterinit(hv);
4439                 while ( (he = hv_iternext(hv)) ) {
4440                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4441                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4442                         (void) hv_iterinit(hv);
4443                         destroy_matcher(matcher);
4444                         RETPUSHYES;
4445                     }
4446                 }
4447                 destroy_matcher(matcher);
4448                 RETPUSHNO;
4449             }
4450         }
4451         else {
4452           sm_any_hash:
4453             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4454             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4455                 RETPUSHYES;
4456             else
4457                 RETPUSHNO;
4458         }
4459     }
4460     /* ~~ @array */
4461     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4462         if (object_on_left) {
4463             goto sm_any_array; /* Treat objects like scalars */
4464         }
4465         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4466             AV * const other_av = MUTABLE_AV(SvRV(e));
4467             const I32 other_len = av_len(other_av) + 1;
4468             I32 i;
4469
4470             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4471             for (i = 0; i < other_len; ++i) {
4472                 SV ** const svp = av_fetch(other_av, i, FALSE);
4473
4474                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4475                 if (svp) {      /* ??? When can this not happen? */
4476                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4477                         RETPUSHYES;
4478                 }
4479             }
4480             RETPUSHNO;
4481         }
4482         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4483             AV *other_av = MUTABLE_AV(SvRV(d));
4484             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4485             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4486                 RETPUSHNO;
4487             else {
4488                 I32 i;
4489                 const I32 other_len = av_len(other_av);
4490
4491                 if (NULL == seen_this) {
4492                     seen_this = newHV();
4493                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4494                 }
4495                 if (NULL == seen_other) {
4496                     seen_other = newHV();
4497                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4498  &n