pp_ctl.c

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