pp_ctl.c

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