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