pp_ctl.c

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