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; /* pp_entereval knows about this 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     STRLEN len;
3660     CV* runcv;
3661     U32 seq;
3662     HV *saved_hh = NULL;
3663
3664     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3665         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3666     }
3667     sv = POPs;
3668
3669     TAINT_IF(SvTAINTED(sv));
3670     TAINT_PROPER("eval");
3671
3672     ENTER;
3673     lex_start(sv, NULL, FALSE);
3674     SAVETMPS;
3675
3676     /* switch to eval mode */
3677
3678     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3679         SV * const temp_sv = sv_newmortal();
3680         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3681                        (unsigned long)++PL_evalseq,
3682                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3683         tmpbuf = SvPVX(temp_sv);
3684         len = SvCUR(temp_sv);
3685     }
3686     else
3687         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3688     SAVECOPFILE_FREE(&PL_compiling);
3689     CopFILE_set(&PL_compiling, tmpbuf+2);
3690     SAVECOPLINE(&PL_compiling);
3691     CopLINE_set(&PL_compiling, 1);
3692     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3693        deleting the eval's FILEGV from the stash before gv_check() runs
3694        (i.e. before run-time proper). To work around the coredump that
3695        ensues, we always turn GvMULTI_on for any globals that were
3696        introduced within evals. See force_ident(). GSAR 96-10-12 */
3697     SAVEHINTS();
3698     PL_hints = PL_op->op_targ;
3699     if (saved_hh)
3700         GvHV(PL_hintgv) = saved_hh;
3701     SAVECOMPILEWARNINGS();
3702     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3703     if (PL_compiling.cop_hints_hash) {
3704         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3705     }
3706     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3707     if (PL_compiling.cop_hints_hash) {
3708         HINTS_REFCNT_LOCK;
3709         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3710         HINTS_REFCNT_UNLOCK;
3711     }
3712     /* special case: an eval '' executed within the DB package gets lexically
3713      * placed in the first non-DB CV rather than the current CV - this
3714      * allows the debugger to execute code, find lexicals etc, in the
3715      * scope of the code being debugged. Passing &seq gets find_runcv
3716      * to do the dirty work for us */
3717     runcv = find_runcv(&seq);
3718
3719     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3720     PUSHEVAL(cx, 0);
3721     cx->blk_eval.retop = PL_op->op_next;
3722
3723     /* prepare to compile string */
3724
3725     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3726         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3727     PUTBACK;
3728
3729     if (doeval(gimme, NULL, runcv, seq)) {
3730         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3731             ? (PERLDB_LINE || PERLDB_SAVESRC)
3732             :  PERLDB_SAVESRC_NOSUBS) {
3733             /* Retain the filegv we created.  */
3734         } else {
3735             char *const safestr = savepvn(tmpbuf, len);
3736             SAVEDELETE(PL_defstash, safestr, len);
3737         }
3738         return DOCATCH(PL_eval_start);
3739     } else {
3740         /* We have already left the scope set up earler thanks to the LEAVE
3741            in doeval().  */
3742         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3743             ? (PERLDB_LINE || PERLDB_SAVESRC)
3744             :  PERLDB_SAVESRC_INVALID) {
3745             /* Retain the filegv we created.  */
3746         } else {
3747             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3748         }
3749         return PL_op->op_next;
3750     }
3751 }
3752
3753 PP(pp_leaveeval)
3754 {
3755     dVAR; dSP;
3756     register SV **mark;
3757     SV **newsp;
3758     PMOP *newpm;
3759     I32 gimme;
3760     register PERL_CONTEXT *cx;
3761     OP *retop;
3762     const U8 save_flags = PL_op -> op_flags;
3763     I32 optype;
3764
3765     POPBLOCK(cx,newpm);
3766     POPEVAL(cx);
3767     retop = cx->blk_eval.retop;
3768
3769     TAINT_NOT;
3770     if (gimme == G_VOID)
3771         MARK = newsp;
3772     else if (gimme == G_SCALAR) {
3773         MARK = newsp + 1;
3774         if (MARK <= SP) {
3775             if (SvFLAGS(TOPs) & SVs_TEMP)
3776                 *MARK = TOPs;
3777             else
3778                 *MARK = sv_mortalcopy(TOPs);
3779         }
3780         else {
3781             MEXTEND(mark,0);
3782             *MARK = &PL_sv_undef;
3783         }
3784         SP = MARK;
3785     }
3786     else {
3787         /* in case LEAVE wipes old return values */
3788         for (mark = newsp + 1; mark <= SP; mark++) {
3789             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3790                 *mark = sv_mortalcopy(*mark);
3791                 TAINT_NOT;      /* Each item is independent */
3792             }
3793         }
3794     }
3795     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3796
3797 #ifdef DEBUGGING
3798     assert(CvDEPTH(PL_compcv) == 1);
3799 #endif
3800     CvDEPTH(PL_compcv) = 0;
3801     lex_end();
3802
3803     if (optype == OP_REQUIRE &&
3804         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3805     {
3806         /* Unassume the success we assumed earlier. */
3807         SV * const nsv = cx->blk_eval.old_namesv;
3808         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3809         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3810         /* die_where() did LEAVE, or we won't be here */
3811     }
3812     else {
3813         LEAVE;
3814         if (!(save_flags & OPf_SPECIAL)) {
3815             CLEAR_ERRSV();
3816         }
3817     }
3818
3819     RETURNOP(retop);
3820 }
3821
3822 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3823    close to the related Perl_create_eval_scope.  */
3824 void
3825 Perl_delete_eval_scope(pTHX)
3826 {
3827     SV **newsp;
3828     PMOP *newpm;
3829     I32 gimme;
3830     register PERL_CONTEXT *cx;
3831     I32 optype;
3832
3833     POPBLOCK(cx,newpm);
3834     POPEVAL(cx);
3835     PL_curpm = newpm;
3836     LEAVE;
3837     PERL_UNUSED_VAR(newsp);
3838     PERL_UNUSED_VAR(gimme);
3839     PERL_UNUSED_VAR(optype);
3840 }
3841
3842 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3843    also needed by Perl_fold_constants.  */
3844 PERL_CONTEXT *
3845 Perl_create_eval_scope(pTHX_ U32 flags)
3846 {
3847     PERL_CONTEXT *cx;
3848     const I32 gimme = GIMME_V;
3849
3850     ENTER;
3851     SAVETMPS;
3852
3853     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3854     PUSHEVAL(cx, 0);
3855
3856     PL_in_eval = EVAL_INEVAL;
3857     if (flags & G_KEEPERR)
3858         PL_in_eval |= EVAL_KEEPERR;
3859     else
3860         CLEAR_ERRSV();
3861     if (flags & G_FAKINGEVAL) {
3862         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3863     }
3864     return cx;
3865 }
3866
3867 PP(pp_entertry)
3868 {
3869     dVAR;
3870     PERL_CONTEXT * const cx = create_eval_scope(0);
3871     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3872     return DOCATCH(PL_op->op_next);
3873 }
3874
3875 PP(pp_leavetry)
3876 {
3877     dVAR; dSP;
3878     SV **newsp;
3879     PMOP *newpm;
3880     I32 gimme;
3881     register PERL_CONTEXT *cx;
3882     I32 optype;
3883
3884     POPBLOCK(cx,newpm);
3885     POPEVAL(cx);
3886     PERL_UNUSED_VAR(optype);
3887
3888     TAINT_NOT;
3889     if (gimme == G_VOID)
3890         SP = newsp;
3891     else if (gimme == G_SCALAR) {
3892         register SV **mark;
3893         MARK = newsp + 1;
3894         if (MARK <= SP) {
3895             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3896                 *MARK = TOPs;
3897             else
3898                 *MARK = sv_mortalcopy(TOPs);
3899         }
3900         else {
3901             MEXTEND(mark,0);
3902             *MARK = &PL_sv_undef;
3903         }
3904         SP = MARK;
3905     }
3906     else {
3907         /* in case LEAVE wipes old return values */
3908         register SV **mark;
3909         for (mark = newsp + 1; mark <= SP; mark++) {
3910             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3911                 *mark = sv_mortalcopy(*mark);
3912                 TAINT_NOT;      /* Each item is independent */
3913             }
3914         }
3915     }
3916     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3917
3918     LEAVE;
3919     CLEAR_ERRSV();
3920     RETURN;
3921 }
3922
3923 PP(pp_entergiven)
3924 {
3925     dVAR; dSP;
3926     register PERL_CONTEXT *cx;
3927     const I32 gimme = GIMME_V;
3928
3929     ENTER;
3930     SAVETMPS;
3931
3932     if (PL_op->op_targ == 0) {
3933         SV ** const defsv_p = &GvSV(PL_defgv);
3934         *defsv_p = newSVsv(POPs);
3935         SAVECLEARSV(*defsv_p);
3936     }
3937     else
3938         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3939
3940     PUSHBLOCK(cx, CXt_GIVEN, SP);
3941     PUSHGIVEN(cx);
3942
3943     RETURN;
3944 }
3945
3946 PP(pp_leavegiven)
3947 {
3948     dVAR; dSP;
3949     register PERL_CONTEXT *cx;
3950     I32 gimme;
3951     SV **newsp;
3952     PMOP *newpm;
3953     PERL_UNUSED_CONTEXT;
3954
3955     POPBLOCK(cx,newpm);
3956     assert(CxTYPE(cx) == CXt_GIVEN);
3957
3958     SP = newsp;
3959     PUTBACK;
3960
3961     PL_curpm = newpm;   /* pop $1 et al */
3962
3963     LEAVE;
3964
3965     return NORMAL;
3966 }
3967
3968 /* Helper routines used by pp_smartmatch */
3969 STATIC PMOP *
3970 S_make_matcher(pTHX_ REGEXP *re)
3971 {
3972     dVAR;
3973     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3974
3975     PERL_ARGS_ASSERT_MAKE_MATCHER;
3976
3977     PM_SETRE(matcher, ReREFCNT_inc(re));
3978
3979     SAVEFREEOP((OP *) matcher);
3980     ENTER; SAVETMPS;
3981     SAVEOP();
3982     return matcher;
3983 }
3984
3985 STATIC bool
3986 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3987 {
3988     dVAR;
3989     dSP;
3990
3991     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3992
3993     PL_op = (OP *) matcher;
3994     XPUSHs(sv);
3995     PUTBACK;
3996     (void) pp_match();
3997     SPAGAIN;
3998     return (SvTRUEx(POPs));
3999 }
4000
4001 STATIC void
4002 S_destroy_matcher(pTHX_ PMOP *matcher)
4003 {
4004     dVAR;
4005
4006     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4007     PERL_UNUSED_ARG(matcher);
4008
4009     FREETMPS;
4010     LEAVE;
4011 }
4012
4013 /* Do a smart match */
4014 PP(pp_smartmatch)
4015 {
4016     return do_smartmatch(NULL, NULL);
4017 }
4018
4019 /* This version of do_smartmatch() implements the
4020  * table of smart matches that is found in perlsyn.
4021  */
4022 STATIC OP *
4023 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4024 {
4025     dVAR;
4026     dSP;
4027
4028     SV *e = TOPs;       /* e is for 'expression' */
4029     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4030     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
4031     REGEXP *this_regex, *other_regex;
4032
4033 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4034
4035 #   define SM_REF(type) ( \
4036            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4037         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4038
4039 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
4040         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
4041             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
4042         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
4043             && NOT_EMPTY_PROTO(This) && (Other = d)))
4044
4045 #   define SM_REGEX ( \
4046            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
4047         && (this_regex = (REGEXP*) This)                                \
4048         && (Other = e))                                                 \
4049     ||                                                                  \
4050            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
4051         && (this_regex = (REGEXP*) This)                                \
4052         && (Other = d)) )
4053
4054
4055 #   define SM_OBJECT ( \
4056            (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))          \
4057     ||                                                                  \
4058            (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )        \
4059
4060 #   define SM_OTHER_REF(type) \
4061         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4062
4063 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
4064         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
4065         && (other_regex = (REGEXP*) SvRV(Other)))
4066
4067
4068 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4069         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4070
4071 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4072         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4073
4074     tryAMAGICbinSET(smart, 0);
4075
4076     SP -= 2;    /* Pop the values */
4077
4078     /* Take care only to invoke mg_get() once for each argument.
4079      * Currently we do this by copying the SV if it's magical. */
4080     if (d) {
4081         if (SvGMAGICAL(d))
4082             d = sv_mortalcopy(d);
4083     }
4084     else
4085         d = &PL_sv_undef;
4086
4087     assert(e);
4088     if (SvGMAGICAL(e))
4089         e = sv_mortalcopy(e);
4090
4091     if (SM_OBJECT)
4092         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4093
4094     if (SM_CV_NEP) {
4095         I32 c;
4096
4097         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4098         {
4099             if (This == SvRV(Other))
4100                 RETPUSHYES;
4101             else
4102                 RETPUSHNO;
4103         }
4104
4105         ENTER;
4106         SAVETMPS;
4107         PUSHMARK(SP);
4108         PUSHs(Other);
4109         PUTBACK;
4110         c = call_sv(This, G_SCALAR);
4111         SPAGAIN;
4112         if (c == 0)
4113             PUSHs(&PL_sv_no);
4114         else if (SvTEMP(TOPs))
4115             SvREFCNT_inc_void(TOPs);
4116         FREETMPS;
4117         LEAVE;
4118         RETURN;
4119     }
4120     else if (SM_REF(PVHV)) {
4121         if (SM_OTHER_REF(PVHV)) {
4122             /* Check that the key-sets are identical */
4123             HE *he;
4124             HV *other_hv = MUTABLE_HV(SvRV(Other));
4125             bool tied = FALSE;
4126             bool other_tied = FALSE;
4127             U32 this_key_count  = 0,
4128                 other_key_count = 0;
4129
4130             /* Tied hashes don't know how many keys they have. */
4131             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4132                 tied = TRUE;
4133             }
4134             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4135                 HV * const temp = other_hv;
4136                 other_hv = MUTABLE_HV(This);
4137                 This  = MUTABLE_SV(temp);
4138                 tied = TRUE;
4139             }
4140             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4141                 other_tied = TRUE;
4142
4143             if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4144                 RETPUSHNO;
4145
4146             /* The hashes have the same number of keys, so it suffices
4147                to check that one is a subset of the other. */
4148             (void) hv_iterinit(MUTABLE_HV(This));
4149             while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4150                 I32 key_len;
4151                 char * const key = hv_iterkey(he, &key_len);
4152
4153                 ++ this_key_count;
4154
4155                 if(!hv_exists(other_hv, key, key_len)) {
4156                     (void) hv_iterinit(MUTABLE_HV(This));       /* reset iterator */
4157                     RETPUSHNO;
4158                 }
4159             }
4160
4161             if (other_tied) {
4162                 (void) hv_iterinit(other_hv);
4163                 while ( hv_iternext(other_hv) )
4164                     ++other_key_count;
4165             }
4166             else
4167                 other_key_count = HvUSEDKEYS(other_hv);
4168
4169             if (this_key_count != other_key_count)
4170                 RETPUSHNO;
4171             else
4172                 RETPUSHYES;
4173         }
4174         else if (SM_OTHER_REF(PVAV)) {
4175             AV * const other_av = MUTABLE_AV(SvRV(Other));
4176             const I32 other_len = av_len(other_av) + 1;
4177             I32 i;
4178
4179             for (i = 0; i < other_len; ++i) {
4180                 SV ** const svp = av_fetch(other_av, i, FALSE);
4181                 char *key;
4182                 STRLEN key_len;
4183
4184                 if (svp) {      /* ??? When can this not happen? */
4185                     key = SvPV(*svp, key_len);
4186                     if (hv_exists(MUTABLE_HV(This), key, key_len))
4187                         RETPUSHYES;
4188                 }
4189             }
4190             RETPUSHNO;
4191         }
4192         else if (SM_OTHER_REGEX) {
4193             PMOP * const matcher = make_matcher(other_regex);
4194             HE *he;
4195
4196             (void) hv_iterinit(MUTABLE_HV(This));
4197             while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4198                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4199                     (void) hv_iterinit(MUTABLE_HV(This));
4200                     destroy_matcher(matcher);
4201                     RETPUSHYES;
4202                 }
4203             }
4204             destroy_matcher(matcher);
4205             RETPUSHNO;
4206         }
4207         else {
4208             if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4209                 RETPUSHYES;
4210             else
4211                 RETPUSHNO;
4212         }
4213     }
4214     else if (SM_REF(PVAV)) {
4215         if (SM_OTHER_REF(PVAV)) {
4216             AV *other_av = MUTABLE_AV(SvRV(Other));
4217             if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4218                 RETPUSHNO;
4219             else {
4220                 I32 i;
4221                 const I32 other_len = av_len(other_av);
4222
4223                 if (NULL == seen_this) {
4224                     seen_this = newHV();
4225                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4226                 }
4227                 if (NULL == seen_other) {
4228                     seen_this = newHV();
4229                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4230                 }
4231                 for(i = 0; i <= other_len; ++i) {
4232                     SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4233                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4234
4235                     if (!this_elem || !other_elem) {
4236                         if (this_elem || other_elem)
4237                             RETPUSHNO;
4238                     }
4239                     else if (SM_SEEN_THIS(*this_elem)
4240                          || SM_SEEN_OTHER(*other_elem))
4241                     {
4242                         if (*this_elem != *other_elem)
4243                             RETPUSHNO;
4244                     }
4245                     else {
4246                         (void)hv_store_ent(seen_this,
4247                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4248                                 &PL_sv_undef, 0);
4249                         (void)hv_store_ent(seen_other,
4250                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4251                                 &PL_sv_undef, 0);
4252                         PUSHs(*this_elem);
4253                         PUSHs(*other_elem);
4254
4255                         PUTBACK;
4256                         (void) do_smartmatch(seen_this, seen_other);
4257                         SPAGAIN;
4258
4259                         if (!SvTRUEx(POPs))
4260                             RETPUSHNO;
4261                     }
4262                 }
4263                 RETPUSHYES;
4264             }
4265         }
4266         else if (SM_OTHER_REGEX) {
4267             PMOP * const matcher = make_matcher(other_regex);
4268             const I32 this_len = av_len(MUTABLE_AV(This));
4269             I32 i;
4270
4271             for(i = 0; i <= this_len; ++i) {
4272                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4273                 if (svp && matcher_matches_sv(matcher, *svp)) {
4274                     destroy_matcher(matcher);
4275                     RETPUSHYES;
4276                 }
4277             }
4278             destroy_matcher(matcher);
4279             RETPUSHNO;
4280         }
4281         else if (SvIOK(Other) || SvNOK(Other)) {
4282             I32 i;
4283
4284             for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4285                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4286                 if (!svp)
4287                     continue;
4288
4289                 PUSHs(Other);
4290                 PUSHs(*svp);
4291                 PUTBACK;
4292                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4293                     (void) pp_i_eq();
4294                 else
4295                     (void) pp_eq();
4296                 SPAGAIN;
4297                 if (SvTRUEx(POPs))
4298                     RETPUSHYES;
4299             }
4300             RETPUSHNO;
4301         }
4302         else if (SvPOK(Other)) {
4303             const I32 this_len = av_len(MUTABLE_AV(This));
4304             I32 i;
4305
4306             for(i = 0; i <= this_len; ++i) {
4307                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4308                 if (!svp)
4309                     continue;
4310
4311                 PUSHs(Other);
4312                 PUSHs(*svp);
4313                 PUTBACK;
4314                 (void) pp_seq();
4315                 SPAGAIN;
4316                 if (SvTRUEx(POPs))
4317                     RETPUSHYES;
4318             }
4319             RETPUSHNO;
4320         }
4321     }
4322     else if (!SvOK(d) || !SvOK(e)) {
4323         if (!SvOK(d) && !SvOK(e))
4324             RETPUSHYES;
4325         else
4326             RETPUSHNO;
4327     }
4328     else if (SM_REGEX) {
4329         PMOP * const matcher = make_matcher(this_regex);
4330
4331         PUTBACK;
4332         PUSHs(matcher_matches_sv(matcher, Other)
4333             ? &PL_sv_yes
4334             : &PL_sv_no);
4335         destroy_matcher(matcher);
4336         RETURN;
4337     }
4338     else if (SM_REF(PVCV)) {
4339         I32 c;
4340         /* This must be a null-prototyped sub, because we
4341            already checked for the other kind. */
4342
4343         ENTER;
4344         SAVETMPS;
4345         PUSHMARK(SP);
4346         PUTBACK;
4347         c = call_sv(This, G_SCALAR);
4348         SPAGAIN;
4349         if (c == 0)
4350             PUSHs(&PL_sv_undef);
4351         else if (SvTEMP(TOPs))
4352             SvREFCNT_inc_void(TOPs);
4353
4354         if (SM_OTHER_REF(PVCV)) {
4355             /* This one has to be null-proto'd too.
4356                Call both of 'em, and compare the results */
4357             PUSHMARK(SP);
4358             c = call_sv(SvRV(Other), G_SCALAR);
4359             SPAGAIN;
4360             if (c == 0)
4361                 PUSHs(&PL_sv_undef);
4362             else if (SvTEMP(TOPs))
4363                 SvREFCNT_inc_void(TOPs);
4364             FREETMPS;
4365             LEAVE;
4366             PUTBACK;
4367             return pp_eq();
4368         }
4369
4370         FREETMPS;
4371         LEAVE;
4372         RETURN;
4373     }
4374     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4375          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4376     {
4377         if (SvPOK(Other) && !looks_like_number(Other)) {
4378             /* String comparison */
4379             PUSHs(d); PUSHs(e);
4380             PUTBACK;
4381             return pp_seq();
4382         }
4383         /* Otherwise, numeric comparison */
4384         PUSHs(d); PUSHs(e);
4385         PUTBACK;
4386         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4387             (void) pp_i_eq();
4388         else
4389             (void) pp_eq();
4390         SPAGAIN;
4391         if (SvTRUEx(POPs))
4392             RETPUSHYES;
4393         else
4394             RETPUSHNO;
4395     }
4396
4397     /* As a last resort, use string comparison */
4398     PUSHs(d); PUSHs(e);
4399     PUTBACK;
4400     return pp_seq();
4401 }
4402
4403 PP(pp_enterwhen)
4404 {
4405     dVAR; dSP;
4406     register PERL_CONTEXT *cx;
4407     const I32 gimme = GIMME_V;
4408
4409     /* This is essentially an optimization: if the match
4410        fails, we don't want to push a context and then
4411        pop it again right away, so we skip straight
4412        to the op that follows the leavewhen.
4413     */
4414     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4415         return cLOGOP->op_other->op_next;
4416
4417     ENTER;
4418     SAVETMPS;
4419
4420     PUSHBLOCK(cx, CXt_WHEN, SP);
4421     PUSHWHEN(cx);
4422
4423     RETURN;
4424 }
4425
4426 PP(pp_leavewhen)
4427 {
4428     dVAR; dSP;
4429     register PERL_CONTEXT *cx;
4430     I32 gimme;
4431     SV **newsp;
4432     PMOP *newpm;
4433
4434     POPBLOCK(cx,newpm);
4435     assert(CxTYPE(cx) == CXt_WHEN);
4436
4437     SP = newsp;
4438     PUTBACK;
4439
4440     PL_curpm = newpm;   /* pop $1 et al */
4441
4442     LEAVE;
4443     return NORMAL;
4444 }
4445
4446 PP(pp_continue)
4447 {
4448     dVAR;
4449     I32 cxix;
4450     register PERL_CONTEXT *cx;
4451     I32 inner;
4452
4453     cxix = dopoptowhen(cxstack_ix);
4454     if (cxix < 0)
4455         DIE(aTHX_ "Can't \"continue\" outside a when block");
4456     if (cxix < cxstack_ix)
4457         dounwind(cxix);
4458
4459     /* clear off anything above the scope we're re-entering */
4460     inner = PL_scopestack_ix;
4461     TOPBLOCK(cx);
4462     if (PL_scopestack_ix < inner)
4463         leave_scope(PL_scopestack[PL_scopestack_ix]);
4464     PL_curcop = cx->blk_oldcop;
4465     return cx->blk_givwhen.leave_op;
4466 }
4467
4468 PP(pp_break)
4469 {
4470     dVAR;
4471     I32 cxix;
4472     register PERL_CONTEXT *cx;
4473     I32 inner;
4474
4475     cxix = dopoptogiven(cxstack_ix);
4476     if (cxix < 0) {
4477         if (PL_op->op_flags & OPf_SPECIAL)
4478             DIE(aTHX_ "Can't use when() outside a topicalizer");
4479         else
4480             DIE(aTHX_ "Can't \"break\" outside a given block");
4481     }
4482     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4483         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4484
4485     if (cxix < cxstack_ix)
4486         dounwind(cxix);
4487
4488     /* clear off anything above the scope we're re-entering */
4489     inner = PL_scopestack_ix;
4490     TOPBLOCK(cx);
4491     if (PL_scopestack_ix < inner)
4492         leave_scope(PL_scopestack[PL_scopestack_ix]);
4493     PL_curcop = cx->blk_oldcop;
4494
4495     if (CxFOREACH(cx))
4496         return CX_LOOP_NEXTOP_GET(cx);
4497     else
4498         return cx->blk_givwhen.leave_op;
4499 }
4500
4501 STATIC OP *
4502 S_doparseform(pTHX_ SV *sv)
4503 {
4504     STRLEN len;
4505     register char *s = SvPV_force(sv, len);
4506     register char * const send = s + len;
4507     register char *base = NULL;
4508     register I32 skipspaces = 0;
4509     bool noblank   = FALSE;
4510     bool repeat    = FALSE;
4511     bool postspace = FALSE;
4512     U32 *fops;
4513     register U32 *fpc;
4514     U32 *linepc = NULL;
4515     register I32 arg;
4516     bool ischop;
4517     bool unchopnum = FALSE;
4518     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4519
4520     PERL_ARGS_ASSERT_DOPARSEFORM;
4521
4522     if (len == 0)
4523         Perl_croak(aTHX_ "Null picture in formline");
4524
4525     /* estimate the buffer size needed */
4526     for (base = s; s <= send; s++) {
4527         if (*s == '\n' || *s == '@' || *s == '^')
4528             maxops += 10;
4529     }
4530     s = base;
4531     base = NULL;
4532
4533     Newx(fops, maxops, U32);
4534     fpc = fops;
4535
4536     if (s < send) {
4537         linepc = fpc;
4538         *fpc++ = FF_LINEMARK;
4539         noblank = repeat = FALSE;
4540         base = s;
4541     }
4542
4543     while (s <= send) {
4544         switch (*s++) {
4545         default:
4546             skipspaces = 0;
4547             continue;
4548
4549         case '~':
4550             if (*s == '~') {
4551                 repeat = TRUE;
4552                 *s = ' ';
4553             }
4554             noblank = TRUE;
4555             s[-1] = ' ';
4556             /* FALL THROUGH */
4557         case ' ': case '\t':
4558             skipspaces++;
4559             continue;
4560         case 0:
4561             if (s < send) {
4562                 skipspaces = 0;
4563                 continue;
4564             } /* else FALL THROUGH */
4565         case '\n':
4566             arg = s - base;
4567             skipspaces++;
4568             arg -= skipspaces;
4569             if (arg) {
4570                 if (postspace)
4571                     *fpc++ = FF_SPACE;
4572                 *fpc++ = FF_LITERAL;
4573                 *fpc++ = (U16)arg;
4574             }
4575             postspace = FALSE;
4576             if (s <= send)
4577                 skipspaces--;
4578             if (skipspaces) {
4579                 *fpc++ = FF_SKIP;
4580                 *fpc++ = (U16)skipspaces;
4581             }
4582             skipspaces = 0;
4583             if (s <= send)
4584                 *fpc++ = FF_NEWLINE;
4585             if (noblank) {
4586                 *fpc++ = FF_BLANK;
4587                 if (repeat)
4588                     arg = fpc - linepc + 1;
4589                 else
4590                     arg = 0;
4591                 *fpc++ = (U16)arg;
4592             }
4593             if (s < send) {
4594                 linepc = fpc;
4595                 *fpc++ = FF_LINEMARK;
4596                 noblank = repeat = FALSE;
4597                 base = s;
4598             }
4599             else
4600                 s++;
4601             continue;
4602
4603         case '@':
4604         case '^':
4605             ischop = s[-1] == '^';
4606
4607             if (postspace) {
4608                 *fpc++ = FF_SPACE;
4609                 postspace = FALSE;
4610             }
4611             arg = (s - base) - 1;
4612             if (arg) {
4613                 *fpc++ = FF_LITERAL;
4614                 *fpc++ = (U16)arg;
4615             }
4616
4617             base = s - 1;
4618             *fpc++ = FF_FETCH;
4619             if (*s == '*') {
4620                 s++;
4621                 *fpc++ = 2;  /* skip the @* or ^* */
4622                 if (ischop) {
4623                     *fpc++ = FF_LINESNGL;
4624                     *fpc++ = FF_CHOP;
4625                 } else
4626                     *fpc++ = FF_LINEGLOB;
4627             }
4628             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4629                 arg = ischop ? 512 : 0;
4630                 base = s - 1;
4631                 while (*s == '#')
4632                     s++;
4633                 if (*s == '.') {
4634                     const char * const f = ++s;
4635                     while (*s == '#')
4636                         s++;
4637                     arg |= 256 + (s - f);
4638                 }
4639                 *fpc++ = s - base;              /* fieldsize for FETCH */
4640                 *fpc++ = FF_DECIMAL;
4641                 *fpc++ = (U16)arg;
4642                 unchopnum |= ! ischop;
4643             }
4644             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4645                 arg = ischop ? 512 : 0;
4646                 base = s - 1;
4647                 s++;                                /* skip the '0' first */
4648                 while (*s == '#')
4649                     s++;
4650                 if (*s == '.') {
4651                     const char * const f = ++s;
4652                     while (*s == '#')
4653                         s++;
4654                     arg |= 256 + (s - f);
4655                 }
4656                 *fpc++ = s - base;                /* fieldsize for FETCH */
4657                 *fpc++ = FF_0DECIMAL;
4658                 *fpc++ = (U16)arg;
4659                 unchopnum |= ! ischop;
4660             }
4661             else {
4662                 I32 prespace = 0;
4663                 bool ismore = FALSE;
4664
4665                 if (*s == '>') {
4666                     while (*++s == '>') ;
4667                     prespace = FF_SPACE;
4668                 }
4669                 else if (*s == '|') {
4670                     while (*++s == '|') ;
4671                     prespace = FF_HALFSPACE;
4672                     postspace = TRUE;
4673                 }
4674                 else {
4675                     if (*s == '<')
4676                         while (*++s == '<') ;
4677                     postspace = TRUE;
4678                 }
4679                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4680                     s += 3;
4681                     ismore = TRUE;
4682                 }
4683                 *fpc++ = s - base;              /* fieldsize for FETCH */
4684
4685                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4686
4687                 if (prespace)
4688                     *fpc++ = (U16)prespace;
4689                 *fpc++ = FF_ITEM;
4690                 if (ismore)
4691                     *fpc++ = FF_MORE;
4692                 if (ischop)
4693                     *fpc++ = FF_CHOP;
4694             }
4695             base = s;
4696             skipspaces = 0;
4697             continue;
4698         }
4699     }
4700     *fpc++ = FF_END;
4701
4702     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4703     arg = fpc - fops;
4704     { /* need to jump to the next word */
4705         int z;
4706         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4707         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4708         s = SvPVX(sv) + SvCUR(sv) + z;
4709     }
4710     Copy(fops, s, arg, U32);
4711     Safefree(fops);
4712     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4713     SvCOMPILED_on(sv);
4714
4715     if (unchopnum && repeat)
4716         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4717     return 0;
4718 }
4719
4720
4721 STATIC bool
4722 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4723 {
4724     /* Can value be printed in fldsize chars, using %*.*f ? */
4725     NV pwr = 1;
4726     NV eps = 0.5;
4727     bool res = FALSE;
4728     int intsize = fldsize - (value < 0 ? 1 : 0);
4729
4730     if (frcsize & 256)
4731         intsize--;
4732     frcsize &= 255;
4733     intsize -= frcsize;
4734
4735     while (intsize--) pwr *= 10.0;
4736     while (frcsize--) eps /= 10.0;
4737
4738     if( value >= 0 ){
4739         if (value + eps >= pwr)
4740             res = TRUE;
4741     } else {
4742         if (value - eps <= -pwr)
4743             res = TRUE;
4744     }
4745     return res;
4746 }
4747
4748 static I32
4749 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4750 {
4751     dVAR;
4752     SV * const datasv = FILTER_DATA(idx);
4753     const int filter_has_file = IoLINES(datasv);
4754     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4755     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4756     int status = 0;
4757     SV *upstream;
4758     STRLEN got_len;
4759     const char *got_p = NULL;
4760     const char *prune_from = NULL;
4761     bool read_from_cache = FALSE;
4762     STRLEN umaxlen;
4763
4764     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4765
4766     assert(maxlen >= 0);
4767     umaxlen = maxlen;
4768
4769     /* I was having segfault trouble under Linux 2.2.5 after a
4770        parse error occured.  (Had to hack around it with a test
4771        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4772        not sure where the trouble is yet.  XXX */
4773
4774     if (IoFMT_GV(datasv)) {
4775         SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4776         if (SvOK(cache)) {
4777             STRLEN cache_len;
4778             const char *cache_p = SvPV(cache, cache_len);
4779             STRLEN take = 0;
4780
4781             if (umaxlen) {
4782                 /* Running in block mode and we have some cached data already.
4783                  */
4784                 if (cache_len >= umaxlen) {
4785                     /* In fact, so much data we don't even need to call
4786                        filter_read.  */
4787                     take = umaxlen;
4788                 }
4789             } else {
4790                 const char *const first_nl =
4791                     (const char *)memchr(cache_p, '\n', cache_len);
4792                 if (first_nl) {
4793                     take = first_nl + 1 - cache_p;
4794                 }
4795             }
4796             if (take) {
4797                 sv_catpvn(buf_sv, cache_p, take);
4798                 sv_chop(cache, cache_p + take);
4799                 /* Definately not EOF  */
4800                 return 1;
4801             }
4802
4803             sv_catsv(buf_sv, cache);
4804             if (umaxlen) {
4805                 umaxlen -= cache_len;
4806             }
4807             SvOK_off(cache);
4808             read_from_cache = TRUE;
4809         }
4810     }
4811
4812     /* Filter API says that the filter appends to the contents of the buffer.
4813        Usually the buffer is "", so the details don't matter. But if it's not,
4814        then clearly what it contains is already filtered by this filter, so we
4815        don't want to pass it in a second time.
4816        I'm going to use a mortal in case the upstream filter croaks.  */
4817     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4818         ? sv_newmortal() : buf_sv;
4819     SvUPGRADE(upstream, SVt_PV);
4820
4821     if (filter_has_file) {
4822         status = FILTER_READ(idx+1, upstream, 0);
4823     }
4824
4825     if (filter_sub && status >= 0) {
4826         dSP;
4827         int count;
4828
4829         ENTER;
4830         SAVE_DEFSV;
4831         SAVETMPS;
4832         EXTEND(SP, 2);
4833
4834         DEFSV_set(upstream);
4835         PUSHMARK(SP);
4836         mPUSHi(0);
4837         if (filter_state) {
4838             PUSHs(filter_state);
4839         }
4840         PUTBACK;
4841         count = call_sv(filter_sub, G_SCALAR);
4842         SPAGAIN;
4843
4844         if (count > 0) {
4845             SV *out = POPs;
4846             if (SvOK(out)) {
4847                 status = SvIV(out);
4848             }
4849         }
4850
4851         PUTBACK;
4852         FREETMPS;
4853         LEAVE;
4854     }
4855
4856     if(SvOK(upstream)) {
4857         got_p = SvPV(upstream, got_len);
4858         if (umaxlen) {
4859             if (got_len > umaxlen) {
4860                 prune_from = got_p + umaxlen;
4861             }
4862         } else {
4863             const char *const first_nl =
4864                 (const char *)memchr(got_p, '\n', got_len);
4865             if (first_nl && first_nl + 1 < got_p + got_len) {
4866                 /* There's a second line here... */
4867                 prune_from = first_nl + 1;
4868             }
4869         }
4870     }
4871     if (prune_from) {
4872         /* Oh. Too long. Stuff some in our cache.  */
4873         STRLEN cached_len = got_p + got_len - prune_from;
4874         SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4875
4876         if (!cache) {
4877             IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4878         } else if (SvOK(cache)) {
4879             /* Cache should be empty.  */
4880             assert(!SvCUR(cache));
4881         }
4882
4883         sv_setpvn(cache, prune_from, cached_len);
4884         /* If you ask for block mode, you may well split UTF-8 characters.
4885            "If it breaks, you get to keep both parts"
4886            (Your code is broken if you  don't put them back together again
4887            before something notices.) */
4888         if (SvUTF8(upstream)) {
4889             SvUTF8_on(cache);
4890         }
4891         SvCUR_set(upstream, got_len - cached_len);
4892         /* Can't yet be EOF  */
4893         if (status == 0)
4894             status = 1;
4895     }
4896
4897     /* If they are at EOF but buf_sv has something in it, then they may never
4898        have touched the SV upstream, so it may be undefined.  If we naively
4899        concatenate it then we get a warning about use of uninitialised value.
4900     */
4901     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4902         sv_catsv(buf_sv, upstream);
4903     }
4904
4905     if (status <= 0) {
4906         IoLINES(datasv) = 0;
4907         SvREFCNT_dec(IoFMT_GV(datasv));
4908         if (filter_state) {
4909             SvREFCNT_dec(filter_state);
4910             IoTOP_GV(datasv) = NULL;
4911         }
4912         if (filter_sub) {
4913             SvREFCNT_dec(filter_sub);
4914             IoBOTTOM_GV(datasv) = NULL;
4915         }
4916         filter_del(S_run_user_filter);
4917     }
4918     if (status == 0 && read_from_cache) {
4919         /* If we read some data from the cache (and by getting here it implies
4920            that we emptied the cache) then we aren't yet at EOF, and mustn't
4921            report that to our caller.  */
4922         return 1;
4923     }
4924     return status;
4925 }
4926
4927 /* perhaps someone can come up with a better name for
4928    this?  it is not really "absolute", per se ... */
4929 static bool
4930 S_path_is_absolute(const char *name)
4931 {
4932     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4933
4934     if (PERL_FILE_IS_ABSOLUTE(name)
4935 #ifdef MACOS_TRADITIONAL
4936         || (*name == ':')
4937 #else
4938         || (*name == '.' && (name[1] == '/' ||
4939                              (name[1] == '.' && name[2] == '/')))
4940 #endif
4941          )
4942     {
4943         return TRUE;
4944     }
4945     else
4946         return FALSE;
4947 }
4948
4949 /*
4950  * Local variables:
4951  * c-indentation-style: bsd
4952  * c-basic-offset: 4
4953  * indent-tabs-mode: t
4954  * End:
4955  *
4956  * ex: set ts=8 sts=4 sw=4 noet:
4957  */