pp_ctl.c

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