pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Now far ahead the Road has gone,
  13  * And I must follow, if I can,
  14  * Pursuing it with eager feet,
  15  * Until it joins some larger way
  16  * Where many paths and errands meet.
  17  * And whither then?  I cannot say.
  18  */
  19
  20 /* This file contains control-oriented pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * Control-oriented means things like pp_enteriter() and pp_next(), which
  27  * alter the flow of control of the program.
  28  */
  29
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PP_CTL_C
  33 #include "perl.h"
  34
  35 #ifndef WORD_ALIGN
  36 #define WORD_ALIGN sizeof(U32)
  37 #endif
  38
  39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  40
  41 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  42
  43 PP(pp_wantarray)
  44 {
  45     dVAR;
  46     dSP;
  47     I32 cxix;
  48     EXTEND(SP, 1);
  49
  50     cxix = dopoptosub(cxstack_ix);
  51     if (cxix < 0)
  52         RETPUSHUNDEF;
  53
  54     switch (cxstack[cxix].blk_gimme) {
  55     case G_ARRAY:
  56         RETPUSHYES;
  57     case G_SCALAR:
  58         RETPUSHNO;
  59     default:
  60         RETPUSHUNDEF;
  61     }
  62 }
  63
  64 PP(pp_regcreset)
  65 {
  66     dVAR;
  67     /* XXXX Should store the old value to allow for tie/overload - and
  68        restore in regcomp, where marked with XXXX. */
  69     PL_reginterp_cnt = 0;
  70     TAINT_NOT;
  71     return NORMAL;
  72 }
  73
  74 PP(pp_regcomp)
  75 {
  76     dVAR;
  77     dSP;
  78     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  79     SV *tmpstr;
  80     REGEXP *re = NULL;
  81
  82     /* prevent recompiling under /o and ithreads. */
  83 #if defined(USE_ITHREADS)
  84     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  85         if (PL_op->op_flags & OPf_STACKED) {
  86             dMARK;
  87             SP = MARK;
  88         }
  89         else
  90             (void)POPs;
  91         RETURN;
  92     }
  93 #endif
  94     if (PL_op->op_flags & OPf_STACKED) {
  95         /* multiple args; concatentate them */
  96         dMARK; dORIGMARK;
  97         tmpstr = PAD_SV(ARGTARG);
  98         sv_setpvn(tmpstr, "", 0);
  99         while (++MARK <= SP) {
 100             if (PL_amagic_generation) {
 101                 SV *sv;
 102                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
 103                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
 104                 {
 105                    sv_setsv(tmpstr, sv);
 106                    continue;
 107                 }
 108             }
 109             sv_catsv(tmpstr, *MARK);
 110         }
 111         SvSETMAGIC(tmpstr);
 112         SP = ORIGMARK;
 113     }
 114     else
 115         tmpstr = POPs;
 116
 117     if (SvROK(tmpstr)) {
 118         SV * const sv = SvRV(tmpstr);
 119         if (SvTYPE(sv) == SVt_REGEXP)
 120             re = (REGEXP*) sv;
 121     }
 122     if (re) {
 123         re = reg_temp_copy(re);
 124         ReREFCNT_dec(PM_GETRE(pm));
 125         PM_SETRE(pm, re);
 126     }
 127     else {
 128         STRLEN len;
 129         const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
 130         re = PM_GETRE(pm);
 131         assert (re != (REGEXP*) &PL_sv_undef);
 132
 133         /* Check against the last compiled regexp. */
 134         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
 135             memNE(RX_PRECOMP(re), t, len))
 136         {
 137             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
 138             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 139             if (re) {
 140                 ReREFCNT_dec(re);
 141 #ifdef USE_ITHREADS
 142                 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
 143 #else
 144                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 145 #endif
 146             } else if (PL_curcop->cop_hints_hash) {
 147                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 148                                        "regcomp", 7, 0, 0);
 149                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 150                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 151             }
 152
 153             if (PL_op->op_flags & OPf_SPECIAL)
 154                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 155
 156             if (DO_UTF8(tmpstr)) {
 157                 assert (SvUTF8(tmpstr));
 158             } else if (SvUTF8(tmpstr)) {
 159                 /* Not doing UTF-8, despite what the SV says. Is this only if
 160                    we're trapped in use 'bytes'?  */
 161                 /* Make a copy of the octet sequence, but without the flag on,
 162                    as the compiler now honours the SvUTF8 flag on tmpstr.  */
 163                 STRLEN len;
 164                 const char *const p = SvPV(tmpstr, len);
 165                 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
 166             }
 167
 168                 if (eng)
 169                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 170                 else
 171                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 172
 173             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 174                                            inside tie/overload accessors.  */
 175         }
 176     }
 177
 178     re = PM_GETRE(pm);
 179
 180 #ifndef INCOMPLETE_TAINTS
 181     if (PL_tainting) {
 182         if (PL_tainted)
 183             RX_EXTFLAGS(re) |= RXf_TAINTED;
 184         else
 185             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 186     }
 187 #endif
 188
 189     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 190         pm = PL_curpm;
 191
 192
 193 #if !defined(USE_ITHREADS)
 194     /* can't change the optree at runtime either */
 195     /* PMf_KEEP is handled differently under threads to avoid these problems */
 196     if (pm->op_pmflags & PMf_KEEP) {
 197         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 198         cLOGOP->op_first->op_next = PL_op->op_next;
 199     }
 200 #endif
 201     RETURN;
 202 }
 203
 204 PP(pp_substcont)
 205 {
 206     dVAR;
 207     dSP;
 208     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 209     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 210     register SV * const dstr = cx->sb_dstr;
 211     register char *s = cx->sb_s;
 212     register char *m = cx->sb_m;
 213     char *orig = cx->sb_orig;
 214     register REGEXP * const rx = cx->sb_rx;
 215     SV *nsv = NULL;
 216     REGEXP *old = PM_GETRE(pm);
 217     if(old != rx) {
 218         if(old)
 219             ReREFCNT_dec(old);
 220         PM_SETRE(pm,ReREFCNT_inc(rx));
 221     }
 222
 223     rxres_restore(&cx->sb_rxres, rx);
 224     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 225
 226     if (cx->sb_iters++) {
 227         const I32 saviters = cx->sb_iters;
 228         if (cx->sb_iters > cx->sb_maxiters)
 229             DIE(aTHX_ "Substitution loop");
 230
 231         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 232             cx->sb_rxtainted |= 2;
 233         sv_catsv(dstr, POPs);
 234         FREETMPS; /* Prevent excess tmp stack */
 235
 236         /* Are we done */
 237         if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 238                                      s == m, cx->sb_targ, NULL,
 239                                      ((cx->sb_rflags & REXEC_COPY_STR)
 240                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 241                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 242         {
 243             SV * const targ = cx->sb_targ;
 244
 245             assert(cx->sb_strend >= s);
 246             if(cx->sb_strend > s) {
 247                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 248                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 249                  else
 250                       sv_catpvn(dstr, s, cx->sb_strend - s);
 251             }
 252             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 253
 254 #ifdef PERL_OLD_COPY_ON_WRITE
 255             if (SvIsCOW(targ)) {
 256                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 257             } else
 258 #endif
 259             {
 260                 SvPV_free(targ);
 261             }
 262             SvPV_set(targ, SvPVX(dstr));
 263             SvCUR_set(targ, SvCUR(dstr));
 264             SvLEN_set(targ, SvLEN(dstr));
 265             if (DO_UTF8(dstr))
 266                 SvUTF8_on(targ);
 267             SvPV_set(dstr, NULL);
 268
 269             TAINT_IF(cx->sb_rxtainted & 1);
 270             mPUSHi(saviters - 1);
 271
 272             (void)SvPOK_only_UTF8(targ);
 273             TAINT_IF(cx->sb_rxtainted);
 274             SvSETMAGIC(targ);
 275             SvTAINT(targ);
 276
 277             LEAVE_SCOPE(cx->sb_oldsave);
 278             POPSUBST(cx);
 279             RETURNOP(pm->op_next);
 280         }
 281         cx->sb_iters = saviters;
 282     }
 283     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 284         m = s;
 285         s = orig;
 286         cx->sb_orig = orig = RX_SUBBEG(rx);
 287         s = orig + (m - s);
 288         cx->sb_strend = s + (cx->sb_strend - m);
 289     }
 290     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 291     if (m > s) {
 292         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 293             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 294         else
 295             sv_catpvn(dstr, s, m-s);
 296     }
 297     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 298     { /* Update the pos() information. */
 299         SV * const sv = cx->sb_targ;
 300         MAGIC *mg;
 301         SvUPGRADE(sv, SVt_PVMG);
 302         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 303 #ifdef PERL_OLD_COPY_ON_WRITE
 304             if (SvIsCOW(sv))
 305                 sv_force_normal_flags(sv, 0);
 306 #endif
 307             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 308                              NULL, 0);
 309         }
 310         mg->mg_len = m - orig;
 311     }
 312     if (old != rx)
 313         (void)ReREFCNT_inc(rx);
 314     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 315     rxres_save(&cx->sb_rxres, rx);
 316     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 317 }
 318
 319 void
 320 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 321 {
 322     UV *p = (UV*)*rsp;
 323     U32 i;
 324
 325     PERL_ARGS_ASSERT_RXRES_SAVE;
 326     PERL_UNUSED_CONTEXT;
 327
 328     if (!p || p[1] < RX_NPARENS(rx)) {
 329 #ifdef PERL_OLD_COPY_ON_WRITE
 330         i = 7 + RX_NPARENS(rx) * 2;
 331 #else
 332         i = 6 + RX_NPARENS(rx) * 2;
 333 #endif
 334         if (!p)
 335             Newx(p, i, UV);
 336         else
 337             Renew(p, i, UV);
 338         *rsp = (void*)p;
 339     }
 340
 341     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 342     RX_MATCH_COPIED_off(rx);
 343
 344 #ifdef PERL_OLD_COPY_ON_WRITE
 345     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 346     RX_SAVED_COPY(rx) = NULL;
 347 #endif
 348
 349     *p++ = RX_NPARENS(rx);
 350
 351     *p++ = PTR2UV(RX_SUBBEG(rx));
 352     *p++ = (UV)RX_SUBLEN(rx);
 353     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 354         *p++ = (UV)RX_OFFS(rx)[i].start;
 355         *p++ = (UV)RX_OFFS(rx)[i].end;
 356     }
 357 }
 358
 359 void
 360 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 361 {
 362     UV *p = (UV*)*rsp;
 363     U32 i;
 364
 365     PERL_ARGS_ASSERT_RXRES_RESTORE;
 366     PERL_UNUSED_CONTEXT;
 367
 368     RX_MATCH_COPY_FREE(rx);
 369     RX_MATCH_COPIED_set(rx, *p);
 370     *p++ = 0;
 371
 372 #ifdef PERL_OLD_COPY_ON_WRITE
 373     if (RX_SAVED_COPY(rx))
 374         SvREFCNT_dec (RX_SAVED_COPY(rx));
 375     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 376     *p++ = 0;
 377 #endif
 378
 379     RX_NPARENS(rx) = *p++;
 380
 381     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 382     RX_SUBLEN(rx) = (I32)(*p++);
 383     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 384         RX_OFFS(rx)[i].start = (I32)(*p++);
 385         RX_OFFS(rx)[i].end = (I32)(*p++);
 386     }
 387 }
 388
 389 void
 390 Perl_rxres_free(pTHX_ void **rsp)
 391 {
 392     UV * const p = (UV*)*rsp;
 393
 394     PERL_ARGS_ASSERT_RXRES_FREE;
 395     PERL_UNUSED_CONTEXT;
 396
 397     if (p) {
 398 #ifdef PERL_POISON
 399         void *tmp = INT2PTR(char*,*p);
 400         Safefree(tmp);
 401         if (*p)
 402             PoisonFree(*p, 1, sizeof(*p));
 403 #else
 404         Safefree(INT2PTR(char*,*p));
 405 #endif
 406 #ifdef PERL_OLD_COPY_ON_WRITE
 407         if (p[1]) {
 408             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 409         }
 410 #endif
 411         Safefree(p);
 412         *rsp = NULL;
 413     }
 414 }
 415
 416 PP(pp_formline)
 417 {
 418     dVAR; dSP; dMARK; dORIGMARK;
 419     register SV * const tmpForm = *++MARK;
 420     register U32 *fpc;
 421     register char *t;
 422     const char *f;
 423     register I32 arg;
 424     register SV *sv = NULL;
 425     const char *item = NULL;
 426     I32 itemsize  = 0;
 427     I32 fieldsize = 0;
 428     I32 lines = 0;
 429     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 430     const char *chophere = NULL;
 431     char *linemark = NULL;
 432     NV value;
 433     bool gotsome = FALSE;
 434     STRLEN len;
 435     const STRLEN fudge = SvPOK(tmpForm)
 436                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 437     bool item_is_utf8 = FALSE;
 438     bool targ_is_utf8 = FALSE;
 439     SV * nsv = NULL;
 440     OP * parseres = NULL;
 441     const char *fmt;
 442     bool oneline;
 443
 444     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 445         if (SvREADONLY(tmpForm)) {
 446             SvREADONLY_off(tmpForm);
 447             parseres = doparseform(tmpForm);
 448             SvREADONLY_on(tmpForm);
 449         }
 450         else
 451             parseres = doparseform(tmpForm);
 452         if (parseres)
 453             return parseres;
 454     }
 455     SvPV_force(PL_formtarget, len);
 456     if (DO_UTF8(PL_formtarget))
 457         targ_is_utf8 = TRUE;
 458     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 459     t += len;
 460     f = SvPV_const(tmpForm, len);
 461     /* need to jump to the next word */
 462     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 463
 464     for (;;) {
 465         DEBUG_f( {
 466             const char *name = "???";
 467             arg = -1;
 468             switch (*fpc) {
 469             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 470             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 471             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 472             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 473             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 474
 475             case FF_CHECKNL:    name = "CHECKNL";       break;
 476             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 477             case FF_SPACE:      name = "SPACE";         break;
 478             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 479             case FF_ITEM:       name = "ITEM";          break;
 480             case FF_CHOP:       name = "CHOP";          break;
 481             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 482             case FF_NEWLINE:    name = "NEWLINE";       break;
 483             case FF_MORE:       name = "MORE";          break;
 484             case FF_LINEMARK:   name = "LINEMARK";      break;
 485             case FF_END:        name = "END";           break;
 486             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 487             case FF_LINESNGL:   name = "LINESNGL";      break;
 488             }
 489             if (arg >= 0)
 490                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 491             else
 492                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 493         } );
 494         switch (*fpc++) {
 495         case FF_LINEMARK:
 496             linemark = t;
 497             lines++;
 498             gotsome = FALSE;
 499             break;
 500
 501         case FF_LITERAL:
 502             arg = *fpc++;
 503             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 504                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 505                 *t = '\0';
 506                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 507                 t = SvEND(PL_formtarget);
 508                 break;
 509             }
 510             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 511                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 512                 *t = '\0';
 513                 sv_utf8_upgrade(PL_formtarget);
 514                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 515                 t = SvEND(PL_formtarget);
 516                 targ_is_utf8 = TRUE;
 517             }
 518             while (arg--)
 519                 *t++ = *f++;
 520             break;
 521
 522         case FF_SKIP:
 523             f += *fpc++;
 524             break;
 525
 526         case FF_FETCH:
 527             arg = *fpc++;
 528             f += arg;
 529             fieldsize = arg;
 530
 531             if (MARK < SP)
 532                 sv = *++MARK;
 533             else {
 534                 sv = &PL_sv_no;
 535                 if (ckWARN(WARN_SYNTAX))
 536                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 537             }
 538             break;
 539
 540         case FF_CHECKNL:
 541             {
 542                 const char *send;
 543                 const char *s = item = SvPV_const(sv, len);
 544                 itemsize = len;
 545                 if (DO_UTF8(sv)) {
 546                     itemsize = sv_len_utf8(sv);
 547                     if (itemsize != (I32)len) {
 548                         I32 itembytes;
 549                         if (itemsize > fieldsize) {
 550                             itemsize = fieldsize;
 551                             itembytes = itemsize;
 552                             sv_pos_u2b(sv, &itembytes, 0);
 553                         }
 554                         else
 555                             itembytes = len;
 556                         send = chophere = s + itembytes;
 557                         while (s < send) {
 558                             if (*s & ~31)
 559                                 gotsome = TRUE;
 560                             else if (*s == '\n')
 561                                 break;
 562                             s++;
 563                         }
 564                         item_is_utf8 = TRUE;
 565                         itemsize = s - item;
 566                         sv_pos_b2u(sv, &itemsize);
 567                         break;
 568                     }
 569                 }
 570                 item_is_utf8 = FALSE;
 571                 if (itemsize > fieldsize)
 572                     itemsize = fieldsize;
 573                 send = chophere = s + itemsize;
 574                 while (s < send) {
 575                     if (*s & ~31)
 576                         gotsome = TRUE;
 577                     else if (*s == '\n')
 578                         break;
 579                     s++;
 580                 }
 581                 itemsize = s - item;
 582                 break;
 583             }
 584
 585         case FF_CHECKCHOP:
 586             {
 587                 const char *s = item = SvPV_const(sv, len);
 588                 itemsize = len;
 589                 if (DO_UTF8(sv)) {
 590                     itemsize = sv_len_utf8(sv);
 591                     if (itemsize != (I32)len) {
 592                         I32 itembytes;
 593                         if (itemsize <= fieldsize) {
 594                             const char *send = chophere = s + itemsize;
 595                             while (s < send) {
 596                                 if (*s == '\r') {
 597                                     itemsize = s - item;
 598                                     chophere = s;
 599                                     break;
 600                                 }
 601                                 if (*s++ & ~31)
 602                                     gotsome = TRUE;
 603                             }
 604                         }
 605                         else {
 606                             const char *send;
 607                             itemsize = fieldsize;
 608                             itembytes = itemsize;
 609                             sv_pos_u2b(sv, &itembytes, 0);
 610                             send = chophere = s + itembytes;
 611                             while (s < send || (s == send && isSPACE(*s))) {
 612                                 if (isSPACE(*s)) {
 613                                     if (chopspace)
 614                                         chophere = s;
 615                                     if (*s == '\r')
 616                                         break;
 617                                 }
 618                                 else {
 619                                     if (*s & ~31)
 620                                         gotsome = TRUE;
 621                                     if (strchr(PL_chopset, *s))
 622                                         chophere = s + 1;
 623                                 }
 624                                 s++;
 625                             }
 626                             itemsize = chophere - item;
 627                             sv_pos_b2u(sv, &itemsize);
 628                         }
 629                         item_is_utf8 = TRUE;
 630                         break;
 631                     }
 632                 }
 633                 item_is_utf8 = FALSE;
 634                 if (itemsize <= fieldsize) {
 635                     const char *const send = chophere = s + itemsize;
 636                     while (s < send) {
 637                         if (*s == '\r') {
 638                             itemsize = s - item;
 639                             chophere = s;
 640                             break;
 641                         }
 642                         if (*s++ & ~31)
 643                             gotsome = TRUE;
 644                     }
 645                 }
 646                 else {
 647                     const char *send;
 648                     itemsize = fieldsize;
 649                     send = chophere = s + itemsize;
 650                     while (s < send || (s == send && isSPACE(*s))) {
 651                         if (isSPACE(*s)) {
 652                             if (chopspace)
 653                                 chophere = s;
 654                             if (*s == '\r')
 655                                 break;
 656                         }
 657                         else {
 658                             if (*s & ~31)
 659                                 gotsome = TRUE;
 660                             if (strchr(PL_chopset, *s))
 661                                 chophere = s + 1;
 662                         }
 663                         s++;
 664                     }
 665                     itemsize = chophere - item;
 666                 }
 667                 break;
 668             }
 669
 670         case FF_SPACE:
 671             arg = fieldsize - itemsize;
 672             if (arg) {
 673                 fieldsize -= arg;
 674                 while (arg-- > 0)
 675                     *t++ = ' ';
 676             }
 677             break;
 678
 679         case FF_HALFSPACE:
 680             arg = fieldsize - itemsize;
 681             if (arg) {
 682                 arg /= 2;
 683                 fieldsize -= arg;
 684                 while (arg-- > 0)
 685                     *t++ = ' ';
 686             }
 687             break;
 688
 689         case FF_ITEM:
 690             {
 691                 const char *s = item;
 692                 arg = itemsize;
 693                 if (item_is_utf8) {
 694                     if (!targ_is_utf8) {
 695                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 696                         *t = '\0';
 697                         sv_utf8_upgrade(PL_formtarget);
 698                         SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 699                         t = SvEND(PL_formtarget);
 700                         targ_is_utf8 = TRUE;
 701                     }
 702                     while (arg--) {
 703                         if (UTF8_IS_CONTINUED(*s)) {
 704                             STRLEN skip = UTF8SKIP(s);
 705                             switch (skip) {
 706                             default:
 707                                 Move(s,t,skip,char);
 708                                 s += skip;
 709                                 t += skip;
 710                                 break;
 711                             case 7: *t++ = *s++;
 712                             case 6: *t++ = *s++;
 713                             case 5: *t++ = *s++;
 714                             case 4: *t++ = *s++;
 715                             case 3: *t++ = *s++;
 716                             case 2: *t++ = *s++;
 717                             case 1: *t++ = *s++;
 718                             }
 719                         }
 720                         else {
 721                             if ( !((*t++ = *s++) & ~31) )
 722                                 t[-1] = ' ';
 723                         }
 724                     }
 725                     break;
 726                 }
 727                 if (targ_is_utf8 && !item_is_utf8) {
 728                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 729                     *t = '\0';
 730                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 731                     for (; t < SvEND(PL_formtarget); t++) {
 732 #ifdef EBCDIC
 733                         const int ch = *t;
 734                         if (iscntrl(ch))
 735 #else
 736                             if (!(*t & ~31))
 737 #endif
 738                                 *t = ' ';
 739                     }
 740                     break;
 741                 }
 742                 while (arg--) {
 743 #ifdef EBCDIC
 744                     const int ch = *t++ = *s++;
 745                     if (iscntrl(ch))
 746 #else
 747                         if ( !((*t++ = *s++) & ~31) )
 748 #endif
 749                             t[-1] = ' ';
 750                 }
 751                 break;
 752             }
 753
 754         case FF_CHOP:
 755             {
 756                 const char *s = chophere;
 757                 if (chopspace) {
 758                     while (isSPACE(*s))
 759                         s++;
 760                 }
 761                 sv_chop(sv,s);
 762                 SvSETMAGIC(sv);
 763                 break;
 764             }
 765
 766         case FF_LINESNGL:
 767             chopspace = 0;
 768             oneline = TRUE;
 769             goto ff_line;
 770         case FF_LINEGLOB:
 771             oneline = FALSE;
 772         ff_line:
 773             {
 774                 const char *s = item = SvPV_const(sv, len);
 775                 itemsize = len;
 776                 if ((item_is_utf8 = DO_UTF8(sv)))
 777                     itemsize = sv_len_utf8(sv);
 778                 if (itemsize) {
 779                     bool chopped = FALSE;
 780                     const char *const send = s + len;
 781                     gotsome = TRUE;
 782                     chophere = s + itemsize;
 783                     while (s < send) {
 784                         if (*s++ == '\n') {
 785                             if (oneline) {
 786                                 chopped = TRUE;
 787                                 chophere = s;
 788                                 break;
 789                             } else {
 790                                 if (s == send) {
 791                                     itemsize--;
 792                                     chopped = TRUE;
 793                                 } else
 794                                     lines++;
 795                             }
 796                         }
 797                     }
 798                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 799                     if (targ_is_utf8)
 800                         SvUTF8_on(PL_formtarget);
 801                     if (oneline) {
 802                         SvCUR_set(sv, chophere - item);
 803                         sv_catsv(PL_formtarget, sv);
 804                         SvCUR_set(sv, itemsize);
 805                     } else
 806                         sv_catsv(PL_formtarget, sv);
 807                     if (chopped)
 808                         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 809                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 810                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 811                     if (item_is_utf8)
 812                         targ_is_utf8 = TRUE;
 813                 }
 814                 break;
 815             }
 816
 817         case FF_0DECIMAL:
 818             arg = *fpc++;
 819 #if defined(USE_LONG_DOUBLE)
 820             fmt = (const char *)
 821                 ((arg & 256) ?
 822                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 823 #else
 824             fmt = (const char *)
 825                 ((arg & 256) ?
 826                  "%#0*.*f"              : "%0*.*f");
 827 #endif
 828             goto ff_dec;
 829         case FF_DECIMAL:
 830             arg = *fpc++;
 831 #if defined(USE_LONG_DOUBLE)
 832             fmt = (const char *)
 833                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 834 #else
 835             fmt = (const char *)
 836                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 837 #endif
 838         ff_dec:
 839             /* If the field is marked with ^ and the value is undefined,
 840                blank it out. */
 841             if ((arg & 512) && !SvOK(sv)) {
 842                 arg = fieldsize;
 843                 while (arg--)
 844                     *t++ = ' ';
 845                 break;
 846             }
 847             gotsome = TRUE;
 848             value = SvNV(sv);
 849             /* overflow evidence */
 850             if (num_overflow(value, fieldsize, arg)) {
 851                 arg = fieldsize;
 852                 while (arg--)
 853                     *t++ = '#';
 854                 break;
 855             }
 856             /* Formats aren't yet marked for locales, so assume "yes". */
 857             {
 858                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 859                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 860                 RESTORE_NUMERIC_STANDARD();
 861             }
 862             t += fieldsize;
 863             break;
 864
 865         case FF_NEWLINE:
 866             f++;
 867             while (t-- > linemark && *t == ' ') ;
 868             t++;
 869             *t++ = '\n';
 870             break;
 871
 872         case FF_BLANK:
 873             arg = *fpc++;
 874             if (gotsome) {
 875                 if (arg) {              /* repeat until fields exhausted? */
 876                     *t = '\0';
 877                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 878                     lines += FmLINES(PL_formtarget);
 879                     if (lines == 200) {
 880                         arg = t - linemark;
 881                         if (strnEQ(linemark, linemark - arg, arg))
 882                             DIE(aTHX_ "Runaway format");
 883                     }
 884                     if (targ_is_utf8)
 885                         SvUTF8_on(PL_formtarget);
 886                     FmLINES(PL_formtarget) = lines;
 887                     SP = ORIGMARK;
 888                     RETURNOP(cLISTOP->op_first);
 889                 }
 890             }
 891             else {
 892                 t = linemark;
 893                 lines--;
 894             }
 895             break;
 896
 897         case FF_MORE:
 898             {
 899                 const char *s = chophere;
 900                 const char *send = item + len;
 901                 if (chopspace) {
 902                     while (isSPACE(*s) && (s < send))
 903                         s++;
 904                 }
 905                 if (s < send) {
 906                     char *s1;
 907                     arg = fieldsize - itemsize;
 908                     if (arg) {
 909                         fieldsize -= arg;
 910                         while (arg-- > 0)
 911                             *t++ = ' ';
 912                     }
 913                     s1 = t - 3;
 914                     if (strnEQ(s1,"   ",3)) {
 915                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 916                             s1--;
 917                     }
 918                     *s1++ = '.';
 919                     *s1++ = '.';
 920                     *s1++ = '.';
 921                 }
 922                 break;
 923             }
 924         case FF_END:
 925             *t = '\0';
 926             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 927             if (targ_is_utf8)
 928                 SvUTF8_on(PL_formtarget);
 929             FmLINES(PL_formtarget) += lines;
 930             SP = ORIGMARK;
 931             RETPUSHYES;
 932         }
 933     }
 934 }
 935
 936 PP(pp_grepstart)
 937 {
 938     dVAR; dSP;
 939     SV *src;
 940
 941     if (PL_stack_base + *PL_markstack_ptr == SP) {
 942         (void)POPMARK;
 943         if (GIMME_V == G_SCALAR)
 944             mXPUSHi(0);
 945         RETURNOP(PL_op->op_next->op_next);
 946     }
 947     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 948     pp_pushmark();                              /* push dst */
 949     pp_pushmark();                              /* push src */
 950     ENTER;                                      /* enter outer scope */
 951
 952     SAVETMPS;
 953     if (PL_op->op_private & OPpGREP_LEX)
 954         SAVESPTR(PAD_SVl(PL_op->op_targ));
 955     else
 956         SAVE_DEFSV;
 957     ENTER;                                      /* enter inner scope */
 958     SAVEVPTR(PL_curpm);
 959
 960     src = PL_stack_base[*PL_markstack_ptr];
 961     SvTEMP_off(src);
 962     if (PL_op->op_private & OPpGREP_LEX)
 963         PAD_SVl(PL_op->op_targ) = src;
 964     else
 965         DEFSV = src;
 966
 967     PUTBACK;
 968     if (PL_op->op_type == OP_MAPSTART)
 969         pp_pushmark();                  /* push top */
 970     return ((LOGOP*)PL_op->op_next)->op_other;
 971 }
 972
 973 PP(pp_mapwhile)
 974 {
 975     dVAR; dSP;
 976     const I32 gimme = GIMME_V;
 977     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 978     I32 count;
 979     I32 shift;
 980     SV** src;
 981     SV** dst;
 982
 983     /* first, move source pointer to the next item in the source list */
 984     ++PL_markstack_ptr[-1];
 985
 986     /* if there are new items, push them into the destination list */
 987     if (items && gimme != G_VOID) {
 988         /* might need to make room back there first */
 989         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 990             /* XXX this implementation is very pessimal because the stack
 991              * is repeatedly extended for every set of items.  Is possible
 992              * to do this without any stack extension or copying at all
 993              * by maintaining a separate list over which the map iterates
 994              * (like foreach does). --gsar */
 995
 996             /* everything in the stack after the destination list moves
 997              * towards the end the stack by the amount of room needed */
 998             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 999
1000             /* items to shift up (accounting for the moved source pointer) */
1001             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1002
1003             /* This optimization is by Ben Tilly and it does
1004              * things differently from what Sarathy (gsar)
1005              * is describing.  The downside of this optimization is
1006              * that leaves "holes" (uninitialized and hopefully unused areas)
1007              * to the Perl stack, but on the other hand this
1008              * shouldn't be a problem.  If Sarathy's idea gets
1009              * implemented, this optimization should become
1010              * irrelevant.  --jhi */
1011             if (shift < count)
1012                 shift = count; /* Avoid shifting too often --Ben Tilly */
1013
1014             EXTEND(SP,shift);
1015             src = SP;
1016             dst = (SP += shift);
1017             PL_markstack_ptr[-1] += shift;
1018             *PL_markstack_ptr += shift;
1019             while (count--)
1020                 *dst-- = *src--;
1021         }
1022         /* copy the new items down to the destination list */
1023         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1024         if (gimme == G_ARRAY) {
1025             while (items-- > 0)
1026                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1027         }
1028         else {
1029             /* scalar context: we don't care about which values map returns
1030              * (we use undef here). And so we certainly don't want to do mortal
1031              * copies of meaningless values. */
1032             while (items-- > 0) {
1033                 (void)POPs;
1034                 *dst-- = &PL_sv_undef;
1035             }
1036         }
1037     }
1038     LEAVE;                                      /* exit inner scope */
1039
1040     /* All done yet? */
1041     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1042
1043         (void)POPMARK;                          /* pop top */
1044         LEAVE;                                  /* exit outer scope */
1045         (void)POPMARK;                          /* pop src */
1046         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1047         (void)POPMARK;                          /* pop dst */
1048         SP = PL_stack_base + POPMARK;           /* pop original mark */
1049         if (gimme == G_SCALAR) {
1050             if (PL_op->op_private & OPpGREP_LEX) {
1051                 SV* sv = sv_newmortal();
1052                 sv_setiv(sv, items);
1053                 PUSHs(sv);
1054             }
1055             else {
1056                 dTARGET;
1057                 XPUSHi(items);
1058             }
1059         }
1060         else if (gimme == G_ARRAY)
1061             SP += items;
1062         RETURN;
1063     }
1064     else {
1065         SV *src;
1066
1067         ENTER;                                  /* enter inner scope */
1068         SAVEVPTR(PL_curpm);
1069
1070         /* set $_ to the new source item */
1071         src = PL_stack_base[PL_markstack_ptr[-1]];
1072         SvTEMP_off(src);
1073         if (PL_op->op_private & OPpGREP_LEX)
1074             PAD_SVl(PL_op->op_targ) = src;
1075         else
1076             DEFSV = src;
1077
1078         RETURNOP(cLOGOP->op_other);
1079     }
1080 }
1081
1082 /* Range stuff. */
1083
1084 PP(pp_range)
1085 {
1086     dVAR;
1087     if (GIMME == G_ARRAY)
1088         return NORMAL;
1089     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1090         return cLOGOP->op_other;
1091     else
1092         return NORMAL;
1093 }
1094
1095 PP(pp_flip)
1096 {
1097     dVAR;
1098     dSP;
1099
1100     if (GIMME == G_ARRAY) {
1101         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1102     }
1103     else {
1104         dTOPss;
1105         SV * const targ = PAD_SV(PL_op->op_targ);
1106         int flip = 0;
1107
1108         if (PL_op->op_private & OPpFLIP_LINENUM) {
1109             if (GvIO(PL_last_in_gv)) {
1110                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1111             }
1112             else {
1113                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1114                 if (gv && GvSV(gv))
1115                     flip = SvIV(sv) == SvIV(GvSV(gv));
1116             }
1117         } else {
1118             flip = SvTRUE(sv);
1119         }
1120         if (flip) {
1121             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1122             if (PL_op->op_flags & OPf_SPECIAL) {
1123                 sv_setiv(targ, 1);
1124                 SETs(targ);
1125                 RETURN;
1126             }
1127             else {
1128                 sv_setiv(targ, 0);
1129                 SP--;
1130                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1131             }
1132         }
1133         sv_setpvn(TARG, "", 0);
1134         SETs(targ);
1135         RETURN;
1136     }
1137 }
1138
1139 /* This code tries to decide if "$left .. $right" should use the
1140    magical string increment, or if the range is numeric (we make
1141    an exception for .."0" [#18165]). AMS 20021031. */
1142
1143 #define RANGE_IS_NUMERIC(left,right) ( \
1144         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1145         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1146         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1147           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1148          && (!SvOK(right) || looks_like_number(right))))
1149
1150 PP(pp_flop)
1151 {
1152     dVAR; dSP;
1153
1154     if (GIMME == G_ARRAY) {
1155         dPOPPOPssrl;
1156
1157         SvGETMAGIC(left);
1158         SvGETMAGIC(right);
1159
1160         if (RANGE_IS_NUMERIC(left,right)) {
1161             register IV i, j;
1162             IV max;
1163             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1164                 (SvOK(right) && SvNV(right) > IV_MAX))
1165                 DIE(aTHX_ "Range iterator outside integer range");
1166             i = SvIV(left);
1167             max = SvIV(right);
1168             if (max >= i) {
1169                 j = max - i + 1;
1170                 EXTEND_MORTAL(j);
1171                 EXTEND(SP, j);
1172             }
1173             else
1174                 j = 0;
1175             while (j--) {
1176                 SV * const sv = sv_2mortal(newSViv(i++));
1177                 PUSHs(sv);
1178             }
1179         }
1180         else {
1181             SV * const final = sv_mortalcopy(right);
1182             STRLEN len;
1183             const char * const tmps = SvPV_const(final, len);
1184
1185             SV *sv = sv_mortalcopy(left);
1186             SvPV_force_nolen(sv);
1187             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1188                 XPUSHs(sv);
1189                 if (strEQ(SvPVX_const(sv),tmps))
1190                     break;
1191                 sv = sv_2mortal(newSVsv(sv));
1192                 sv_inc(sv);
1193             }
1194         }
1195     }
1196     else {
1197         dTOPss;
1198         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1199         int flop = 0;
1200         sv_inc(targ);
1201
1202         if (PL_op->op_private & OPpFLIP_LINENUM) {
1203             if (GvIO(PL_last_in_gv)) {
1204                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1205             }
1206             else {
1207                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1208                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1209             }
1210         }
1211         else {
1212             flop = SvTRUE(sv);
1213         }
1214
1215         if (flop) {
1216             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1217             sv_catpvs(targ, "E0");
1218         }
1219         SETs(targ);
1220     }
1221
1222     RETURN;
1223 }
1224
1225 /* Control. */
1226
1227 static const char * const context_name[] = {
1228     "pseudo-block",
1229     "when",
1230     NULL, /* CXt_BLOCK never actually needs "block" */
1231     "given",
1232     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1233     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1234     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1235     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1236     "subroutine",
1237     "format",
1238     "eval",
1239     "substitution",
1240 };
1241
1242 STATIC I32
1243 S_dopoptolabel(pTHX_ const char *label)
1244 {
1245     dVAR;
1246     register I32 i;
1247
1248     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1249
1250     for (i = cxstack_ix; i >= 0; i--) {
1251         register const PERL_CONTEXT * const cx = &cxstack[i];
1252         switch (CxTYPE(cx)) {
1253         case CXt_SUBST:
1254         case CXt_SUB:
1255         case CXt_FORMAT:
1256         case CXt_EVAL:
1257         case CXt_NULL:
1258         case CXt_GIVEN:
1259         case CXt_WHEN:
1260             if (ckWARN(WARN_EXITING))
1261                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1262                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1263             if (CxTYPE(cx) == CXt_NULL)
1264                 return -1;
1265             break;
1266         case CXt_LOOP_LAZYIV:
1267         case CXt_LOOP_LAZYSV:
1268         case CXt_LOOP_FOR:
1269         case CXt_LOOP_PLAIN:
1270             if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1271                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1272                         (long)i, CxLABEL(cx)));
1273                 continue;
1274             }
1275             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1276             return i;
1277         }
1278     }
1279     return i;
1280 }
1281
1282
1283
1284 I32
1285 Perl_dowantarray(pTHX)
1286 {
1287     dVAR;
1288     const I32 gimme = block_gimme();
1289     return (gimme == G_VOID) ? G_SCALAR : gimme;
1290 }
1291
1292 I32
1293 Perl_block_gimme(pTHX)
1294 {
1295     dVAR;
1296     const I32 cxix = dopoptosub(cxstack_ix);
1297     if (cxix < 0)
1298         return G_VOID;
1299
1300     switch (cxstack[cxix].blk_gimme) {
1301     case G_VOID:
1302         return G_VOID;
1303     case G_SCALAR:
1304         return G_SCALAR;
1305     case G_ARRAY:
1306         return G_ARRAY;
1307     default:
1308         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1309         /* NOTREACHED */
1310         return 0;
1311     }
1312 }
1313
1314 I32
1315 Perl_is_lvalue_sub(pTHX)
1316 {
1317     dVAR;
1318     const I32 cxix = dopoptosub(cxstack_ix);
1319     assert(cxix >= 0);  /* We should only be called from inside subs */
1320
1321     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1322         return CxLVAL(cxstack + cxix);
1323     else
1324         return 0;
1325 }
1326
1327 STATIC I32
1328 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1329 {
1330     dVAR;
1331     I32 i;
1332
1333     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1334
1335     for (i = startingblock; i >= 0; i--) {
1336         register const PERL_CONTEXT * const cx = &cxstk[i];
1337         switch (CxTYPE(cx)) {
1338         default:
1339             continue;
1340         case CXt_EVAL:
1341         case CXt_SUB:
1342         case CXt_FORMAT:
1343             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1344             return i;
1345         }
1346     }
1347     return i;
1348 }
1349
1350 STATIC I32
1351 S_dopoptoeval(pTHX_ I32 startingblock)
1352 {
1353     dVAR;
1354     I32 i;
1355     for (i = startingblock; i >= 0; i--) {
1356         register const PERL_CONTEXT *cx = &cxstack[i];
1357         switch (CxTYPE(cx)) {
1358         default:
1359             continue;
1360         case CXt_EVAL:
1361             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1362             return i;
1363         }
1364     }
1365     return i;
1366 }
1367
1368 STATIC I32
1369 S_dopoptoloop(pTHX_ I32 startingblock)
1370 {
1371     dVAR;
1372     I32 i;
1373     for (i = startingblock; i >= 0; i--) {
1374         register const PERL_CONTEXT * const cx = &cxstack[i];
1375         switch (CxTYPE(cx)) {
1376         case CXt_SUBST:
1377         case CXt_SUB:
1378         case CXt_FORMAT:
1379         case CXt_EVAL:
1380         case CXt_NULL:
1381             if (ckWARN(WARN_EXITING))
1382                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1383                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1384             if ((CxTYPE(cx)) == CXt_NULL)
1385                 return -1;
1386             break;
1387         case CXt_LOOP_LAZYIV:
1388         case CXt_LOOP_LAZYSV:
1389         case CXt_LOOP_FOR:
1390         case CXt_LOOP_PLAIN:
1391             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1392             return i;
1393         }
1394     }
1395     return i;
1396 }
1397
1398 STATIC I32
1399 S_dopoptogiven(pTHX_ I32 startingblock)
1400 {
1401     dVAR;
1402     I32 i;
1403     for (i = startingblock; i >= 0; i--) {
1404         register const PERL_CONTEXT *cx = &cxstack[i];
1405         switch (CxTYPE(cx)) {
1406         default:
1407             continue;
1408         case CXt_GIVEN:
1409             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1410             return i;
1411         case CXt_LOOP_PLAIN:
1412             assert(!CxFOREACHDEF(cx));
1413             break;
1414         case CXt_LOOP_LAZYIV:
1415         case CXt_LOOP_LAZYSV:
1416         case CXt_LOOP_FOR:
1417             if (CxFOREACHDEF(cx)) {
1418                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1419                 return i;
1420             }
1421         }
1422     }
1423     return i;
1424 }
1425
1426 STATIC I32
1427 S_dopoptowhen(pTHX_ I32 startingblock)
1428 {
1429     dVAR;
1430     I32 i;
1431     for (i = startingblock; i >= 0; i--) {
1432         register const PERL_CONTEXT *cx = &cxstack[i];
1433         switch (CxTYPE(cx)) {
1434         default:
1435             continue;
1436         case CXt_WHEN:
1437             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1438             return i;
1439         }
1440     }
1441     return i;
1442 }
1443
1444 void
1445 Perl_dounwind(pTHX_ I32 cxix)
1446 {
1447     dVAR;
1448     I32 optype;
1449
1450     while (cxstack_ix > cxix) {
1451         SV *sv;
1452         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1453         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1454                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1455         /* Note: we don't need to restore the base context info till the end. */
1456         switch (CxTYPE(cx)) {
1457         case CXt_SUBST:
1458             POPSUBST(cx);
1459             continue;  /* not break */
1460         case CXt_SUB:
1461             POPSUB(cx,sv);
1462             LEAVESUB(sv);
1463             break;
1464         case CXt_EVAL:
1465             POPEVAL(cx);
1466             break;
1467         case CXt_LOOP_LAZYIV:
1468         case CXt_LOOP_LAZYSV:
1469         case CXt_LOOP_FOR:
1470         case CXt_LOOP_PLAIN:
1471             POPLOOP(cx);
1472             break;
1473         case CXt_NULL:
1474             break;
1475         case CXt_FORMAT:
1476             POPFORMAT(cx);
1477             break;
1478         }
1479         cxstack_ix--;
1480     }
1481     PERL_UNUSED_VAR(optype);
1482 }
1483
1484 void
1485 Perl_qerror(pTHX_ SV *err)
1486 {
1487     dVAR;
1488
1489     PERL_ARGS_ASSERT_QERROR;
1490
1491     if (PL_in_eval)
1492         sv_catsv(ERRSV, err);
1493     else if (PL_errors)
1494         sv_catsv(PL_errors, err);
1495     else
1496         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1497     if (PL_parser)
1498         ++PL_parser->error_count;
1499 }
1500
1501 OP *
1502 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1503 {
1504     dVAR;
1505
1506     if (PL_in_eval) {
1507         I32 cxix;
1508         I32 gimme;
1509
1510         if (message) {
1511             if (PL_in_eval & EVAL_KEEPERR) {
1512                 static const char prefix[] = "\t(in cleanup) ";
1513                 SV * const err = ERRSV;
1514                 const char *e = NULL;
1515                 if (!SvPOK(err))
1516                     sv_setpvn(err,"",0);
1517                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1518                     STRLEN len;
1519                     e = SvPV_const(err, len);
1520                     e += len - msglen;
1521                     if (*e != *message || strNE(e,message))
1522                         e = NULL;
1523                 }
1524                 if (!e) {
1525                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1526                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1527                     sv_catpvn(err, message, msglen);
1528                     if (ckWARN(WARN_MISC)) {
1529                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1530                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1531                     }
1532                 }
1533             }
1534             else {
1535                 sv_setpvn(ERRSV, message, msglen);
1536             }
1537         }
1538
1539         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1540                && PL_curstackinfo->si_prev)
1541         {
1542             dounwind(-1);
1543             POPSTACK;
1544         }
1545
1546         if (cxix >= 0) {
1547             I32 optype;
1548             register PERL_CONTEXT *cx;
1549             SV **newsp;
1550
1551             if (cxix < cxstack_ix)
1552                 dounwind(cxix);
1553
1554             POPBLOCK(cx,PL_curpm);
1555             if (CxTYPE(cx) != CXt_EVAL) {
1556                 if (!message)
1557                     message = SvPVx_const(ERRSV, msglen);
1558                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1559                 PerlIO_write(Perl_error_log, message, msglen);
1560                 my_exit(1);
1561             }
1562             POPEVAL(cx);
1563
1564             if (gimme == G_SCALAR)
1565                 *++newsp = &PL_sv_undef;
1566             PL_stack_sp = newsp;
1567
1568             LEAVE;
1569
1570             /* LEAVE could clobber PL_curcop (see save_re_context())
1571              * XXX it might be better to find a way to avoid messing with
1572              * PL_curcop in save_re_context() instead, but this is a more
1573              * minimal fix --GSAR */
1574             PL_curcop = cx->blk_oldcop;
1575
1576             if (optype == OP_REQUIRE) {
1577                 const char* const msg = SvPVx_nolen_const(ERRSV);
1578                 SV * const nsv = cx->blk_eval.old_namesv;
1579                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1580                                &PL_sv_undef, 0);
1581                 DIE(aTHX_ "%sCompilation failed in require",
1582                     *msg ? msg : "Unknown error\n");
1583             }
1584             assert(CxTYPE(cx) == CXt_EVAL);
1585             return cx->blk_eval.retop;
1586         }
1587     }
1588     if (!message)
1589         message = SvPVx_const(ERRSV, msglen);
1590
1591     write_to_stderr(message, msglen);
1592     my_failure_exit();
1593     /* NOTREACHED */
1594     return 0;
1595 }
1596
1597 PP(pp_xor)
1598 {
1599     dVAR; dSP; dPOPTOPssrl;
1600     if (SvTRUE(left) != SvTRUE(right))
1601         RETSETYES;
1602     else
1603         RETSETNO;
1604 }
1605
1606 PP(pp_caller)
1607 {
1608     dVAR;
1609     dSP;
1610     register I32 cxix = dopoptosub(cxstack_ix);
1611     register const PERL_CONTEXT *cx;
1612     register const PERL_CONTEXT *ccstack = cxstack;
1613     const PERL_SI *top_si = PL_curstackinfo;
1614     I32 gimme;
1615     const char *stashname;
1616     I32 count = 0;
1617
1618     if (MAXARG)
1619         count = POPi;
1620
1621     for (;;) {
1622         /* we may be in a higher stacklevel, so dig down deeper */
1623         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1624             top_si = top_si->si_prev;
1625             ccstack = top_si->si_cxstack;
1626             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1627         }
1628         if (cxix < 0) {
1629             if (GIMME != G_ARRAY) {
1630                 EXTEND(SP, 1);
1631                 RETPUSHUNDEF;
1632             }
1633             RETURN;
1634         }
1635         /* caller() should not report the automatic calls to &DB::sub */
1636         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1637                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1638             count++;
1639         if (!count--)
1640             break;
1641         cxix = dopoptosub_at(ccstack, cxix - 1);
1642     }
1643
1644     cx = &ccstack[cxix];
1645     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1646         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1647         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1648            field below is defined for any cx. */
1649         /* caller() should not report the automatic calls to &DB::sub */
1650         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1651             cx = &ccstack[dbcxix];
1652     }
1653
1654     stashname = CopSTASHPV(cx->blk_oldcop);
1655     if (GIMME != G_ARRAY) {
1656         EXTEND(SP, 1);
1657         if (!stashname)
1658             PUSHs(&PL_sv_undef);
1659         else {
1660             dTARGET;
1661             sv_setpv(TARG, stashname);
1662             PUSHs(TARG);
1663         }
1664         RETURN;
1665     }
1666
1667     EXTEND(SP, 11);
1668
1669     if (!stashname)
1670         PUSHs(&PL_sv_undef);
1671     else
1672         mPUSHs(newSVpv(stashname, 0));
1673     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1674     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1675     if (!MAXARG)
1676         RETURN;
1677     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1678         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1679         /* So is ccstack[dbcxix]. */
1680         if (isGV(cvgv)) {
1681             SV * const sv = newSV(0);
1682             gv_efullname3(sv, cvgv, NULL);
1683             mPUSHs(sv);
1684             PUSHs(boolSV(CxHASARGS(cx)));
1685         }
1686         else {
1687             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1688             PUSHs(boolSV(CxHASARGS(cx)));
1689         }
1690     }
1691     else {
1692         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1693         mPUSHi(0);
1694     }
1695     gimme = (I32)cx->blk_gimme;
1696     if (gimme == G_VOID)
1697         PUSHs(&PL_sv_undef);
1698     else
1699         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1700     if (CxTYPE(cx) == CXt_EVAL) {
1701         /* eval STRING */
1702         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1703             PUSHs(cx->blk_eval.cur_text);
1704             PUSHs(&PL_sv_no);
1705         }
1706         /* require */
1707         else if (cx->blk_eval.old_namesv) {
1708             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1709             PUSHs(&PL_sv_yes);
1710         }
1711         /* eval BLOCK (try blocks have old_namesv == 0) */
1712         else {
1713             PUSHs(&PL_sv_undef);
1714             PUSHs(&PL_sv_undef);
1715         }
1716     }
1717     else {
1718         PUSHs(&PL_sv_undef);
1719         PUSHs(&PL_sv_undef);
1720     }
1721     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1722         && CopSTASH_eq(PL_curcop, PL_debstash))
1723     {
1724         AV * const ary = cx->blk_sub.argarray;
1725         const int off = AvARRAY(ary) - AvALLOC(ary);
1726
1727         if (!PL_dbargs) {
1728             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1729             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1730             GvMULTI_on(tmpgv);
1731             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1732         }
1733
1734         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1735             av_extend(PL_dbargs, AvFILLp(ary) + off);
1736         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1737         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1738     }
1739     /* XXX only hints propagated via op_private are currently
1740      * visible (others are not easily accessible, since they
1741      * use the global PL_hints) */
1742     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1743     {
1744         SV * mask ;
1745         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1746
1747         if  (old_warnings == pWARN_NONE ||
1748                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1749             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1750         else if (old_warnings == pWARN_ALL ||
1751                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1752             /* Get the bit mask for $warnings::Bits{all}, because
1753              * it could have been extended by warnings::register */
1754             SV **bits_all;
1755             HV * const bits = get_hv("warnings::Bits", FALSE);
1756             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1757                 mask = newSVsv(*bits_all);
1758             }
1759             else {
1760                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1761             }
1762         }
1763         else
1764             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1765         mPUSHs(mask);
1766     }
1767
1768     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1769           sv_2mortal(newRV_noinc(
1770             (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1771                                               cx->blk_oldcop->cop_hints_hash)))
1772           : &PL_sv_undef);
1773     RETURN;
1774 }
1775
1776 PP(pp_reset)
1777 {
1778     dVAR;
1779     dSP;
1780     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1781     sv_reset(tmps, CopSTASH(PL_curcop));
1782     PUSHs(&PL_sv_yes);
1783     RETURN;
1784 }
1785
1786 /* like pp_nextstate, but used instead when the debugger is active */
1787
1788 PP(pp_dbstate)
1789 {
1790     dVAR;
1791     PL_curcop = (COP*)PL_op;
1792     TAINT_NOT;          /* Each statement is presumed innocent */
1793     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1794     FREETMPS;
1795
1796     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1797             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1798     {
1799         dSP;
1800         register PERL_CONTEXT *cx;
1801         const I32 gimme = G_ARRAY;
1802         U8 hasargs;
1803         GV * const gv = PL_DBgv;
1804         register CV * const cv = GvCV(gv);
1805
1806         if (!cv)
1807             DIE(aTHX_ "No DB::DB routine defined");
1808
1809         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1810             /* don't do recursive DB::DB call */
1811             return NORMAL;
1812
1813         ENTER;
1814         SAVETMPS;
1815
1816         SAVEI32(PL_debug);
1817         SAVESTACK_POS();
1818         PL_debug = 0;
1819         hasargs = 0;
1820         SPAGAIN;
1821
1822         if (CvISXSUB(cv)) {
1823             CvDEPTH(cv)++;
1824             PUSHMARK(SP);
1825             (void)(*CvXSUB(cv))(aTHX_ cv);
1826             CvDEPTH(cv)--;
1827             FREETMPS;
1828             LEAVE;
1829             return NORMAL;
1830         }
1831         else {
1832             PUSHBLOCK(cx, CXt_SUB, SP);
1833             PUSHSUB_DB(cx);
1834             cx->blk_sub.retop = PL_op->op_next;
1835             CvDEPTH(cv)++;
1836             SAVECOMPPAD();
1837             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1838             RETURNOP(CvSTART(cv));
1839         }
1840     }
1841     else
1842         return NORMAL;
1843 }
1844
1845 PP(pp_enteriter)
1846 {
1847     dVAR; dSP; dMARK;
1848     register PERL_CONTEXT *cx;
1849     const I32 gimme = GIMME_V;
1850     SV **svp;
1851     U8 cxtype = CXt_LOOP_FOR;
1852 #ifdef USE_ITHREADS
1853     PAD *iterdata;
1854 #endif
1855
1856     ENTER;
1857     SAVETMPS;
1858
1859     if (PL_op->op_targ) {
1860         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1861             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1862             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1863                     SVs_PADSTALE, SVs_PADSTALE);
1864         }
1865         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1866 #ifndef USE_ITHREADS
1867         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1868 #else
1869         iterdata = NULL;
1870 #endif
1871     }
1872     else {
1873         GV * const gv = (GV*)POPs;
1874         svp = &GvSV(gv);                        /* symbol table variable */
1875         SAVEGENERICSV(*svp);
1876         *svp = newSV(0);
1877 #ifdef USE_ITHREADS
1878         iterdata = (PAD*)gv;
1879 #endif
1880     }
1881
1882     if (PL_op->op_private & OPpITER_DEF)
1883         cxtype |= CXp_FOR_DEF;
1884
1885     ENTER;
1886
1887     PUSHBLOCK(cx, cxtype, SP);
1888 #ifdef USE_ITHREADS
1889     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1890 #else
1891     PUSHLOOP_FOR(cx, svp, MARK, 0);
1892 #endif
1893     if (PL_op->op_flags & OPf_STACKED) {
1894         SV *maybe_ary = POPs;
1895         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1896             dPOPss;
1897             SV * const right = maybe_ary;
1898             SvGETMAGIC(sv);
1899             SvGETMAGIC(right);
1900             if (RANGE_IS_NUMERIC(sv,right)) {
1901                 cx->cx_type &= ~CXTYPEMASK;
1902                 cx->cx_type |= CXt_LOOP_LAZYIV;
1903                 /* Make sure that no-one re-orders cop.h and breaks our
1904                    assumptions */
1905                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1906 #ifdef NV_PRESERVES_UV
1907                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1908                                   (SvNV(sv) > (NV)IV_MAX)))
1909                         ||
1910                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1911                                      (SvNV(right) < (NV)IV_MIN))))
1912 #else
1913                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1914                                   ||
1915                                   ((SvNV(sv) > 0) &&
1916                                         ((SvUV(sv) > (UV)IV_MAX) ||
1917                                          (SvNV(sv) > (NV)UV_MAX)))))
1918                         ||
1919                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1920                                      ||
1921                                      ((SvNV(right) > 0) &&
1922                                         ((SvUV(right) > (UV)IV_MAX) ||
1923                                          (SvNV(right) > (NV)UV_MAX))))))
1924 #endif
1925                     DIE(aTHX_ "Range iterator outside integer range");
1926                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1927                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1928 #ifdef DEBUGGING
1929                 /* for correct -Dstv display */
1930                 cx->blk_oldsp = sp - PL_stack_base;
1931 #endif
1932             }
1933             else {
1934                 cx->cx_type &= ~CXTYPEMASK;
1935                 cx->cx_type |= CXt_LOOP_LAZYSV;
1936                 /* Make sure that no-one re-orders cop.h and breaks our
1937                    assumptions */
1938                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1939                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1940                 cx->blk_loop.state_u.lazysv.end = right;
1941                 SvREFCNT_inc(right);
1942                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1943                 /* This will do the upgrade to SVt_PV, and warn if the value
1944                    is uninitialised.  */
1945                 (void) SvPV_nolen_const(right);
1946                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1947                    to replace !SvOK() with a pointer to "".  */
1948                 if (!SvOK(right)) {
1949                     SvREFCNT_dec(right);
1950                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1951                 }
1952             }
1953         }
1954         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1955             cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1956             SvREFCNT_inc(maybe_ary);
1957             cx->blk_loop.state_u.ary.ix =
1958                 (PL_op->op_private & OPpITER_REVERSED) ?
1959                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1960                 -1;
1961         }
1962     }
1963     else { /* iterating over items on the stack */
1964         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1965         if (PL_op->op_private & OPpITER_REVERSED) {
1966             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1967         }
1968         else {
1969             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1970         }
1971     }
1972
1973     RETURN;
1974 }
1975
1976 PP(pp_enterloop)
1977 {
1978     dVAR; dSP;
1979     register PERL_CONTEXT *cx;
1980     const I32 gimme = GIMME_V;
1981
1982     ENTER;
1983     SAVETMPS;
1984     ENTER;
1985
1986     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1987     PUSHLOOP_PLAIN(cx, SP);
1988
1989     RETURN;
1990 }
1991
1992 PP(pp_leaveloop)
1993 {
1994     dVAR; dSP;
1995     register PERL_CONTEXT *cx;
1996     I32 gimme;
1997     SV **newsp;
1998     PMOP *newpm;
1999     SV **mark;
2000
2001     POPBLOCK(cx,newpm);
2002     assert(CxTYPE_is_LOOP(cx));
2003     mark = newsp;
2004     newsp = PL_stack_base + cx->blk_loop.resetsp;
2005
2006     TAINT_NOT;
2007     if (gimme == G_VOID)
2008         NOOP;
2009     else if (gimme == G_SCALAR) {
2010         if (mark < SP)
2011             *++newsp = sv_mortalcopy(*SP);
2012         else
2013             *++newsp = &PL_sv_undef;
2014     }
2015     else {
2016         while (mark < SP) {
2017             *++newsp = sv_mortalcopy(*++mark);
2018             TAINT_NOT;          /* Each item is independent */
2019         }
2020     }
2021     SP = newsp;
2022     PUTBACK;
2023
2024     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2025     PL_curpm = newpm;   /* ... and pop $1 et al */
2026
2027     LEAVE;
2028     LEAVE;
2029
2030     return NORMAL;
2031 }
2032
2033 PP(pp_return)
2034 {
2035     dVAR; dSP; dMARK;
2036     register PERL_CONTEXT *cx;
2037     bool popsub2 = FALSE;
2038     bool clear_errsv = FALSE;
2039     I32 gimme;
2040     SV **newsp;
2041     PMOP *newpm;
2042     I32 optype = 0;
2043     SV *sv;
2044     OP *retop;
2045
2046     const I32 cxix = dopoptosub(cxstack_ix);
2047
2048     if (cxix < 0) {
2049         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2050                                      * sort block, which is a CXt_NULL
2051                                      * not a CXt_SUB */
2052             dounwind(0);
2053             PL_stack_base[1] = *PL_stack_sp;
2054             PL_stack_sp = PL_stack_base + 1;
2055             return 0;
2056         }
2057         else
2058             DIE(aTHX_ "Can't return outside a subroutine");
2059     }
2060     if (cxix < cxstack_ix)
2061         dounwind(cxix);
2062
2063     if (CxMULTICALL(&cxstack[cxix])) {
2064         gimme = cxstack[cxix].blk_gimme;
2065         if (gimme == G_VOID)
2066             PL_stack_sp = PL_stack_base;
2067         else if (gimme == G_SCALAR) {
2068             PL_stack_base[1] = *PL_stack_sp;
2069             PL_stack_sp = PL_stack_base + 1;
2070         }
2071         return 0;
2072     }
2073
2074     POPBLOCK(cx,newpm);
2075     switch (CxTYPE(cx)) {
2076     case CXt_SUB:
2077         popsub2 = TRUE;
2078         retop = cx->blk_sub.retop;
2079         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2080         break;
2081     case CXt_EVAL:
2082         if (!(PL_in_eval & EVAL_KEEPERR))
2083             clear_errsv = TRUE;
2084         POPEVAL(cx);
2085         retop = cx->blk_eval.retop;
2086         if (CxTRYBLOCK(cx))
2087             break;
2088         lex_end();
2089         if (optype == OP_REQUIRE &&
2090             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2091         {
2092             /* Unassume the success we assumed earlier. */
2093             SV * const nsv = cx->blk_eval.old_namesv;
2094             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2095             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2096         }
2097         break;
2098     case CXt_FORMAT:
2099         POPFORMAT(cx);
2100         retop = cx->blk_sub.retop;
2101         break;
2102     default:
2103         DIE(aTHX_ "panic: return");
2104     }
2105
2106     TAINT_NOT;
2107     if (gimme == G_SCALAR) {
2108         if (MARK < SP) {
2109             if (popsub2) {
2110                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2111                     if (SvTEMP(TOPs)) {
2112                         *++newsp = SvREFCNT_inc(*SP);
2113                         FREETMPS;
2114                         sv_2mortal(*newsp);
2115                     }
2116                     else {
2117                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2118                         FREETMPS;
2119                         *++newsp = sv_mortalcopy(sv);
2120                         SvREFCNT_dec(sv);
2121                     }
2122                 }
2123                 else
2124                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2125             }
2126             else
2127                 *++newsp = sv_mortalcopy(*SP);
2128         }
2129         else
2130             *++newsp = &PL_sv_undef;
2131     }
2132     else if (gimme == G_ARRAY) {
2133         while (++MARK <= SP) {
2134             *++newsp = (popsub2 && SvTEMP(*MARK))
2135                         ? *MARK : sv_mortalcopy(*MARK);
2136             TAINT_NOT;          /* Each item is independent */
2137         }
2138     }
2139     PL_stack_sp = newsp;
2140
2141     LEAVE;
2142     /* Stack values are safe: */
2143     if (popsub2) {
2144         cxstack_ix--;
2145         POPSUB(cx,sv);  /* release CV and @_ ... */
2146     }
2147     else
2148         sv = NULL;
2149     PL_curpm = newpm;   /* ... and pop $1 et al */
2150
2151     LEAVESUB(sv);
2152     if (clear_errsv)
2153         sv_setpvn(ERRSV,"",0);
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         sv_setpvn(ERRSV,"",0);
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             sv_setpvn(ERRSV,"",0);
3778     }
3779
3780     RETURNOP(retop);
3781 }
3782
3783 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3784    close to the related Perl_create_eval_scope.  */
3785 void
3786 Perl_delete_eval_scope(pTHX)
3787 {
3788     SV **newsp;
3789     PMOP *newpm;
3790     I32 gimme;
3791     register PERL_CONTEXT *cx;
3792     I32 optype;
3793
3794     POPBLOCK(cx,newpm);
3795     POPEVAL(cx);
3796     PL_curpm = newpm;
3797     LEAVE;
3798     PERL_UNUSED_VAR(newsp);
3799     PERL_UNUSED_VAR(gimme);
3800     PERL_UNUSED_VAR(optype);
3801 }
3802
3803 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3804    also needed by Perl_fold_constants.  */
3805 PERL_CONTEXT *
3806 Perl_create_eval_scope(pTHX_ U32 flags)
3807 {
3808     PERL_CONTEXT *cx;
3809     const I32 gimme = GIMME_V;
3810
3811     ENTER;
3812     SAVETMPS;
3813
3814     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3815     PUSHEVAL(cx, 0);
3816
3817     PL_in_eval = EVAL_INEVAL;
3818     if (flags & G_KEEPERR)
3819         PL_in_eval |= EVAL_KEEPERR;
3820     else
3821         sv_setpvn(ERRSV,"",0);
3822     if (flags & G_FAKINGEVAL) {
3823         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3824     }
3825     return cx;
3826 }
3827
3828 PP(pp_entertry)
3829 {
3830     dVAR;
3831     PERL_CONTEXT * const cx = create_eval_scope(0);
3832     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3833     return DOCATCH(PL_op->op_next);
3834 }
3835
3836 PP(pp_leavetry)
3837 {
3838     dVAR; dSP;
3839     SV **newsp;
3840     PMOP *newpm;
3841     I32 gimme;
3842     register PERL_CONTEXT *cx;
3843     I32 optype;
3844
3845     POPBLOCK(cx,newpm);
3846     POPEVAL(cx);
3847     PERL_UNUSED_VAR(optype);
3848
3849     TAINT_NOT;
3850     if (gimme == G_VOID)
3851         SP = newsp;
3852     else if (gimme == G_SCALAR) {
3853         register SV **mark;
3854         MARK = newsp + 1;
3855         if (MARK <= SP) {
3856             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3857                 *MARK = TOPs;
3858             else
3859                 *MARK = sv_mortalcopy(TOPs);
3860         }
3861         else {
3862             MEXTEND(mark,0);
3863             *MARK = &PL_sv_undef;
3864         }
3865         SP = MARK;
3866     }
3867     else {
3868         /* in case LEAVE wipes old return values */
3869         register SV **mark;
3870         for (mark = newsp + 1; mark <= SP; mark++) {
3871             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3872                 *mark = sv_mortalcopy(*mark);
3873                 TAINT_NOT;      /* Each item is independent */
3874             }
3875         }
3876     }
3877     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3878
3879     LEAVE;
3880     sv_setpvn(ERRSV,"",0);
3881     RETURN;
3882 }
3883
3884 PP(pp_entergiven)
3885 {
3886     dVAR; dSP;
3887     register PERL_CONTEXT *cx;
3888     const I32 gimme = GIMME_V;
3889
3890     ENTER;
3891     SAVETMPS;
3892
3893     if (PL_op->op_targ == 0) {
3894         SV ** const defsv_p = &GvSV(PL_defgv);
3895         *defsv_p = newSVsv(POPs);
3896         SAVECLEARSV(*defsv_p);
3897     }
3898     else
3899         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3900
3901     PUSHBLOCK(cx, CXt_GIVEN, SP);
3902     PUSHGIVEN(cx);
3903
3904     RETURN;
3905 }
3906
3907 PP(pp_leavegiven)
3908 {
3909     dVAR; dSP;
3910     register PERL_CONTEXT *cx;
3911     I32 gimme;
3912     SV **newsp;
3913     PMOP *newpm;
3914     PERL_UNUSED_CONTEXT;
3915
3916     POPBLOCK(cx,newpm);
3917     assert(CxTYPE(cx) == CXt_GIVEN);
3918
3919     SP = newsp;
3920     PUTBACK;
3921
3922     PL_curpm = newpm;   /* pop $1 et al */
3923
3924     LEAVE;
3925
3926     return NORMAL;
3927 }
3928
3929 /* Helper routines used by pp_smartmatch */
3930 STATIC PMOP *
3931 S_make_matcher(pTHX_ REGEXP *re)
3932 {
3933     dVAR;
3934     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3935
3936     PERL_ARGS_ASSERT_MAKE_MATCHER;
3937
3938     PM_SETRE(matcher, ReREFCNT_inc(re));
3939
3940     SAVEFREEOP((OP *) matcher);
3941     ENTER; SAVETMPS;
3942     SAVEOP();
3943     return matcher;
3944 }
3945
3946 STATIC bool
3947 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3948 {
3949     dVAR;
3950     dSP;
3951
3952     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3953
3954     PL_op = (OP *) matcher;
3955     XPUSHs(sv);
3956     PUTBACK;
3957     (void) pp_match();
3958     SPAGAIN;
3959     return (SvTRUEx(POPs));
3960 }
3961
3962 STATIC void
3963 S_destroy_matcher(pTHX_ PMOP *matcher)
3964 {
3965     dVAR;
3966
3967     PERL_ARGS_ASSERT_DESTROY_MATCHER;
3968     PERL_UNUSED_ARG(matcher);
3969
3970     FREETMPS;
3971     LEAVE;
3972 }
3973
3974 /* Do a smart match */
3975 PP(pp_smartmatch)
3976 {
3977     return do_smartmatch(NULL, NULL);
3978 }
3979
3980 /* This version of do_smartmatch() implements the
3981  * table of smart matches that is found in perlsyn.
3982  */
3983 STATIC OP *
3984 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3985 {
3986     dVAR;
3987     dSP;
3988
3989     SV *e = TOPs;       /* e is for 'expression' */
3990     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3991     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3992     REGEXP *this_regex, *other_regex;
3993
3994 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3995
3996 #   define SM_REF(type) ( \
3997            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3998         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3999
4000 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
4001         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
4002             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
4003         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
4004             && NOT_EMPTY_PROTO(This) && (Other = d)))
4005
4006 #   define SM_REGEX ( \
4007            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
4008         && (this_regex = (REGEXP*) This)                                \
4009         && (Other = e))                                                 \
4010     ||                                                                  \
4011            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
4012         && (this_regex = (REGEXP*) This)                                \
4013         && (Other = d)) )
4014
4015
4016 #   define SM_OTHER_REF(type) \
4017         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4018
4019 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
4020         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
4021         && (other_regex = (REGEXP*) SvRV(Other)))
4022
4023
4024 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4025         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4026
4027 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4028         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4029
4030     tryAMAGICbinSET(smart, 0);
4031
4032     SP -= 2;    /* Pop the values */
4033
4034     /* Take care only to invoke mg_get() once for each argument.
4035      * Currently we do this by copying the SV if it's magical. */
4036     if (d) {
4037         if (SvGMAGICAL(d))
4038             d = sv_mortalcopy(d);
4039     }
4040     else
4041         d = &PL_sv_undef;
4042
4043     assert(e);
4044     if (SvGMAGICAL(e))
4045         e = sv_mortalcopy(e);
4046
4047     if (SM_CV_NEP) {
4048         I32 c;
4049
4050         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4051         {
4052             if (This == SvRV(Other))
4053                 RETPUSHYES;
4054             else
4055                 RETPUSHNO;
4056         }
4057
4058         ENTER;
4059         SAVETMPS;
4060         PUSHMARK(SP);
4061         PUSHs(Other);
4062         PUTBACK;
4063         c = call_sv(This, G_SCALAR);
4064         SPAGAIN;
4065         if (c == 0)
4066             PUSHs(&PL_sv_no);
4067         else if (SvTEMP(TOPs))
4068             SvREFCNT_inc_void(TOPs);
4069         FREETMPS;
4070         LEAVE;
4071         RETURN;
4072     }
4073     else if (SM_REF(PVHV)) {
4074         if (SM_OTHER_REF(PVHV)) {
4075             /* Check that the key-sets are identical */
4076             HE *he;
4077             HV *other_hv = (HV *) SvRV(Other);
4078             bool tied = FALSE;
4079             bool other_tied = FALSE;
4080             U32 this_key_count  = 0,
4081                 other_key_count = 0;
4082
4083             /* Tied hashes don't know how many keys they have. */
4084             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4085                 tied = TRUE;
4086             }
4087             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4088                 HV * const temp = other_hv;
4089                 other_hv = (HV *) This;
4090                 This  = (SV *) temp;
4091                 tied = TRUE;
4092             }
4093             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4094                 other_tied = TRUE;
4095
4096             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4097                 RETPUSHNO;
4098
4099             /* The hashes have the same number of keys, so it suffices
4100                to check that one is a subset of the other. */
4101             (void) hv_iterinit((HV *) This);
4102             while ( (he = hv_iternext((HV *) This)) ) {
4103                 I32 key_len;
4104                 char * const key = hv_iterkey(he, &key_len);
4105
4106                 ++ this_key_count;
4107
4108                 if(!hv_exists(other_hv, key, key_len)) {
4109                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4110                     RETPUSHNO;
4111                 }
4112             }
4113
4114             if (other_tied) {
4115                 (void) hv_iterinit(other_hv);
4116                 while ( hv_iternext(other_hv) )
4117                     ++other_key_count;
4118             }
4119             else
4120                 other_key_count = HvUSEDKEYS(other_hv);
4121
4122             if (this_key_count != other_key_count)
4123                 RETPUSHNO;
4124             else
4125                 RETPUSHYES;
4126         }
4127         else if (SM_OTHER_REF(PVAV)) {
4128             AV * const other_av = (AV *) SvRV(Other);
4129             const I32 other_len = av_len(other_av) + 1;
4130             I32 i;
4131
4132             for (i = 0; i < other_len; ++i) {
4133                 SV ** const svp = av_fetch(other_av, i, FALSE);
4134                 char *key;
4135                 STRLEN key_len;
4136
4137                 if (svp) {      /* ??? When can this not happen? */
4138                     key = SvPV(*svp, key_len);
4139                     if (hv_exists((HV *) This, key, key_len))
4140                         RETPUSHYES;
4141                 }
4142             }
4143             RETPUSHNO;
4144         }
4145         else if (SM_OTHER_REGEX) {
4146             PMOP * const matcher = make_matcher(other_regex);
4147             HE *he;
4148
4149             (void) hv_iterinit((HV *) This);
4150             while ( (he = hv_iternext((HV *) This)) ) {
4151                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4152                     (void) hv_iterinit((HV *) This);
4153                     destroy_matcher(matcher);
4154                     RETPUSHYES;
4155                 }
4156             }
4157             destroy_matcher(matcher);
4158             RETPUSHNO;
4159         }
4160         else {
4161             if (hv_exists_ent((HV *) This, Other, 0))
4162                 RETPUSHYES;
4163             else
4164                 RETPUSHNO;
4165         }
4166     }
4167     else if (SM_REF(PVAV)) {
4168         if (SM_OTHER_REF(PVAV)) {
4169             AV *other_av = (AV *) SvRV(Other);
4170             if (av_len((AV *) This) != av_len(other_av))
4171                 RETPUSHNO;
4172             else {
4173                 I32 i;
4174                 const I32 other_len = av_len(other_av);
4175
4176                 if (NULL == seen_this) {
4177                     seen_this = newHV();
4178                     (void) sv_2mortal((SV *) seen_this);
4179                 }
4180                 if (NULL == seen_other) {
4181                     seen_this = newHV();
4182                     (void) sv_2mortal((SV *) seen_other);
4183                 }
4184                 for(i = 0; i <= other_len; ++i) {
4185                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4186                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4187
4188                     if (!this_elem || !other_elem) {
4189                         if (this_elem || other_elem)
4190                             RETPUSHNO;
4191                     }
4192                     else if (SM_SEEN_THIS(*this_elem)
4193                          || SM_SEEN_OTHER(*other_elem))
4194                     {
4195                         if (*this_elem != *other_elem)
4196                             RETPUSHNO;
4197                     }
4198                     else {
4199                         (void)hv_store_ent(seen_this,
4200                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4201                                 &PL_sv_undef, 0);
4202                         (void)hv_store_ent(seen_other,
4203                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4204                                 &PL_sv_undef, 0);
4205                         PUSHs(*this_elem);
4206                         PUSHs(*other_elem);
4207
4208                         PUTBACK;
4209                         (void) do_smartmatch(seen_this, seen_other);
4210                         SPAGAIN;
4211
4212                         if (!SvTRUEx(POPs))
4213                             RETPUSHNO;
4214                     }
4215                 }
4216                 RETPUSHYES;
4217             }
4218         }
4219         else if (SM_OTHER_REGEX) {
4220             PMOP * const matcher = make_matcher(other_regex);
4221             const I32 this_len = av_len((AV *) This);
4222             I32 i;
4223
4224             for(i = 0; i <= this_len; ++i) {
4225                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4226                 if (svp && matcher_matches_sv(matcher, *svp)) {
4227                     destroy_matcher(matcher);
4228                     RETPUSHYES;
4229                 }
4230             }
4231             destroy_matcher(matcher);
4232             RETPUSHNO;
4233         }
4234         else if (SvIOK(Other) || SvNOK(Other)) {
4235             I32 i;
4236
4237             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4238                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4239                 if (!svp)
4240                     continue;
4241
4242                 PUSHs(Other);
4243                 PUSHs(*svp);
4244                 PUTBACK;
4245                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4246                     (void) pp_i_eq();
4247                 else
4248                     (void) pp_eq();
4249                 SPAGAIN;
4250                 if (SvTRUEx(POPs))
4251                     RETPUSHYES;
4252             }
4253             RETPUSHNO;
4254         }
4255         else if (SvPOK(Other)) {
4256             const I32 this_len = av_len((AV *) This);
4257             I32 i;
4258
4259             for(i = 0; i <= this_len; ++i) {
4260                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4261                 if (!svp)
4262                     continue;
4263
4264                 PUSHs(Other);
4265                 PUSHs(*svp);
4266                 PUTBACK;
4267                 (void) pp_seq();
4268                 SPAGAIN;
4269                 if (SvTRUEx(POPs))
4270                     RETPUSHYES;
4271             }
4272             RETPUSHNO;
4273         }
4274     }
4275     else if (!SvOK(d) || !SvOK(e)) {
4276         if (!SvOK(d) && !SvOK(e))
4277             RETPUSHYES;
4278         else
4279             RETPUSHNO;
4280     }
4281     else if (SM_REGEX) {
4282         PMOP * const matcher = make_matcher(this_regex);
4283
4284         PUTBACK;
4285         PUSHs(matcher_matches_sv(matcher, Other)
4286             ? &PL_sv_yes
4287             : &PL_sv_no);
4288         destroy_matcher(matcher);
4289         RETURN;
4290     }
4291     else if (SM_REF(PVCV)) {
4292         I32 c;
4293         /* This must be a null-prototyped sub, because we
4294            already checked for the other kind. */
4295
4296         ENTER;
4297         SAVETMPS;
4298         PUSHMARK(SP);
4299         PUTBACK;
4300         c = call_sv(This, G_SCALAR);
4301         SPAGAIN;
4302         if (c == 0)
4303             PUSHs(&PL_sv_undef);
4304         else if (SvTEMP(TOPs))
4305             SvREFCNT_inc_void(TOPs);
4306
4307         if (SM_OTHER_REF(PVCV)) {
4308             /* This one has to be null-proto'd too.
4309                Call both of 'em, and compare the results */
4310             PUSHMARK(SP);
4311             c = call_sv(SvRV(Other), G_SCALAR);
4312             SPAGAIN;
4313             if (c == 0)
4314                 PUSHs(&PL_sv_undef);
4315             else if (SvTEMP(TOPs))
4316                 SvREFCNT_inc_void(TOPs);
4317             FREETMPS;
4318             LEAVE;
4319             PUTBACK;
4320             return pp_eq();
4321         }
4322
4323         FREETMPS;
4324         LEAVE;
4325         RETURN;
4326     }
4327     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4328          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4329     {
4330         if (SvPOK(Other) && !looks_like_number(Other)) {
4331             /* String comparison */
4332             PUSHs(d); PUSHs(e);
4333             PUTBACK;
4334             return pp_seq();
4335         }
4336         /* Otherwise, numeric comparison */
4337         PUSHs(d); PUSHs(e);
4338         PUTBACK;
4339         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4340             (void) pp_i_eq();
4341         else
4342             (void) pp_eq();
4343         SPAGAIN;
4344         if (SvTRUEx(POPs))
4345             RETPUSHYES;
4346         else
4347             RETPUSHNO;
4348     }
4349
4350     /* As a last resort, use string comparison */
4351     PUSHs(d); PUSHs(e);
4352     PUTBACK;
4353     return pp_seq();
4354 }
4355
4356 PP(pp_enterwhen)
4357 {
4358     dVAR; dSP;
4359     register PERL_CONTEXT *cx;
4360     const I32 gimme = GIMME_V;
4361
4362     /* This is essentially an optimization: if the match
4363        fails, we don't want to push a context and then
4364        pop it again right away, so we skip straight
4365        to the op that follows the leavewhen.
4366     */
4367     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4368         return cLOGOP->op_other->op_next;
4369
4370     ENTER;
4371     SAVETMPS;
4372
4373     PUSHBLOCK(cx, CXt_WHEN, SP);
4374     PUSHWHEN(cx);
4375
4376     RETURN;
4377 }
4378
4379 PP(pp_leavewhen)
4380 {
4381     dVAR; dSP;
4382     register PERL_CONTEXT *cx;
4383     I32 gimme;
4384     SV **newsp;
4385     PMOP *newpm;
4386
4387     POPBLOCK(cx,newpm);
4388     assert(CxTYPE(cx) == CXt_WHEN);
4389
4390     SP = newsp;
4391     PUTBACK;
4392
4393     PL_curpm = newpm;   /* pop $1 et al */
4394
4395     LEAVE;
4396     return NORMAL;
4397 }
4398
4399 PP(pp_continue)
4400 {
4401     dVAR;
4402     I32 cxix;
4403     register PERL_CONTEXT *cx;
4404     I32 inner;
4405
4406     cxix = dopoptowhen(cxstack_ix);
4407     if (cxix < 0)
4408         DIE(aTHX_ "Can't \"continue\" outside a when block");
4409     if (cxix < cxstack_ix)
4410         dounwind(cxix);
4411
4412     /* clear off anything above the scope we're re-entering */
4413     inner = PL_scopestack_ix;
4414     TOPBLOCK(cx);
4415     if (PL_scopestack_ix < inner)
4416         leave_scope(PL_scopestack[PL_scopestack_ix]);
4417     PL_curcop = cx->blk_oldcop;
4418     return cx->blk_givwhen.leave_op;
4419 }
4420
4421 PP(pp_break)
4422 {
4423     dVAR;
4424     I32 cxix;
4425     register PERL_CONTEXT *cx;
4426     I32 inner;
4427
4428     cxix = dopoptogiven(cxstack_ix);
4429     if (cxix < 0) {
4430         if (PL_op->op_flags & OPf_SPECIAL)
4431             DIE(aTHX_ "Can't use when() outside a topicalizer");
4432         else
4433             DIE(aTHX_ "Can't \"break\" outside a given block");
4434     }
4435     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4436         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4437
4438     if (cxix < cxstack_ix)
4439         dounwind(cxix);
4440
4441     /* clear off anything above the scope we're re-entering */
4442     inner = PL_scopestack_ix;
4443     TOPBLOCK(cx);
4444     if (PL_scopestack_ix < inner)
4445         leave_scope(PL_scopestack[PL_scopestack_ix]);
4446     PL_curcop = cx->blk_oldcop;
4447
4448     if (CxFOREACH(cx))
4449         return CX_LOOP_NEXTOP_GET(cx);
4450     else
4451         return cx->blk_givwhen.leave_op;
4452 }
4453
4454 STATIC OP *
4455 S_doparseform(pTHX_ SV *sv)
4456 {
4457     STRLEN len;
4458     register char *s = SvPV_force(sv, len);
4459     register char * const send = s + len;
4460     register char *base = NULL;
4461     register I32 skipspaces = 0;
4462     bool noblank   = FALSE;
4463     bool repeat    = FALSE;
4464     bool postspace = FALSE;
4465     U32 *fops;
4466     register U32 *fpc;
4467     U32 *linepc = NULL;
4468     register I32 arg;
4469     bool ischop;
4470     bool unchopnum = FALSE;
4471     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4472
4473     PERL_ARGS_ASSERT_DOPARSEFORM;
4474
4475     if (len == 0)
4476         Perl_croak(aTHX_ "Null picture in formline");
4477
4478     /* estimate the buffer size needed */
4479     for (base = s; s <= send; s++) {
4480         if (*s == '\n' || *s == '@' || *s == '^')
4481             maxops += 10;
4482     }
4483     s = base;
4484     base = NULL;
4485
4486     Newx(fops, maxops, U32);
4487     fpc = fops;
4488
4489     if (s < send) {
4490         linepc = fpc;
4491         *fpc++ = FF_LINEMARK;
4492         noblank = repeat = FALSE;
4493         base = s;
4494     }
4495
4496     while (s <= send) {
4497         switch (*s++) {
4498         default:
4499             skipspaces = 0;
4500             continue;
4501
4502         case '~':
4503             if (*s == '~') {
4504                 repeat = TRUE;
4505                 *s = ' ';
4506             }
4507             noblank = TRUE;
4508             s[-1] = ' ';
4509             /* FALL THROUGH */
4510         case ' ': case '\t':
4511             skipspaces++;
4512             continue;
4513         case 0:
4514             if (s < send) {
4515                 skipspaces = 0;
4516                 continue;
4517             } /* else FALL THROUGH */
4518         case '\n':
4519             arg = s - base;
4520             skipspaces++;
4521             arg -= skipspaces;
4522             if (arg) {
4523                 if (postspace)
4524                     *fpc++ = FF_SPACE;
4525                 *fpc++ = FF_LITERAL;
4526                 *fpc++ = (U16)arg;
4527             }
4528             postspace = FALSE;
4529             if (s <= send)
4530                 skipspaces--;
4531             if (skipspaces) {
4532                 *fpc++ = FF_SKIP;
4533                 *fpc++ = (U16)skipspaces;
4534             }
4535             skipspaces = 0;
4536             if (s <= send)
4537                 *fpc++ = FF_NEWLINE;
4538             if (noblank) {
4539                 *fpc++ = FF_BLANK;
4540                 if (repeat)
4541                     arg = fpc - linepc + 1;
4542                 else
4543                     arg = 0;
4544                 *fpc++ = (U16)arg;
4545             }
4546             if (s < send) {
4547                 linepc = fpc;
4548                 *fpc++ = FF_LINEMARK;
4549                 noblank = repeat = FALSE;
4550                 base = s;
4551             }
4552             else
4553                 s++;
4554             continue;
4555
4556         case '@':
4557         case '^':
4558             ischop = s[-1] == '^';
4559
4560             if (postspace) {
4561                 *fpc++ = FF_SPACE;
4562                 postspace = FALSE;
4563             }
4564             arg = (s - base) - 1;
4565             if (arg) {
4566                 *fpc++ = FF_LITERAL;
4567                 *fpc++ = (U16)arg;
4568             }
4569
4570             base = s - 1;
4571             *fpc++ = FF_FETCH;
4572             if (*s == '*') {
4573                 s++;
4574                 *fpc++ = 2;  /* skip the @* or ^* */
4575                 if (ischop) {
4576                     *fpc++ = FF_LINESNGL;
4577                     *fpc++ = FF_CHOP;
4578                 } else
4579                     *fpc++ = FF_LINEGLOB;
4580             }
4581             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4582                 arg = ischop ? 512 : 0;
4583                 base = s - 1;
4584                 while (*s == '#')
4585                     s++;
4586                 if (*s == '.') {
4587                     const char * const f = ++s;
4588                     while (*s == '#')
4589                         s++;
4590                     arg |= 256 + (s - f);
4591                 }
4592                 *fpc++ = s - base;              /* fieldsize for FETCH */
4593                 *fpc++ = FF_DECIMAL;
4594                 *fpc++ = (U16)arg;
4595                 unchopnum |= ! ischop;
4596             }
4597             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4598                 arg = ischop ? 512 : 0;
4599                 base = s - 1;
4600                 s++;                                /* skip the '0' first */
4601                 while (*s == '#')
4602                     s++;
4603                 if (*s == '.') {
4604                     const char * const f = ++s;
4605                     while (*s == '#')
4606                         s++;
4607                     arg |= 256 + (s - f);
4608                 }
4609                 *fpc++ = s - base;                /* fieldsize for FETCH */
4610                 *fpc++ = FF_0DECIMAL;
4611                 *fpc++ = (U16)arg;
4612                 unchopnum |= ! ischop;
4613             }
4614             else {
4615                 I32 prespace = 0;
4616                 bool ismore = FALSE;
4617
4618                 if (*s == '>') {
4619                     while (*++s == '>') ;
4620                     prespace = FF_SPACE;
4621                 }
4622                 else if (*s == '|') {
4623                     while (*++s == '|') ;
4624                     prespace = FF_HALFSPACE;
4625                     postspace = TRUE;
4626                 }
4627                 else {
4628                     if (*s == '<')
4629                         while (*++s == '<') ;
4630                     postspace = TRUE;
4631                 }
4632                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4633                     s += 3;
4634                     ismore = TRUE;
4635                 }
4636                 *fpc++ = s - base;              /* fieldsize for FETCH */
4637
4638                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4639
4640                 if (prespace)
4641                     *fpc++ = (U16)prespace;
4642                 *fpc++ = FF_ITEM;
4643                 if (ismore)
4644                     *fpc++ = FF_MORE;
4645                 if (ischop)
4646                     *fpc++ = FF_CHOP;
4647             }
4648             base = s;
4649             skipspaces = 0;
4650             continue;
4651         }
4652     }
4653     *fpc++ = FF_END;
4654
4655     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4656     arg = fpc - fops;
4657     { /* need to jump to the next word */
4658         int z;
4659         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4660         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4661         s = SvPVX(sv) + SvCUR(sv) + z;
4662     }
4663     Copy(fops, s, arg, U32);
4664     Safefree(fops);
4665     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4666     SvCOMPILED_on(sv);
4667
4668     if (unchopnum && repeat)
4669         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4670     return 0;
4671 }
4672
4673
4674 STATIC bool
4675 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4676 {
4677     /* Can value be printed in fldsize chars, using %*.*f ? */
4678     NV pwr = 1;
4679     NV eps = 0.5;
4680     bool res = FALSE;
4681     int intsize = fldsize - (value < 0 ? 1 : 0);
4682
4683     if (frcsize & 256)
4684         intsize--;
4685     frcsize &= 255;
4686     intsize -= frcsize;
4687
4688     while (intsize--) pwr *= 10.0;
4689     while (frcsize--) eps /= 10.0;
4690
4691     if( value >= 0 ){
4692         if (value + eps >= pwr)
4693             res = TRUE;
4694     } else {
4695         if (value - eps <= -pwr)
4696             res = TRUE;
4697     }
4698     return res;
4699 }
4700
4701 static I32
4702 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4703 {
4704     dVAR;
4705     SV * const datasv = FILTER_DATA(idx);
4706     const int filter_has_file = IoLINES(datasv);
4707     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4708     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4709     int status = 0;
4710     SV *upstream;
4711     STRLEN got_len;
4712     const char *got_p = NULL;
4713     const char *prune_from = NULL;
4714     bool read_from_cache = FALSE;
4715     STRLEN umaxlen;
4716
4717     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4718
4719     assert(maxlen >= 0);
4720     umaxlen = maxlen;
4721
4722     /* I was having segfault trouble under Linux 2.2.5 after a
4723        parse error occured.  (Had to hack around it with a test
4724        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4725        not sure where the trouble is yet.  XXX */
4726
4727     if (IoFMT_GV(datasv)) {
4728         SV *const cache = (SV *)IoFMT_GV(datasv);
4729         if (SvOK(cache)) {
4730             STRLEN cache_len;
4731             const char *cache_p = SvPV(cache, cache_len);
4732             STRLEN take = 0;
4733
4734             if (umaxlen) {
4735                 /* Running in block mode and we have some cached data already.
4736                  */
4737                 if (cache_len >= umaxlen) {
4738                     /* In fact, so much data we don't even need to call
4739                        filter_read.  */
4740                     take = umaxlen;
4741                 }
4742             } else {
4743                 const char *const first_nl =
4744                     (const char *)memchr(cache_p, '\n', cache_len);
4745                 if (first_nl) {
4746                     take = first_nl + 1 - cache_p;
4747                 }
4748             }
4749             if (take) {
4750                 sv_catpvn(buf_sv, cache_p, take);
4751                 sv_chop(cache, cache_p + take);
4752                 /* Definately not EOF  */
4753                 return 1;
4754             }
4755
4756             sv_catsv(buf_sv, cache);
4757             if (umaxlen) {
4758                 umaxlen -= cache_len;
4759             }
4760             SvOK_off(cache);
4761             read_from_cache = TRUE;
4762         }
4763     }
4764
4765     /* Filter API says that the filter appends to the contents of the buffer.
4766        Usually the buffer is "", so the details don't matter. But if it's not,
4767        then clearly what it contains is already filtered by this filter, so we
4768        don't want to pass it in a second time.
4769        I'm going to use a mortal in case the upstream filter croaks.  */
4770     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4771         ? sv_newmortal() : buf_sv;
4772     SvUPGRADE(upstream, SVt_PV);
4773
4774     if (filter_has_file) {
4775         status = FILTER_READ(idx+1, upstream, 0);
4776     }
4777
4778     if (filter_sub && status >= 0) {
4779         dSP;
4780         int count;
4781
4782         ENTER;
4783         SAVE_DEFSV;
4784         SAVETMPS;
4785         EXTEND(SP, 2);
4786
4787         DEFSV = upstream;
4788         PUSHMARK(SP);
4789         mPUSHi(0);
4790         if (filter_state) {
4791             PUSHs(filter_state);
4792         }
4793         PUTBACK;
4794         count = call_sv(filter_sub, G_SCALAR);
4795         SPAGAIN;
4796
4797         if (count > 0) {
4798             SV *out = POPs;
4799             if (SvOK(out)) {
4800                 status = SvIV(out);
4801             }
4802         }
4803
4804         PUTBACK;
4805         FREETMPS;
4806         LEAVE;
4807     }
4808
4809     if(SvOK(upstream)) {
4810         got_p = SvPV(upstream, got_len);
4811         if (umaxlen) {
4812             if (got_len > umaxlen) {
4813                 prune_from = got_p + umaxlen;
4814             }
4815         } else {
4816             const char *const first_nl =
4817                 (const char *)memchr(got_p, '\n', got_len);
4818             if (first_nl && first_nl + 1 < got_p + got_len) {
4819                 /* There's a second line here... */
4820                 prune_from = first_nl + 1;
4821             }
4822         }
4823     }
4824     if (prune_from) {
4825         /* Oh. Too long. Stuff some in our cache.  */
4826         STRLEN cached_len = got_p + got_len - prune_from;
4827         SV *cache = (SV *)IoFMT_GV(datasv);
4828
4829         if (!cache) {
4830             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4831         } else if (SvOK(cache)) {
4832             /* Cache should be empty.  */
4833             assert(!SvCUR(cache));
4834         }
4835
4836         sv_setpvn(cache, prune_from, cached_len);
4837         /* If you ask for block mode, you may well split UTF-8 characters.
4838            "If it breaks, you get to keep both parts"
4839            (Your code is broken if you  don't put them back together again
4840            before something notices.) */
4841         if (SvUTF8(upstream)) {
4842             SvUTF8_on(cache);
4843         }
4844         SvCUR_set(upstream, got_len - cached_len);
4845         /* Can't yet be EOF  */
4846         if (status == 0)
4847             status = 1;
4848     }
4849
4850     /* If they are at EOF but buf_sv has something in it, then they may never
4851        have touched the SV upstream, so it may be undefined.  If we naively
4852        concatenate it then we get a warning about use of uninitialised value.
4853     */
4854     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4855         sv_catsv(buf_sv, upstream);
4856     }
4857
4858     if (status <= 0) {
4859         IoLINES(datasv) = 0;
4860         SvREFCNT_dec(IoFMT_GV(datasv));
4861         if (filter_state) {
4862             SvREFCNT_dec(filter_state);
4863             IoTOP_GV(datasv) = NULL;
4864         }
4865         if (filter_sub) {
4866             SvREFCNT_dec(filter_sub);
4867             IoBOTTOM_GV(datasv) = NULL;
4868         }
4869         filter_del(S_run_user_filter);
4870     }
4871     if (status == 0 && read_from_cache) {
4872         /* If we read some data from the cache (and by getting here it implies
4873            that we emptied the cache) then we aren't yet at EOF, and mustn't
4874            report that to our caller.  */
4875         return 1;
4876     }
4877     return status;
4878 }
4879
4880 /* perhaps someone can come up with a better name for
4881    this?  it is not really "absolute", per se ... */
4882 static bool
4883 S_path_is_absolute(const char *name)
4884 {
4885     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4886
4887     if (PERL_FILE_IS_ABSOLUTE(name)
4888 #ifdef MACOS_TRADITIONAL
4889         || (*name == ':')
4890 #else
4891         || (*name == '.' && (name[1] == '/' ||
4892                              (name[1] == '.' && name[2] == '/')))
4893 #endif
4894          )
4895     {
4896         return TRUE;
4897     }
4898     else
4899         return FALSE;
4900 }
4901
4902 /*
4903  * Local variables:
4904  * c-indentation-style: bsd
4905  * c-basic-offset: 4
4906  * indent-tabs-mode: t
4907  * End:
4908  *
4909  * ex: set ts=8 sts=4 sw=4 noet:
4910  */