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