pp_ctl.c

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