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     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3007         SV **newsp;                     /* Used by POPBLOCK. */
3008         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3009         I32 optype = 0;                 /* Might be reset by POPEVAL. */
3010         const char *msg;
3011
3012         PL_op = saveop;
3013         if (PL_eval_root) {
3014             op_free(PL_eval_root);
3015             PL_eval_root = NULL;
3016         }
3017         SP = PL_stack_base + POPMARK;           /* pop original mark */
3018         if (!startop) {
3019             POPBLOCK(cx,PL_curpm);
3020             POPEVAL(cx);
3021         }
3022         lex_end();
3023         LEAVE;
3024
3025         msg = SvPVx_nolen_const(ERRSV);
3026         if (optype == OP_REQUIRE) {
3027             const SV * const nsv = cx->blk_eval.old_namesv;
3028             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3029                           &PL_sv_undef, 0);
3030             Perl_croak(aTHX_ "%sCompilation failed in require",
3031                        *msg ? msg : "Unknown error\n");
3032         }
3033         else if (startop) {
3034             POPBLOCK(cx,PL_curpm);
3035             POPEVAL(cx);
3036             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3037                        (*msg ? msg : "Unknown error\n"));
3038         }
3039         else {
3040             if (!*msg) {
3041                 sv_setpvs(ERRSV, "Compilation error");
3042             }
3043         }
3044         PERL_UNUSED_VAR(newsp);
3045         PUSHs(&PL_sv_undef);
3046         PUTBACK;
3047         return FALSE;
3048     }
3049     CopLINE_set(&PL_compiling, 0);
3050     if (startop) {
3051         *startop = PL_eval_root;
3052     } else
3053         SAVEFREEOP(PL_eval_root);
3054
3055     /* Set the context for this new optree.
3056      * If the last op is an OP_REQUIRE, force scalar context.
3057      * Otherwise, propagate the context from the eval(). */
3058     if (PL_eval_root->op_type == OP_LEAVEEVAL
3059             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3060             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3061             == OP_REQUIRE)
3062         scalar(PL_eval_root);
3063     else if ((gimme & G_WANT) == G_VOID)
3064         scalarvoid(PL_eval_root);
3065     else if ((gimme & G_WANT) == G_ARRAY)
3066         list(PL_eval_root);
3067     else
3068         scalar(PL_eval_root);
3069
3070     DEBUG_x(dump_eval());
3071
3072     /* Register with debugger: */
3073     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3074         CV * const cv = get_cv("DB::postponed", FALSE);
3075         if (cv) {
3076             dSP;
3077             PUSHMARK(SP);
3078             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3079             PUTBACK;
3080             call_sv((SV*)cv, G_DISCARD);
3081         }
3082     }
3083
3084     if (PL_unitcheckav)
3085         call_list(PL_scopestack_ix, PL_unitcheckav);
3086
3087     /* compiled okay, so do it */
3088
3089     CvDEPTH(PL_compcv) = 1;
3090     SP = PL_stack_base + POPMARK;               /* pop original mark */
3091     PL_op = saveop;                     /* The caller may need it. */
3092     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3093
3094     PUTBACK;
3095     return TRUE;
3096 }
3097
3098 STATIC PerlIO *
3099 S_check_type_and_open(pTHX_ const char *name)
3100 {
3101     Stat_t st;
3102     const int st_rc = PerlLIO_stat(name, &st);
3103
3104     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3105
3106     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3107         return NULL;
3108     }
3109
3110     return PerlIO_open(name, PERL_SCRIPT_MODE);
3111 }
3112
3113 #ifndef PERL_DISABLE_PMC
3114 STATIC PerlIO *
3115 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3116 {
3117     PerlIO *fp;
3118
3119     PERL_ARGS_ASSERT_DOOPEN_PM;
3120
3121     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3122         SV *const pmcsv = newSV(namelen + 2);
3123         char *const pmc = SvPVX(pmcsv);
3124         Stat_t pmcstat;
3125
3126         memcpy(pmc, name, namelen);
3127         pmc[namelen] = 'c';
3128         pmc[namelen + 1] = '\0';
3129
3130         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3131             fp = check_type_and_open(name);
3132         }
3133         else {
3134             fp = check_type_and_open(pmc);
3135         }
3136         SvREFCNT_dec(pmcsv);
3137     }
3138     else {
3139         fp = check_type_and_open(name);
3140     }
3141     return fp;
3142 }
3143 #else
3144 #  define doopen_pm(name, namelen) check_type_and_open(name)
3145 #endif /* !PERL_DISABLE_PMC */
3146
3147 PP(pp_require)
3148 {
3149     dVAR; dSP;
3150     register PERL_CONTEXT *cx;
3151     SV *sv;
3152     const char *name;
3153     STRLEN len;
3154     char * unixname;
3155     STRLEN unixlen;
3156 #ifdef VMS
3157     int vms_unixname = 0;
3158 #endif
3159     const char *tryname = NULL;
3160     SV *namesv = NULL;
3161     const I32 gimme = GIMME_V;
3162     int filter_has_file = 0;
3163     PerlIO *tryrsfp = NULL;
3164     SV *filter_cache = NULL;
3165     SV *filter_state = NULL;
3166     SV *filter_sub = NULL;
3167     SV *hook_sv = NULL;
3168     SV *encoding;
3169     OP *op;
3170
3171     sv = POPs;
3172     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3173         sv = new_version(sv);
3174         if (!sv_derived_from(PL_patchlevel, "version"))
3175             upg_version(PL_patchlevel, TRUE);
3176         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3177             if ( vcmp(sv,PL_patchlevel) <= 0 )
3178                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3179                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3180         }
3181         else {
3182             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3183                 I32 first = 0;
3184                 AV *lav;
3185                 SV * const req = SvRV(sv);
3186                 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3187
3188                 /* get the left hand term */
3189                 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3190
3191                 first  = SvIV(*av_fetch(lav,0,0));
3192                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3193                     || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3194                     || av_len(lav) > 1               /* FP with > 3 digits */
3195                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3196                    ) {
3197                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3198                         "%"SVf", stopped", SVfARG(vnormal(req)),
3199                         SVfARG(vnormal(PL_patchlevel)));
3200                 }
3201                 else { /* probably 'use 5.10' or 'use 5.8' */
3202                     SV * hintsv = newSV(0);
3203                     I32 second = 0;
3204
3205                     if (av_len(lav)>=1)
3206                         second = SvIV(*av_fetch(lav,1,0));
3207
3208                     second /= second >= 600  ? 100 : 10;
3209                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3210                         (int)first, (int)second,0);
3211                     upg_version(hintsv, TRUE);
3212
3213                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3214                         "--this is only %"SVf", stopped",
3215                         SVfARG(vnormal(req)),
3216                         SVfARG(vnormal(hintsv)),
3217                         SVfARG(vnormal(PL_patchlevel)));
3218                 }
3219             }
3220         }
3221
3222         /* We do this only with use, not require. */
3223         if (PL_compcv &&
3224           /* If we request a version >= 5.9.5, load feature.pm with the
3225            * feature bundle that corresponds to the required version. */
3226                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3227             SV *const importsv = vnormal(sv);
3228             *SvPVX_mutable(importsv) = ':';
3229             ENTER;
3230             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3231             LEAVE;
3232         }
3233
3234         RETPUSHYES;
3235     }
3236     name = SvPV_const(sv, len);
3237     if (!(name && len > 0 && *name))
3238         DIE(aTHX_ "Null filename used");
3239     TAINT_PROPER("require");
3240
3241
3242 #ifdef VMS
3243     /* The key in the %ENV hash is in the syntax of file passed as the argument
3244      * usually this is in UNIX format, but sometimes in VMS format, which
3245      * can result in a module being pulled in more than once.
3246      * To prevent this, the key must be stored in UNIX format if the VMS
3247      * name can be translated to UNIX.
3248      */
3249     if ((unixname = tounixspec(name, NULL)) != NULL) {
3250         unixlen = strlen(unixname);
3251         vms_unixname = 1;
3252     }
3253     else
3254 #endif
3255     {
3256         /* if not VMS or VMS name can not be translated to UNIX, pass it
3257          * through.
3258          */
3259         unixname = (char *) name;
3260         unixlen = len;
3261     }
3262     if (PL_op->op_type == OP_REQUIRE) {
3263         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3264                                           unixname, unixlen, 0);
3265         if ( svp ) {
3266             if (*svp != &PL_sv_undef)
3267                 RETPUSHYES;
3268             else
3269                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3270                             "Compilation failed in require", unixname);
3271         }
3272     }
3273
3274     /* prepare to compile file */
3275
3276     if (path_is_absolute(name)) {
3277         tryname = name;
3278         tryrsfp = doopen_pm(name, len);
3279     }
3280 #ifdef MACOS_TRADITIONAL
3281     if (!tryrsfp) {
3282         char newname[256];
3283
3284         MacPerl_CanonDir(name, newname, 1);
3285         if (path_is_absolute(newname)) {
3286             tryname = newname;
3287             tryrsfp = doopen_pm(newname, strlen(newname));
3288         }
3289     }
3290 #endif
3291     if (!tryrsfp) {
3292         AV * const ar = GvAVn(PL_incgv);
3293         I32 i;
3294 #ifdef VMS
3295         if (vms_unixname)
3296 #endif
3297         {
3298             namesv = newSV_type(SVt_PV);
3299             for (i = 0; i <= AvFILL(ar); i++) {
3300                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3301
3302                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3303                     mg_get(dirsv);
3304                 if (SvROK(dirsv)) {
3305                     int count;
3306                     SV **svp;
3307                     SV *loader = dirsv;
3308
3309                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3310                         && !sv_isobject(loader))
3311                     {
3312                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3313                     }
3314
3315                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3316                                    PTR2UV(SvRV(dirsv)), name);
3317                     tryname = SvPVX_const(namesv);
3318                     tryrsfp = NULL;
3319
3320                     ENTER;
3321                     SAVETMPS;
3322                     EXTEND(SP, 2);
3323
3324                     PUSHMARK(SP);
3325                     PUSHs(dirsv);
3326                     PUSHs(sv);
3327                     PUTBACK;
3328                     if (sv_isobject(loader))
3329                         count = call_method("INC", G_ARRAY);
3330                     else
3331                         count = call_sv(loader, G_ARRAY);
3332                     SPAGAIN;
3333
3334                     /* Adjust file name if the hook has set an %INC entry */
3335                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3336                     if (svp)
3337                         tryname = SvPVX_const(*svp);
3338
3339                     if (count > 0) {
3340                         int i = 0;
3341                         SV *arg;
3342
3343                         SP -= count - 1;
3344                         arg = SP[i++];
3345
3346                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3347                             && !isGV_with_GP(SvRV(arg))) {
3348                             filter_cache = SvRV(arg);
3349                             SvREFCNT_inc_simple_void_NN(filter_cache);
3350
3351                             if (i < count) {
3352                                 arg = SP[i++];
3353                             }
3354                         }
3355
3356                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3357                             arg = SvRV(arg);
3358                         }
3359
3360                         if (SvTYPE(arg) == SVt_PVGV) {
3361                             IO * const io = GvIO((GV *)arg);
3362
3363                             ++filter_has_file;
3364
3365                             if (io) {
3366                                 tryrsfp = IoIFP(io);
3367                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3368                                     PerlIO_close(IoOFP(io));
3369                                 }
3370                                 IoIFP(io) = NULL;
3371                                 IoOFP(io) = NULL;
3372                             }
3373
3374                             if (i < count) {
3375                                 arg = SP[i++];
3376                             }
3377                         }
3378
3379                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3380                             filter_sub = arg;
3381                             SvREFCNT_inc_simple_void_NN(filter_sub);
3382
3383                             if (i < count) {
3384                                 filter_state = SP[i];
3385                                 SvREFCNT_inc_simple_void(filter_state);
3386                             }
3387                         }
3388
3389                         if (!tryrsfp && (filter_cache || filter_sub)) {
3390                             tryrsfp = PerlIO_open(BIT_BUCKET,
3391                                                   PERL_SCRIPT_MODE);
3392                         }
3393                         SP--;
3394                     }
3395
3396                     PUTBACK;
3397                     FREETMPS;
3398                     LEAVE;
3399
3400                     if (tryrsfp) {
3401                         hook_sv = dirsv;
3402                         break;
3403                     }
3404
3405                     filter_has_file = 0;
3406                     if (filter_cache) {
3407                         SvREFCNT_dec(filter_cache);
3408                         filter_cache = NULL;
3409                     }
3410                     if (filter_state) {
3411                         SvREFCNT_dec(filter_state);
3412                         filter_state = NULL;
3413                     }
3414                     if (filter_sub) {
3415                         SvREFCNT_dec(filter_sub);
3416                         filter_sub = NULL;
3417                     }
3418                 }
3419                 else {
3420                   if (!path_is_absolute(name)
3421 #ifdef MACOS_TRADITIONAL
3422                         /* We consider paths of the form :a:b ambiguous and interpret them first
3423                            as global then as local
3424                         */
3425                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3426 #endif
3427                   ) {
3428                     const char *dir;
3429                     STRLEN dirlen;
3430
3431                     if (SvOK(dirsv)) {
3432                         dir = SvPV_const(dirsv, dirlen);
3433                     } else {
3434                         dir = "";
3435                         dirlen = 0;
3436                     }
3437
3438 #ifdef MACOS_TRADITIONAL
3439                     char buf1[256];
3440                     char buf2[256];
3441
3442                     MacPerl_CanonDir(name, buf2, 1);
3443                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3444 #else
3445 #  ifdef VMS
3446                     char *unixdir;
3447                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3448                         continue;
3449                     sv_setpv(namesv, unixdir);
3450                     sv_catpv(namesv, unixname);
3451 #  else
3452 #    ifdef __SYMBIAN32__
3453                     if (PL_origfilename[0] &&
3454                         PL_origfilename[1] == ':' &&
3455                         !(dir[0] && dir[1] == ':'))
3456                         Perl_sv_setpvf(aTHX_ namesv,
3457                                        "%c:%s\\%s",
3458                                        PL_origfilename[0],
3459                                        dir, name);
3460                     else
3461                         Perl_sv_setpvf(aTHX_ namesv,
3462                                        "%s\\%s",
3463                                        dir, name);
3464 #    else
3465                     /* The equivalent of
3466                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3467                        but without the need to parse the format string, or
3468                        call strlen on either pointer, and with the correct
3469                        allocation up front.  */
3470                     {
3471                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3472
3473                         memcpy(tmp, dir, dirlen);
3474                         tmp +=dirlen;
3475                         *tmp++ = '/';
3476                         /* name came from an SV, so it will have a '\0' at the
3477                            end that we can copy as part of this memcpy().  */
3478                         memcpy(tmp, name, len + 1);
3479
3480                         SvCUR_set(namesv, dirlen + len + 1);
3481
3482                         /* Don't even actually have to turn SvPOK_on() as we
3483                            access it directly with SvPVX() below.  */
3484                     }
3485 #    endif
3486 #  endif
3487 #endif
3488                     TAINT_PROPER("require");
3489                     tryname = SvPVX_const(namesv);
3490                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3491                     if (tryrsfp) {
3492                         if (tryname[0] == '.' && tryname[1] == '/')
3493                             tryname += 2;
3494                         break;
3495                     }
3496                     else if (errno == EMFILE)
3497                         /* no point in trying other paths if out of handles */
3498                         break;
3499                   }
3500                 }
3501             }
3502         }
3503     }
3504     SAVECOPFILE_FREE(&PL_compiling);
3505     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3506     SvREFCNT_dec(namesv);
3507     if (!tryrsfp) {
3508         if (PL_op->op_type == OP_REQUIRE) {
3509             const char *msgstr = name;
3510             if(errno == EMFILE) {
3511                 SV * const msg
3512                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3513                                                Strerror(errno)));
3514                 msgstr = SvPV_nolen_const(msg);
3515             } else {
3516                 if (namesv) {                   /* did we lookup @INC? */
3517                     AV * const ar = GvAVn(PL_incgv);
3518                     I32 i;
3519                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3520                         "%s in @INC%s%s (@INC contains:",
3521                         msgstr,
3522                         (instr(msgstr, ".h ")
3523                          ? " (change .h to .ph maybe?)" : ""),
3524                         (instr(msgstr, ".ph ")
3525                          ? " (did you run h2ph?)" : "")
3526                                                               ));
3527
3528                     for (i = 0; i <= AvFILL(ar); i++) {
3529                         sv_catpvs(msg, " ");
3530                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3531                     }
3532                     sv_catpvs(msg, ")");
3533                     msgstr = SvPV_nolen_const(msg);
3534                 }
3535             }
3536             DIE(aTHX_ "Can't locate %s", msgstr);
3537         }
3538
3539         RETPUSHUNDEF;
3540     }
3541     else
3542         SETERRNO(0, SS_NORMAL);
3543
3544     /* Assume success here to prevent recursive requirement. */
3545     /* name is never assigned to again, so len is still strlen(name)  */
3546     /* Check whether a hook in @INC has already filled %INC */
3547     if (!hook_sv) {
3548         (void)hv_store(GvHVn(PL_incgv),
3549                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3550     } else {
3551         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3552         if (!svp)
3553             (void)hv_store(GvHVn(PL_incgv),
3554                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3555     }
3556
3557     ENTER;
3558     SAVETMPS;
3559     lex_start(NULL, tryrsfp, TRUE);
3560
3561     SAVEHINTS();
3562     PL_hints = 0;
3563     if (PL_compiling.cop_hints_hash) {
3564         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3565         PL_compiling.cop_hints_hash = NULL;
3566     }
3567
3568     SAVECOMPILEWARNINGS();
3569     if (PL_dowarn & G_WARN_ALL_ON)
3570         PL_compiling.cop_warnings = pWARN_ALL ;
3571     else if (PL_dowarn & G_WARN_ALL_OFF)
3572         PL_compiling.cop_warnings = pWARN_NONE ;
3573     else
3574         PL_compiling.cop_warnings = pWARN_STD ;
3575
3576     if (filter_sub || filter_cache) {
3577         SV * const datasv = filter_add(S_run_user_filter, NULL);
3578         IoLINES(datasv) = filter_has_file;
3579         IoTOP_GV(datasv) = (GV *)filter_state;
3580         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3581         IoFMT_GV(datasv) = (GV *)filter_cache;
3582     }
3583
3584     /* switch to eval mode */
3585     PUSHBLOCK(cx, CXt_EVAL, SP);
3586     PUSHEVAL(cx, name);
3587     cx->blk_eval.retop = PL_op->op_next;
3588
3589     SAVECOPLINE(&PL_compiling);
3590     CopLINE_set(&PL_compiling, 0);
3591
3592     PUTBACK;
3593
3594     /* Store and reset encoding. */
3595     encoding = PL_encoding;
3596     PL_encoding = NULL;
3597
3598     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3599         op = DOCATCH(PL_eval_start);
3600     else
3601         op = PL_op->op_next;
3602
3603     /* Restore encoding. */
3604     PL_encoding = encoding;
3605
3606     return op;
3607 }
3608
3609 /* This is a op added to hold the hints hash for
3610    pp_entereval. The hash can be modified by the code
3611    being eval'ed, so we return a copy instead. */
3612
3613 PP(pp_hintseval)
3614 {
3615     dVAR;
3616     dSP;
3617     mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
3618     RETURN;
3619 }
3620
3621
3622 PP(pp_entereval)
3623 {
3624     dVAR; dSP;
3625     register PERL_CONTEXT *cx;
3626     SV *sv;
3627     const I32 gimme = GIMME_V;
3628     const I32 was = PL_sub_generation;
3629     char tbuf[TYPE_DIGITS(long) + 12];
3630     char *tmpbuf = tbuf;
3631     char *safestr;
3632     STRLEN len;
3633     bool ok;
3634     CV* runcv;
3635     U32 seq;
3636     HV *saved_hh = NULL;
3637     const char * const fakestr = "_<(eval )";
3638     const int fakelen = 9 + 1;
3639
3640     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3641         saved_hh = (HV*) SvREFCNT_inc(POPs);
3642     }
3643     sv = POPs;
3644
3645     TAINT_IF(SvTAINTED(sv));
3646     TAINT_PROPER("eval");
3647
3648     ENTER;
3649     lex_start(sv, NULL, FALSE);
3650     SAVETMPS;
3651
3652     /* switch to eval mode */
3653
3654     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3655         SV * const temp_sv = sv_newmortal();
3656         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3657                        (unsigned long)++PL_evalseq,
3658                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3659         tmpbuf = SvPVX(temp_sv);
3660         len = SvCUR(temp_sv);
3661     }
3662     else
3663         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3664     SAVECOPFILE_FREE(&PL_compiling);
3665     CopFILE_set(&PL_compiling, tmpbuf+2);
3666     SAVECOPLINE(&PL_compiling);
3667     CopLINE_set(&PL_compiling, 1);
3668     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3669        deleting the eval's FILEGV from the stash before gv_check() runs
3670        (i.e. before run-time proper). To work around the coredump that
3671        ensues, we always turn GvMULTI_on for any globals that were
3672        introduced within evals. See force_ident(). GSAR 96-10-12 */
3673     safestr = savepvn(tmpbuf, len);
3674     SAVEDELETE(PL_defstash, safestr, len);
3675     SAVEHINTS();
3676     PL_hints = PL_op->op_targ;
3677     if (saved_hh)
3678         GvHV(PL_hintgv) = saved_hh;
3679     SAVECOMPILEWARNINGS();
3680     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3681     if (PL_compiling.cop_hints_hash) {
3682         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3683     }
3684     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3685     if (PL_compiling.cop_hints_hash) {
3686         HINTS_REFCNT_LOCK;
3687         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3688         HINTS_REFCNT_UNLOCK;
3689     }
3690     /* special case: an eval '' executed within the DB package gets lexically
3691      * placed in the first non-DB CV rather than the current CV - this
3692      * allows the debugger to execute code, find lexicals etc, in the
3693      * scope of the code being debugged. Passing &seq gets find_runcv
3694      * to do the dirty work for us */
3695     runcv = find_runcv(&seq);
3696
3697     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3698     PUSHEVAL(cx, 0);
3699     cx->blk_eval.retop = PL_op->op_next;
3700
3701     /* prepare to compile string */
3702
3703     if (PERLDB_LINE && PL_curstash != PL_debstash)
3704         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3705     PUTBACK;
3706     ok = doeval(gimme, NULL, runcv, seq);
3707     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3708         && ok) {
3709         /* Copy in anything fake and short. */
3710         my_strlcpy(safestr, fakestr, fakelen);
3711     }
3712     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3713 }
3714
3715 PP(pp_leaveeval)
3716 {
3717     dVAR; dSP;
3718     register SV **mark;
3719     SV **newsp;
3720     PMOP *newpm;
3721     I32 gimme;
3722     register PERL_CONTEXT *cx;
3723     OP *retop;
3724     const U8 save_flags = PL_op -> op_flags;
3725     I32 optype;
3726
3727     POPBLOCK(cx,newpm);
3728     POPEVAL(cx);
3729     retop = cx->blk_eval.retop;
3730
3731     TAINT_NOT;
3732     if (gimme == G_VOID)
3733         MARK = newsp;
3734     else if (gimme == G_SCALAR) {
3735         MARK = newsp + 1;
3736         if (MARK <= SP) {
3737             if (SvFLAGS(TOPs) & SVs_TEMP)
3738                 *MARK = TOPs;
3739             else
3740                 *MARK = sv_mortalcopy(TOPs);
3741         }
3742         else {
3743             MEXTEND(mark,0);
3744             *MARK = &PL_sv_undef;
3745         }
3746         SP = MARK;
3747     }
3748     else {
3749         /* in case LEAVE wipes old return values */
3750         for (mark = newsp + 1; mark <= SP; mark++) {
3751             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3752                 *mark = sv_mortalcopy(*mark);
3753                 TAINT_NOT;      /* Each item is independent */
3754             }
3755         }
3756     }
3757     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3758
3759 #ifdef DEBUGGING
3760     assert(CvDEPTH(PL_compcv) == 1);
3761 #endif
3762     CvDEPTH(PL_compcv) = 0;
3763     lex_end();
3764
3765     if (optype == OP_REQUIRE &&
3766         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3767     {
3768         /* Unassume the success we assumed earlier. */
3769         SV * const nsv = cx->blk_eval.old_namesv;
3770         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3771         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3772         /* die_where() did LEAVE, or we won't be here */
3773     }
3774     else {
3775         LEAVE;
3776         if (!(save_flags & OPf_SPECIAL)) {
3777             CLEAR_ERRSV();
3778         }
3779     }
3780
3781     RETURNOP(retop);
3782 }
3783
3784 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3785    close to the related Perl_create_eval_scope.  */
3786 void
3787 Perl_delete_eval_scope(pTHX)
3788 {
3789     SV **newsp;
3790     PMOP *newpm;
3791     I32 gimme;
3792     register PERL_CONTEXT *cx;
3793     I32 optype;
3794
3795     POPBLOCK(cx,newpm);
3796     POPEVAL(cx);
3797     PL_curpm = newpm;
3798     LEAVE;
3799     PERL_UNUSED_VAR(newsp);
3800     PERL_UNUSED_VAR(gimme);
3801     PERL_UNUSED_VAR(optype);
3802 }
3803
3804 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3805    also needed by Perl_fold_constants.  */
3806 PERL_CONTEXT *
3807 Perl_create_eval_scope(pTHX_ U32 flags)
3808 {
3809     PERL_CONTEXT *cx;
3810     const I32 gimme = GIMME_V;
3811
3812     ENTER;
3813     SAVETMPS;
3814
3815     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3816     PUSHEVAL(cx, 0);
3817
3818     PL_in_eval = EVAL_INEVAL;
3819     if (flags & G_KEEPERR)
3820         PL_in_eval |= EVAL_KEEPERR;
3821     else
3822         CLEAR_ERRSV();
3823     if (flags & G_FAKINGEVAL) {
3824         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3825     }
3826     return cx;
3827 }
3828
3829 PP(pp_entertry)
3830 {
3831     dVAR;
3832     PERL_CONTEXT * const cx = create_eval_scope(0);
3833     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3834     return DOCATCH(PL_op->op_next);
3835 }
3836
3837 PP(pp_leavetry)
3838 {
3839     dVAR; dSP;
3840     SV **newsp;
3841     PMOP *newpm;
3842     I32 gimme;
3843     register PERL_CONTEXT *cx;
3844     I32 optype;
3845
3846     POPBLOCK(cx,newpm);
3847     POPEVAL(cx);
3848     PERL_UNUSED_VAR(optype);
3849
3850     TAINT_NOT;
3851     if (gimme == G_VOID)
3852         SP = newsp;
3853     else if (gimme == G_SCALAR) {
3854         register SV **mark;
3855         MARK = newsp + 1;
3856         if (MARK <= SP) {
3857             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3858                 *MARK = TOPs;
3859             else
3860                 *MARK = sv_mortalcopy(TOPs);
3861         }
3862         else {
3863             MEXTEND(mark,0);
3864             *MARK = &PL_sv_undef;
3865         }
3866         SP = MARK;
3867     }
3868     else {
3869         /* in case LEAVE wipes old return values */
3870         register SV **mark;
3871         for (mark = newsp + 1; mark <= SP; mark++) {
3872             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3873                 *mark = sv_mortalcopy(*mark);
3874                 TAINT_NOT;      /* Each item is independent */
3875             }
3876         }
3877     }
3878     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3879
3880     LEAVE;
3881     CLEAR_ERRSV();
3882     RETURN;
3883 }
3884
3885 PP(pp_entergiven)
3886 {
3887     dVAR; dSP;
3888     register PERL_CONTEXT *cx;
3889     const I32 gimme = GIMME_V;
3890
3891     ENTER;
3892     SAVETMPS;
3893
3894     if (PL_op->op_targ == 0) {
3895         SV ** const defsv_p = &GvSV(PL_defgv);
3896         *defsv_p = newSVsv(POPs);
3897         SAVECLEARSV(*defsv_p);
3898     }
3899     else
3900         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3901
3902     PUSHBLOCK(cx, CXt_GIVEN, SP);
3903     PUSHGIVEN(cx);
3904
3905     RETURN;
3906 }
3907
3908 PP(pp_leavegiven)
3909 {
3910     dVAR; dSP;
3911     register PERL_CONTEXT *cx;
3912     I32 gimme;
3913     SV **newsp;
3914     PMOP *newpm;
3915     PERL_UNUSED_CONTEXT;
3916
3917     POPBLOCK(cx,newpm);
3918     assert(CxTYPE(cx) == CXt_GIVEN);
3919
3920     SP = newsp;
3921     PUTBACK;
3922
3923     PL_curpm = newpm;   /* pop $1 et al */
3924
3925     LEAVE;
3926
3927     return NORMAL;
3928 }
3929
3930 /* Helper routines used by pp_smartmatch */
3931 STATIC PMOP *
3932 S_make_matcher(pTHX_ REGEXP *re)
3933 {
3934     dVAR;
3935     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3936
3937     PERL_ARGS_ASSERT_MAKE_MATCHER;
3938
3939     PM_SETRE(matcher, ReREFCNT_inc(re));
3940
3941     SAVEFREEOP((OP *) matcher);
3942     ENTER; SAVETMPS;
3943     SAVEOP();
3944     return matcher;
3945 }
3946
3947 STATIC bool
3948 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3949 {
3950     dVAR;
3951     dSP;
3952
3953     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3954
3955     PL_op = (OP *) matcher;
3956     XPUSHs(sv);
3957     PUTBACK;
3958     (void) pp_match();
3959     SPAGAIN;
3960     return (SvTRUEx(POPs));
3961 }
3962
3963 STATIC void
3964 S_destroy_matcher(pTHX_ PMOP *matcher)
3965 {
3966     dVAR;
3967
3968     PERL_ARGS_ASSERT_DESTROY_MATCHER;
3969     PERL_UNUSED_ARG(matcher);
3970
3971     FREETMPS;
3972     LEAVE;
3973 }
3974
3975 /* Do a smart match */
3976 PP(pp_smartmatch)
3977 {
3978     return do_smartmatch(NULL, NULL);
3979 }
3980
3981 /* This version of do_smartmatch() implements the
3982  * table of smart matches that is found in perlsyn.
3983  */
3984 STATIC OP *
3985 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3986 {
3987     dVAR;
3988     dSP;
3989
3990     SV *e = TOPs;       /* e is for 'expression' */
3991     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3992     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3993     REGEXP *this_regex, *other_regex;
3994
3995 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3996
3997 #   define SM_REF(type) ( \
3998            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3999         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4000
4001 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
4002         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
4003             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
4004         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
4005             && NOT_EMPTY_PROTO(This) && (Other = d)))
4006
4007 #   define SM_REGEX ( \
4008            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
4009         && (this_regex = (REGEXP*) This)                                \
4010         && (Other = e))                                                 \
4011     ||                                                                  \
4012            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
4013         && (this_regex = (REGEXP*) This)                                \
4014         && (Other = d)) )
4015
4016
4017 #   define SM_OBJECT ( \
4018            (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))          \
4019     ||                                                                  \
4020            (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )        \
4021
4022 #   define SM_OTHER_REF(type) \
4023         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4024
4025 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
4026         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
4027         && (other_regex = (REGEXP*) SvRV(Other)))
4028
4029
4030 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4031         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4032
4033 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4034         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4035
4036     tryAMAGICbinSET(smart, 0);
4037
4038     SP -= 2;    /* Pop the values */
4039
4040     /* Take care only to invoke mg_get() once for each argument.
4041      * Currently we do this by copying the SV if it's magical. */
4042     if (d) {
4043         if (SvGMAGICAL(d))
4044             d = sv_mortalcopy(d);
4045     }
4046     else
4047         d = &PL_sv_undef;
4048
4049     assert(e);
4050     if (SvGMAGICAL(e))
4051         e = sv_mortalcopy(e);
4052
4053     if (SM_OBJECT)
4054         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4055
4056     if (SM_CV_NEP) {
4057         I32 c;
4058
4059         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4060         {
4061             if (This == SvRV(Other))
4062                 RETPUSHYES;
4063             else
4064                 RETPUSHNO;
4065         }
4066
4067         ENTER;
4068         SAVETMPS;
4069         PUSHMARK(SP);
4070         PUSHs(Other);
4071         PUTBACK;
4072         c = call_sv(This, G_SCALAR);
4073         SPAGAIN;
4074         if (c == 0)
4075             PUSHs(&PL_sv_no);
4076         else if (SvTEMP(TOPs))
4077             SvREFCNT_inc_void(TOPs);
4078         FREETMPS;
4079         LEAVE;
4080         RETURN;
4081     }
4082     else if (SM_REF(PVHV)) {
4083         if (SM_OTHER_REF(PVHV)) {
4084             /* Check that the key-sets are identical */
4085             HE *he;
4086             HV *other_hv = (HV *) SvRV(Other);
4087             bool tied = FALSE;
4088             bool other_tied = FALSE;
4089             U32 this_key_count  = 0,
4090                 other_key_count = 0;
4091
4092             /* Tied hashes don't know how many keys they have. */
4093             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4094                 tied = TRUE;
4095             }
4096             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4097                 HV * const temp = other_hv;
4098                 other_hv = (HV *) This;
4099                 This  = (SV *) temp;
4100                 tied = TRUE;
4101             }
4102             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4103                 other_tied = TRUE;
4104
4105             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4106                 RETPUSHNO;
4107
4108             /* The hashes have the same number of keys, so it suffices
4109                to check that one is a subset of the other. */
4110             (void) hv_iterinit((HV *) This);
4111             while ( (he = hv_iternext((HV *) This)) ) {
4112                 I32 key_len;
4113                 char * const key = hv_iterkey(he, &key_len);
4114
4115                 ++ this_key_count;
4116
4117                 if(!hv_exists(other_hv, key, key_len)) {
4118                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4119                     RETPUSHNO;
4120                 }
4121             }
4122
4123             if (other_tied) {
4124                 (void) hv_iterinit(other_hv);
4125                 while ( hv_iternext(other_hv) )
4126                     ++other_key_count;
4127             }
4128             else
4129                 other_key_count = HvUSEDKEYS(other_hv);
4130
4131             if (this_key_count != other_key_count)
4132                 RETPUSHNO;
4133             else
4134                 RETPUSHYES;
4135         }
4136         else if (SM_OTHER_REF(PVAV)) {
4137             AV * const other_av = (AV *) SvRV(Other);
4138             const I32 other_len = av_len(other_av) + 1;
4139             I32 i;
4140
4141             for (i = 0; i < other_len; ++i) {
4142                 SV ** const svp = av_fetch(other_av, i, FALSE);
4143                 char *key;
4144                 STRLEN key_len;
4145
4146                 if (svp) {      /* ??? When can this not happen? */
4147                     key = SvPV(*svp, key_len);
4148                     if (hv_exists((HV *) This, key, key_len))
4149                         RETPUSHYES;
4150                 }
4151             }
4152             RETPUSHNO;
4153         }
4154         else if (SM_OTHER_REGEX) {
4155             PMOP * const matcher = make_matcher(other_regex);
4156             HE *he;
4157
4158             (void) hv_iterinit((HV *) This);
4159             while ( (he = hv_iternext((HV *) This)) ) {
4160                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4161                     (void) hv_iterinit((HV *) This);
4162                     destroy_matcher(matcher);
4163                     RETPUSHYES;
4164                 }
4165             }
4166             destroy_matcher(matcher);
4167             RETPUSHNO;
4168         }
4169         else {
4170             if (hv_exists_ent((HV *) This, Other, 0))
4171                 RETPUSHYES;
4172             else
4173                 RETPUSHNO;
4174         }
4175     }
4176     else if (SM_REF(PVAV)) {
4177         if (SM_OTHER_REF(PVAV)) {
4178             AV *other_av = (AV *) SvRV(Other);
4179             if (av_len((AV *) This) != av_len(other_av))
4180                 RETPUSHNO;
4181             else {
4182                 I32 i;
4183                 const I32 other_len = av_len(other_av);
4184
4185                 if (NULL == seen_this) {
4186                     seen_this = newHV();
4187                     (void) sv_2mortal((SV *) seen_this);
4188                 }
4189                 if (NULL == seen_other) {
4190                     seen_this = newHV();
4191                     (void) sv_2mortal((SV *) seen_other);
4192                 }
4193                 for(i = 0; i <= other_len; ++i) {
4194                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4195                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4196
4197                     if (!this_elem || !other_elem) {
4198                         if (this_elem || other_elem)
4199                             RETPUSHNO;
4200                     }
4201                     else if (SM_SEEN_THIS(*this_elem)
4202                          || SM_SEEN_OTHER(*other_elem))
4203                     {
4204                         if (*this_elem != *other_elem)
4205                             RETPUSHNO;
4206                     }
4207                     else {
4208                         (void)hv_store_ent(seen_this,
4209                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4210                                 &PL_sv_undef, 0);
4211                         (void)hv_store_ent(seen_other,
4212                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4213                                 &PL_sv_undef, 0);
4214                         PUSHs(*this_elem);
4215                         PUSHs(*other_elem);
4216
4217                         PUTBACK;
4218                         (void) do_smartmatch(seen_this, seen_other);
4219                         SPAGAIN;
4220
4221                         if (!SvTRUEx(POPs))
4222                             RETPUSHNO;
4223                     }
4224                 }
4225                 RETPUSHYES;
4226             }
4227         }
4228         else if (SM_OTHER_REGEX) {
4229             PMOP * const matcher = make_matcher(other_regex);
4230             const I32 this_len = av_len((AV *) This);
4231             I32 i;
4232
4233             for(i = 0; i <= this_len; ++i) {
4234                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4235                 if (svp && matcher_matches_sv(matcher, *svp)) {
4236                     destroy_matcher(matcher);
4237                     RETPUSHYES;
4238                 }
4239             }
4240             destroy_matcher(matcher);
4241             RETPUSHNO;
4242         }
4243         else if (SvIOK(Other) || SvNOK(Other)) {
4244             I32 i;
4245
4246             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4247                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4248                 if (!svp)
4249                     continue;
4250
4251                 PUSHs(Other);
4252                 PUSHs(*svp);
4253                 PUTBACK;
4254                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4255                     (void) pp_i_eq();
4256                 else
4257                     (void) pp_eq();
4258                 SPAGAIN;
4259                 if (SvTRUEx(POPs))
4260                     RETPUSHYES;
4261             }
4262             RETPUSHNO;
4263         }
4264         else if (SvPOK(Other)) {
4265             const I32 this_len = av_len((AV *) This);
4266             I32 i;
4267
4268             for(i = 0; i <= this_len; ++i) {
4269                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4270                 if (!svp)
4271                     continue;
4272
4273                 PUSHs(Other);
4274                 PUSHs(*svp);
4275                 PUTBACK;
4276                 (void) pp_seq();
4277                 SPAGAIN;
4278                 if (SvTRUEx(POPs))
4279                     RETPUSHYES;
4280             }
4281             RETPUSHNO;
4282         }
4283     }
4284     else if (!SvOK(d) || !SvOK(e)) {
4285         if (!SvOK(d) && !SvOK(e))
4286             RETPUSHYES;
4287         else
4288             RETPUSHNO;
4289     }
4290     else if (SM_REGEX) {
4291         PMOP * const matcher = make_matcher(this_regex);
4292
4293         PUTBACK;
4294         PUSHs(matcher_matches_sv(matcher, Other)
4295             ? &PL_sv_yes
4296             : &PL_sv_no);
4297         destroy_matcher(matcher);
4298         RETURN;
4299     }
4300     else if (SM_REF(PVCV)) {
4301         I32 c;
4302         /* This must be a null-prototyped sub, because we
4303            already checked for the other kind. */
4304
4305         ENTER;
4306         SAVETMPS;
4307         PUSHMARK(SP);
4308         PUTBACK;
4309         c = call_sv(This, G_SCALAR);
4310         SPAGAIN;
4311         if (c == 0)
4312             PUSHs(&PL_sv_undef);
4313         else if (SvTEMP(TOPs))
4314             SvREFCNT_inc_void(TOPs);
4315
4316         if (SM_OTHER_REF(PVCV)) {
4317             /* This one has to be null-proto'd too.
4318                Call both of 'em, and compare the results */
4319             PUSHMARK(SP);
4320             c = call_sv(SvRV(Other), G_SCALAR);
4321             SPAGAIN;
4322             if (c == 0)
4323                 PUSHs(&PL_sv_undef);
4324             else if (SvTEMP(TOPs))
4325                 SvREFCNT_inc_void(TOPs);
4326             FREETMPS;
4327             LEAVE;
4328             PUTBACK;
4329             return pp_eq();
4330         }
4331
4332         FREETMPS;
4333         LEAVE;
4334         RETURN;
4335     }
4336     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4337          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4338     {
4339         if (SvPOK(Other) && !looks_like_number(Other)) {
4340             /* String comparison */
4341             PUSHs(d); PUSHs(e);
4342             PUTBACK;
4343             return pp_seq();
4344         }
4345         /* Otherwise, numeric comparison */
4346         PUSHs(d); PUSHs(e);
4347         PUTBACK;
4348         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4349             (void) pp_i_eq();
4350         else
4351             (void) pp_eq();
4352         SPAGAIN;
4353         if (SvTRUEx(POPs))
4354             RETPUSHYES;
4355         else
4356             RETPUSHNO;
4357     }
4358
4359     /* As a last resort, use string comparison */
4360     PUSHs(d); PUSHs(e);
4361     PUTBACK;
4362     return pp_seq();
4363 }
4364
4365 PP(pp_enterwhen)
4366 {
4367     dVAR; dSP;
4368     register PERL_CONTEXT *cx;
4369     const I32 gimme = GIMME_V;
4370
4371     /* This is essentially an optimization: if the match
4372        fails, we don't want to push a context and then
4373        pop it again right away, so we skip straight
4374        to the op that follows the leavewhen.
4375     */
4376     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4377         return cLOGOP->op_other->op_next;
4378
4379     ENTER;
4380     SAVETMPS;
4381
4382     PUSHBLOCK(cx, CXt_WHEN, SP);
4383     PUSHWHEN(cx);
4384
4385     RETURN;
4386 }
4387
4388 PP(pp_leavewhen)
4389 {
4390     dVAR; dSP;
4391     register PERL_CONTEXT *cx;
4392     I32 gimme;
4393     SV **newsp;
4394     PMOP *newpm;
4395
4396     POPBLOCK(cx,newpm);
4397     assert(CxTYPE(cx) == CXt_WHEN);
4398
4399     SP = newsp;
4400     PUTBACK;
4401
4402     PL_curpm = newpm;   /* pop $1 et al */
4403
4404     LEAVE;
4405     return NORMAL;
4406 }
4407
4408 PP(pp_continue)
4409 {
4410     dVAR;
4411     I32 cxix;
4412     register PERL_CONTEXT *cx;
4413     I32 inner;
4414
4415     cxix = dopoptowhen(cxstack_ix);
4416     if (cxix < 0)
4417         DIE(aTHX_ "Can't \"continue\" outside a when block");
4418     if (cxix < cxstack_ix)
4419         dounwind(cxix);
4420
4421     /* clear off anything above the scope we're re-entering */
4422     inner = PL_scopestack_ix;
4423     TOPBLOCK(cx);
4424     if (PL_scopestack_ix < inner)
4425         leave_scope(PL_scopestack[PL_scopestack_ix]);
4426     PL_curcop = cx->blk_oldcop;
4427     return cx->blk_givwhen.leave_op;
4428 }
4429
4430 PP(pp_break)
4431 {
4432     dVAR;
4433     I32 cxix;
4434     register PERL_CONTEXT *cx;
4435     I32 inner;
4436
4437     cxix = dopoptogiven(cxstack_ix);
4438     if (cxix < 0) {
4439         if (PL_op->op_flags & OPf_SPECIAL)
4440             DIE(aTHX_ "Can't use when() outside a topicalizer");
4441         else
4442             DIE(aTHX_ "Can't \"break\" outside a given block");
4443     }
4444     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4445         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4446
4447     if (cxix < cxstack_ix)
4448         dounwind(cxix);
4449
4450     /* clear off anything above the scope we're re-entering */
4451     inner = PL_scopestack_ix;
4452     TOPBLOCK(cx);
4453     if (PL_scopestack_ix < inner)
4454         leave_scope(PL_scopestack[PL_scopestack_ix]);
4455     PL_curcop = cx->blk_oldcop;
4456
4457     if (CxFOREACH(cx))
4458         return CX_LOOP_NEXTOP_GET(cx);
4459     else
4460         return cx->blk_givwhen.leave_op;
4461 }
4462
4463 STATIC OP *
4464 S_doparseform(pTHX_ SV *sv)
4465 {
4466     STRLEN len;
4467     register char *s = SvPV_force(sv, len);
4468     register char * const send = s + len;
4469     register char *base = NULL;
4470     register I32 skipspaces = 0;
4471     bool noblank   = FALSE;
4472     bool repeat    = FALSE;
4473     bool postspace = FALSE;
4474     U32 *fops;
4475     register U32 *fpc;
4476     U32 *linepc = NULL;
4477     register I32 arg;
4478     bool ischop;
4479     bool unchopnum = FALSE;
4480     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4481
4482     PERL_ARGS_ASSERT_DOPARSEFORM;
4483
4484     if (len == 0)
4485         Perl_croak(aTHX_ "Null picture in formline");
4486
4487     /* estimate the buffer size needed */
4488     for (base = s; s <= send; s++) {
4489         if (*s == '\n' || *s == '@' || *s == '^')
4490             maxops += 10;
4491     }
4492     s = base;
4493     base = NULL;
4494
4495     Newx(fops, maxops, U32);
4496     fpc = fops;
4497
4498     if (s < send) {
4499         linepc = fpc;
4500         *fpc++ = FF_LINEMARK;
4501         noblank = repeat = FALSE;
4502         base = s;
4503     }
4504
4505     while (s <= send) {
4506         switch (*s++) {
4507         default:
4508             skipspaces = 0;
4509             continue;
4510
4511         case '~':
4512             if (*s == '~') {
4513                 repeat = TRUE;
4514                 *s = ' ';
4515             }
4516             noblank = TRUE;
4517             s[-1] = ' ';
4518             /* FALL THROUGH */
4519         case ' ': case '\t':
4520             skipspaces++;
4521             continue;
4522         case 0:
4523             if (s < send) {
4524                 skipspaces = 0;
4525                 continue;
4526             } /* else FALL THROUGH */
4527         case '\n':
4528             arg = s - base;
4529             skipspaces++;
4530             arg -= skipspaces;
4531             if (arg) {
4532                 if (postspace)
4533                     *fpc++ = FF_SPACE;
4534                 *fpc++ = FF_LITERAL;
4535                 *fpc++ = (U16)arg;
4536             }
4537             postspace = FALSE;
4538             if (s <= send)
4539                 skipspaces--;
4540             if (skipspaces) {
4541                 *fpc++ = FF_SKIP;
4542                 *fpc++ = (U16)skipspaces;
4543             }
4544             skipspaces = 0;
4545             if (s <= send)
4546                 *fpc++ = FF_NEWLINE;
4547             if (noblank) {
4548                 *fpc++ = FF_BLANK;
4549                 if (repeat)
4550                     arg = fpc - linepc + 1;
4551                 else
4552                     arg = 0;
4553                 *fpc++ = (U16)arg;
4554             }
4555             if (s < send) {
4556                 linepc = fpc;
4557                 *fpc++ = FF_LINEMARK;
4558                 noblank = repeat = FALSE;
4559                 base = s;
4560             }
4561             else
4562                 s++;
4563             continue;
4564
4565         case '@':
4566         case '^':
4567             ischop = s[-1] == '^';
4568
4569             if (postspace) {
4570                 *fpc++ = FF_SPACE;
4571                 postspace = FALSE;
4572             }
4573             arg = (s - base) - 1;
4574             if (arg) {
4575                 *fpc++ = FF_LITERAL;
4576                 *fpc++ = (U16)arg;
4577             }
4578
4579             base = s - 1;
4580             *fpc++ = FF_FETCH;
4581             if (*s == '*') {
4582                 s++;
4583                 *fpc++ = 2;  /* skip the @* or ^* */
4584                 if (ischop) {
4585                     *fpc++ = FF_LINESNGL;
4586                     *fpc++ = FF_CHOP;
4587                 } else
4588                     *fpc++ = FF_LINEGLOB;
4589             }
4590             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4591                 arg = ischop ? 512 : 0;
4592                 base = s - 1;
4593                 while (*s == '#')
4594                     s++;
4595                 if (*s == '.') {
4596                     const char * const f = ++s;
4597                     while (*s == '#')
4598                         s++;
4599                     arg |= 256 + (s - f);
4600                 }
4601                 *fpc++ = s - base;              /* fieldsize for FETCH */
4602                 *fpc++ = FF_DECIMAL;
4603                 *fpc++ = (U16)arg;
4604                 unchopnum |= ! ischop;
4605             }
4606             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4607                 arg = ischop ? 512 : 0;
4608                 base = s - 1;
4609                 s++;                                /* skip the '0' first */
4610                 while (*s == '#')
4611                     s++;
4612                 if (*s == '.') {
4613                     const char * const f = ++s;
4614                     while (*s == '#')
4615                         s++;
4616                     arg |= 256 + (s - f);
4617                 }
4618                 *fpc++ = s - base;                /* fieldsize for FETCH */
4619                 *fpc++ = FF_0DECIMAL;
4620                 *fpc++ = (U16)arg;
4621                 unchopnum |= ! ischop;
4622             }
4623             else {
4624                 I32 prespace = 0;
4625                 bool ismore = FALSE;
4626
4627                 if (*s == '>') {
4628                     while (*++s == '>') ;
4629                     prespace = FF_SPACE;
4630                 }
4631                 else if (*s == '|') {
4632                     while (*++s == '|') ;
4633                     prespace = FF_HALFSPACE;
4634                     postspace = TRUE;
4635                 }
4636                 else {
4637                     if (*s == '<')
4638                         while (*++s == '<') ;
4639                     postspace = TRUE;
4640                 }
4641                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4642                     s += 3;
4643                     ismore = TRUE;
4644                 }
4645                 *fpc++ = s - base;              /* fieldsize for FETCH */
4646
4647                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4648
4649                 if (prespace)
4650                     *fpc++ = (U16)prespace;
4651                 *fpc++ = FF_ITEM;
4652                 if (ismore)
4653                     *fpc++ = FF_MORE;
4654                 if (ischop)
4655                     *fpc++ = FF_CHOP;
4656             }
4657             base = s;
4658             skipspaces = 0;
4659             continue;
4660         }
4661     }
4662     *fpc++ = FF_END;
4663
4664     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4665     arg = fpc - fops;
4666     { /* need to jump to the next word */
4667         int z;
4668         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4669         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4670         s = SvPVX(sv) + SvCUR(sv) + z;
4671     }
4672     Copy(fops, s, arg, U32);
4673     Safefree(fops);
4674     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4675     SvCOMPILED_on(sv);
4676
4677     if (unchopnum && repeat)
4678         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4679     return 0;
4680 }
4681
4682
4683 STATIC bool
4684 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4685 {
4686     /* Can value be printed in fldsize chars, using %*.*f ? */
4687     NV pwr = 1;
4688     NV eps = 0.5;
4689     bool res = FALSE;
4690     int intsize = fldsize - (value < 0 ? 1 : 0);
4691
4692     if (frcsize & 256)
4693         intsize--;
4694     frcsize &= 255;
4695     intsize -= frcsize;
4696
4697     while (intsize--) pwr *= 10.0;
4698     while (frcsize--) eps /= 10.0;
4699
4700     if( value >= 0 ){
4701         if (value + eps >= pwr)
4702             res = TRUE;
4703     } else {
4704         if (value - eps <= -pwr)
4705             res = TRUE;
4706     }
4707     return res;
4708 }
4709
4710 static I32
4711 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4712 {
4713     dVAR;
4714     SV * const datasv = FILTER_DATA(idx);
4715     const int filter_has_file = IoLINES(datasv);
4716     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4717     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4718     int status = 0;
4719     SV *upstream;
4720     STRLEN got_len;
4721     const char *got_p = NULL;
4722     const char *prune_from = NULL;
4723     bool read_from_cache = FALSE;
4724     STRLEN umaxlen;
4725
4726     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4727
4728     assert(maxlen >= 0);
4729     umaxlen = maxlen;
4730
4731     /* I was having segfault trouble under Linux 2.2.5 after a
4732        parse error occured.  (Had to hack around it with a test
4733        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4734        not sure where the trouble is yet.  XXX */
4735
4736     if (IoFMT_GV(datasv)) {
4737         SV *const cache = (SV *)IoFMT_GV(datasv);
4738         if (SvOK(cache)) {
4739             STRLEN cache_len;
4740             const char *cache_p = SvPV(cache, cache_len);
4741             STRLEN take = 0;
4742
4743             if (umaxlen) {
4744                 /* Running in block mode and we have some cached data already.
4745                  */
4746                 if (cache_len >= umaxlen) {
4747                     /* In fact, so much data we don't even need to call
4748                        filter_read.  */
4749                     take = umaxlen;
4750                 }
4751             } else {
4752                 const char *const first_nl =
4753                     (const char *)memchr(cache_p, '\n', cache_len);
4754                 if (first_nl) {
4755                     take = first_nl + 1 - cache_p;
4756                 }
4757             }
4758             if (take) {
4759                 sv_catpvn(buf_sv, cache_p, take);
4760                 sv_chop(cache, cache_p + take);
4761                 /* Definately not EOF  */
4762                 return 1;
4763             }
4764
4765             sv_catsv(buf_sv, cache);
4766             if (umaxlen) {
4767                 umaxlen -= cache_len;
4768             }
4769             SvOK_off(cache);
4770             read_from_cache = TRUE;
4771         }
4772     }
4773
4774     /* Filter API says that the filter appends to the contents of the buffer.
4775        Usually the buffer is "", so the details don't matter. But if it's not,
4776        then clearly what it contains is already filtered by this filter, so we
4777        don't want to pass it in a second time.
4778        I'm going to use a mortal in case the upstream filter croaks.  */
4779     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4780         ? sv_newmortal() : buf_sv;
4781     SvUPGRADE(upstream, SVt_PV);
4782
4783     if (filter_has_file) {
4784         status = FILTER_READ(idx+1, upstream, 0);
4785     }
4786
4787     if (filter_sub && status >= 0) {
4788         dSP;
4789         int count;
4790
4791         ENTER;
4792         SAVE_DEFSV;
4793         SAVETMPS;
4794         EXTEND(SP, 2);
4795
4796         DEFSV = upstream;
4797         PUSHMARK(SP);
4798         mPUSHi(0);
4799         if (filter_state) {
4800             PUSHs(filter_state);
4801         }
4802         PUTBACK;
4803         count = call_sv(filter_sub, G_SCALAR);
4804         SPAGAIN;
4805
4806         if (count > 0) {
4807             SV *out = POPs;
4808             if (SvOK(out)) {
4809                 status = SvIV(out);
4810             }
4811         }
4812
4813         PUTBACK;
4814         FREETMPS;
4815         LEAVE;
4816     }
4817
4818     if(SvOK(upstream)) {
4819         got_p = SvPV(upstream, got_len);
4820         if (umaxlen) {
4821             if (got_len > umaxlen) {
4822                 prune_from = got_p + umaxlen;
4823             }
4824         } else {
4825             const char *const first_nl =
4826                 (const char *)memchr(got_p, '\n', got_len);
4827             if (first_nl && first_nl + 1 < got_p + got_len) {
4828                 /* There's a second line here... */
4829                 prune_from = first_nl + 1;
4830             }
4831         }
4832     }
4833     if (prune_from) {
4834         /* Oh. Too long. Stuff some in our cache.  */
4835         STRLEN cached_len = got_p + got_len - prune_from;
4836         SV *cache = (SV *)IoFMT_GV(datasv);
4837
4838         if (!cache) {
4839             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4840         } else if (SvOK(cache)) {
4841             /* Cache should be empty.  */
4842             assert(!SvCUR(cache));
4843         }
4844
4845         sv_setpvn(cache, prune_from, cached_len);
4846         /* If you ask for block mode, you may well split UTF-8 characters.
4847            "If it breaks, you get to keep both parts"
4848            (Your code is broken if you  don't put them back together again
4849            before something notices.) */
4850         if (SvUTF8(upstream)) {
4851             SvUTF8_on(cache);
4852         }
4853         SvCUR_set(upstream, got_len - cached_len);
4854         /* Can't yet be EOF  */
4855         if (status == 0)
4856             status = 1;
4857     }
4858
4859     /* If they are at EOF but buf_sv has something in it, then they may never
4860        have touched the SV upstream, so it may be undefined.  If we naively
4861        concatenate it then we get a warning about use of uninitialised value.
4862     */
4863     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4864         sv_catsv(buf_sv, upstream);
4865     }
4866
4867     if (status <= 0) {
4868         IoLINES(datasv) = 0;
4869         SvREFCNT_dec(IoFMT_GV(datasv));
4870         if (filter_state) {
4871             SvREFCNT_dec(filter_state);
4872             IoTOP_GV(datasv) = NULL;
4873         }
4874         if (filter_sub) {
4875             SvREFCNT_dec(filter_sub);
4876             IoBOTTOM_GV(datasv) = NULL;
4877         }
4878         filter_del(S_run_user_filter);
4879     }
4880     if (status == 0 && read_from_cache) {
4881         /* If we read some data from the cache (and by getting here it implies
4882            that we emptied the cache) then we aren't yet at EOF, and mustn't
4883            report that to our caller.  */
4884         return 1;
4885     }
4886     return status;
4887 }
4888
4889 /* perhaps someone can come up with a better name for
4890    this?  it is not really "absolute", per se ... */
4891 static bool
4892 S_path_is_absolute(const char *name)
4893 {
4894     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4895
4896     if (PERL_FILE_IS_ABSOLUTE(name)
4897 #ifdef MACOS_TRADITIONAL
4898         || (*name == ':')
4899 #else
4900         || (*name == '.' && (name[1] == '/' ||
4901                              (name[1] == '.' && name[2] == '/')))
4902 #endif
4903          )
4904     {
4905         return TRUE;
4906     }
4907     else
4908         return FALSE;
4909 }
4910
4911 /*
4912  * Local variables:
4913  * c-indentation-style: bsd
4914  * c-basic-offset: 4
4915  * indent-tabs-mode: t
4916  * End:
4917  *
4918  * ex: set ts=8 sts=4 sw=4 noet:
4919  */