pp_ctl.c

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