pp_ctl.c

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