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