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