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