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