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 #if !defined(PERLIO_IS_STDIO)
3521     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3522 #else
3523     retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3524 #endif
3525 #ifdef WIN32
3526     /* EACCES stops the INC search early in pp_require to implement
3527        feature RT #113422 */
3528     if(!retio && errno == EACCES) { /* exists but probably a directory */
3529         int eno;
3530         st_rc = PerlLIO_stat(p, &st);
3531         if (st_rc >= 0) {
3532             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3533                 eno = 0;
3534             else
3535                 eno = EACCES;
3536             errno = eno;
3537         }
3538     }
3539 #endif
3540     return retio;
3541 }
3542
3543 #ifndef PERL_DISABLE_PMC
3544 STATIC PerlIO *
3545 S_doopen_pm(pTHX_ SV *name)
3546 {
3547     STRLEN namelen;
3548     const char *p = SvPV_const(name, namelen);
3549
3550     PERL_ARGS_ASSERT_DOOPEN_PM;
3551
3552     /* check the name before trying for the .pmc name to avoid the
3553      * warning referring to the .pmc which the user probably doesn't
3554      * know or care about
3555      */
3556     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3557         return NULL;
3558
3559     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3560         SV *const pmcsv = sv_newmortal();
3561         Stat_t pmcstat;
3562
3563         SvSetSV_nosteal(pmcsv,name);
3564         sv_catpvs(pmcsv, "c");
3565
3566         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3567             return check_type_and_open(pmcsv);
3568     }
3569     return check_type_and_open(name);
3570 }
3571 #else
3572 #  define doopen_pm(name) check_type_and_open(name)
3573 #endif /* !PERL_DISABLE_PMC */
3574
3575 /* require doesn't search for absolute names, or when the name is
3576    explicitly relative the current directory */
3577 PERL_STATIC_INLINE bool
3578 S_path_is_searchable(const char *name)
3579 {
3580     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3581
3582     if (PERL_FILE_IS_ABSOLUTE(name)
3583 #ifdef WIN32
3584         || (*name == '.' && ((name[1] == '/' ||
3585                              (name[1] == '.' && name[2] == '/'))
3586                          || (name[1] == '\\' ||
3587                              ( name[1] == '.' && name[2] == '\\')))
3588             )
3589 #else
3590         || (*name == '.' && (name[1] == '/' ||
3591                              (name[1] == '.' && name[2] == '/')))
3592 #endif
3593          )
3594     {
3595         return FALSE;
3596     }
3597     else
3598         return TRUE;
3599 }
3600
3601
3602 /* also used for: pp_dofile() */
3603
3604 PP(pp_require)
3605 {
3606     dSP;
3607     PERL_CONTEXT *cx;
3608     SV *sv;
3609     const char *name;
3610     STRLEN len;
3611     char * unixname;
3612     STRLEN unixlen;
3613 #ifdef VMS
3614     int vms_unixname = 0;
3615     char *unixdir;
3616 #endif
3617     const char *tryname = NULL;
3618     SV *namesv = NULL;
3619     const I32 gimme = GIMME_V;
3620     int filter_has_file = 0;
3621     PerlIO *tryrsfp = NULL;
3622     SV *filter_cache = NULL;
3623     SV *filter_state = NULL;
3624     SV *filter_sub = NULL;
3625     SV *hook_sv = NULL;
3626     OP *op;
3627     int saved_errno;
3628     bool path_searchable;
3629
3630     sv = POPs;
3631     SvGETMAGIC(sv);
3632     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3633         sv = sv_2mortal(new_version(sv));
3634         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3635             upg_version(PL_patchlevel, TRUE);
3636         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3637             if ( vcmp(sv,PL_patchlevel) <= 0 )
3638                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3639                     SVfARG(sv_2mortal(vnormal(sv))),
3640                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3641                 );
3642         }
3643         else {
3644             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3645                 I32 first = 0;
3646                 AV *lav;
3647                 SV * const req = SvRV(sv);
3648                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3649
3650                 /* get the left hand term */
3651                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3652
3653                 first  = SvIV(*av_fetch(lav,0,0));
3654                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3655                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3656                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3657                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3658                    ) {
3659                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3660                         "%"SVf", stopped",
3661                         SVfARG(sv_2mortal(vnormal(req))),
3662                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3663                     );
3664                 }
3665                 else { /* probably 'use 5.10' or 'use 5.8' */
3666                     SV *hintsv;
3667                     I32 second = 0;
3668
3669                     if (av_tindex(lav)>=1)
3670                         second = SvIV(*av_fetch(lav,1,0));
3671
3672                     second /= second >= 600  ? 100 : 10;
3673                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3674                                            (int)first, (int)second);
3675                     upg_version(hintsv, TRUE);
3676
3677                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3678                         "--this is only %"SVf", stopped",
3679                         SVfARG(sv_2mortal(vnormal(req))),
3680                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3681                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3682                     );
3683                 }
3684             }
3685         }
3686
3687         RETPUSHYES;
3688     }
3689     if (!SvOK(sv))
3690         DIE(aTHX_ "Missing or undefined argument to require");
3691     name = SvPV_nomg_const(sv, len);
3692     if (!(name && len > 0 && *name))
3693         DIE(aTHX_ "Missing or undefined argument to require");
3694
3695     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3696         DIE(aTHX_ "Can't locate %s:   %s",
3697             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3698                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3699             Strerror(ENOENT));
3700     }
3701     TAINT_PROPER("require");
3702
3703     path_searchable = path_is_searchable(name);
3704
3705 #ifdef VMS
3706     /* The key in the %ENV hash is in the syntax of file passed as the argument
3707      * usually this is in UNIX format, but sometimes in VMS format, which
3708      * can result in a module being pulled in more than once.
3709      * To prevent this, the key must be stored in UNIX format if the VMS
3710      * name can be translated to UNIX.
3711      */
3712
3713     if ((unixname =
3714           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3715          != NULL) {
3716         unixlen = strlen(unixname);
3717         vms_unixname = 1;
3718     }
3719     else
3720 #endif
3721     {
3722         /* if not VMS or VMS name can not be translated to UNIX, pass it
3723          * through.
3724          */
3725         unixname = (char *) name;
3726         unixlen = len;
3727     }
3728     if (PL_op->op_type == OP_REQUIRE) {
3729         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3730                                           unixname, unixlen, 0);
3731         if ( svp ) {
3732             if (*svp != &PL_sv_undef)
3733                 RETPUSHYES;
3734             else
3735                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3736                             "Compilation failed in require", unixname);
3737         }
3738     }
3739
3740     LOADING_FILE_PROBE(unixname);
3741
3742     /* prepare to compile file */
3743
3744     if (!path_searchable) {
3745         /* At this point, name is SvPVX(sv)  */
3746         tryname = name;
3747         tryrsfp = doopen_pm(sv);
3748     }
3749     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3750         AV * const ar = GvAVn(PL_incgv);
3751         SSize_t i;
3752 #ifdef VMS
3753         if (vms_unixname)
3754 #endif
3755         {
3756             SV *nsv = sv;
3757             namesv = newSV_type(SVt_PV);
3758             for (i = 0; i <= AvFILL(ar); i++) {
3759                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3760
3761                 SvGETMAGIC(dirsv);
3762                 if (SvROK(dirsv)) {
3763                     int count;
3764                     SV **svp;
3765                     SV *loader = dirsv;
3766
3767                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3768                         && !SvOBJECT(SvRV(loader)))
3769                     {
3770                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3771                         SvGETMAGIC(loader);
3772                     }
3773
3774                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3775                                    PTR2UV(SvRV(dirsv)), name);
3776                     tryname = SvPVX_const(namesv);
3777                     tryrsfp = NULL;
3778
3779                     if (SvPADTMP(nsv)) {
3780                         nsv = sv_newmortal();
3781                         SvSetSV_nosteal(nsv,sv);
3782                     }
3783
3784                     ENTER_with_name("call_INC");
3785                     SAVETMPS;
3786                     EXTEND(SP, 2);
3787
3788                     PUSHMARK(SP);
3789                     PUSHs(dirsv);
3790                     PUSHs(nsv);
3791                     PUTBACK;
3792                     if (SvGMAGICAL(loader)) {
3793                         SV *l = sv_newmortal();
3794                         sv_setsv_nomg(l, loader);
3795                         loader = l;
3796                     }
3797                     if (sv_isobject(loader))
3798                         count = call_method("INC", G_ARRAY);
3799                     else
3800                         count = call_sv(loader, G_ARRAY);
3801                     SPAGAIN;
3802
3803                     if (count > 0) {
3804                         int i = 0;
3805                         SV *arg;
3806
3807                         SP -= count - 1;
3808                         arg = SP[i++];
3809
3810                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3811                             && !isGV_with_GP(SvRV(arg))) {
3812                             filter_cache = SvRV(arg);
3813
3814                             if (i < count) {
3815                                 arg = SP[i++];
3816                             }
3817                         }
3818
3819                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3820                             arg = SvRV(arg);
3821                         }
3822
3823                         if (isGV_with_GP(arg)) {
3824                             IO * const io = GvIO((const GV *)arg);
3825
3826                             ++filter_has_file;
3827
3828                             if (io) {
3829                                 tryrsfp = IoIFP(io);
3830                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3831                                     PerlIO_close(IoOFP(io));
3832                                 }
3833                                 IoIFP(io) = NULL;
3834                                 IoOFP(io) = NULL;
3835                             }
3836
3837                             if (i < count) {
3838                                 arg = SP[i++];
3839                             }
3840                         }
3841
3842                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3843                             filter_sub = arg;
3844                             SvREFCNT_inc_simple_void_NN(filter_sub);
3845
3846                             if (i < count) {
3847                                 filter_state = SP[i];
3848                                 SvREFCNT_inc_simple_void(filter_state);
3849                             }
3850                         }
3851
3852                         if (!tryrsfp && (filter_cache || filter_sub)) {
3853                             tryrsfp = PerlIO_open(BIT_BUCKET,
3854                                                   PERL_SCRIPT_MODE);
3855                         }
3856                         SP--;
3857                     }
3858
3859                     /* FREETMPS may free our filter_cache */
3860                     SvREFCNT_inc_simple_void(filter_cache);
3861
3862                     PUTBACK;
3863                     FREETMPS;
3864                     LEAVE_with_name("call_INC");
3865
3866                     /* Now re-mortalize it. */
3867                     sv_2mortal(filter_cache);
3868
3869                     /* Adjust file name if the hook has set an %INC entry.
3870                        This needs to happen after the FREETMPS above.  */
3871                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3872                     if (svp)
3873                         tryname = SvPV_nolen_const(*svp);
3874
3875                     if (tryrsfp) {
3876                         hook_sv = dirsv;
3877                         break;
3878                     }
3879
3880                     filter_has_file = 0;
3881                     filter_cache = NULL;
3882                     if (filter_state) {
3883                         SvREFCNT_dec_NN(filter_state);
3884                         filter_state = NULL;
3885                     }
3886                     if (filter_sub) {
3887                         SvREFCNT_dec_NN(filter_sub);
3888                         filter_sub = NULL;
3889                     }
3890                 }
3891                 else {
3892                   if (path_searchable) {
3893                     const char *dir;
3894                     STRLEN dirlen;
3895
3896                     if (SvOK(dirsv)) {
3897                         dir = SvPV_nomg_const(dirsv, dirlen);
3898                     } else {
3899                         dir = "";
3900                         dirlen = 0;
3901                     }
3902
3903                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3904                         continue;
3905 #ifdef VMS
3906                     if ((unixdir =
3907                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3908                          == NULL)
3909                         continue;
3910                     sv_setpv(namesv, unixdir);
3911                     sv_catpv(namesv, unixname);
3912 #else
3913 #  ifdef __SYMBIAN32__
3914                     if (PL_origfilename[0] &&
3915                         PL_origfilename[1] == ':' &&
3916                         !(dir[0] && dir[1] == ':'))
3917                         Perl_sv_setpvf(aTHX_ namesv,
3918                                        "%c:%s\\%s",
3919                                        PL_origfilename[0],
3920                                        dir, name);
3921                     else
3922                         Perl_sv_setpvf(aTHX_ namesv,
3923                                        "%s\\%s",
3924                                        dir, name);
3925 #  else
3926                     /* The equivalent of
3927                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3928                        but without the need to parse the format string, or
3929                        call strlen on either pointer, and with the correct
3930                        allocation up front.  */
3931                     {
3932                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3933
3934                         memcpy(tmp, dir, dirlen);
3935                         tmp +=dirlen;
3936
3937                         /* Avoid '<dir>//<file>' */
3938                         if (!dirlen || *(tmp-1) != '/') {
3939                             *tmp++ = '/';
3940                         } else {
3941                             /* So SvCUR_set reports the correct length below */
3942                             dirlen--;
3943                         }
3944
3945                         /* name came from an SV, so it will have a '\0' at the
3946                            end that we can copy as part of this memcpy().  */
3947                         memcpy(tmp, name, len + 1);
3948
3949                         SvCUR_set(namesv, dirlen + len + 1);
3950                         SvPOK_on(namesv);
3951                     }
3952 #  endif
3953 #endif
3954                     TAINT_PROPER("require");
3955                     tryname = SvPVX_const(namesv);
3956                     tryrsfp = doopen_pm(namesv);
3957                     if (tryrsfp) {
3958                         if (tryname[0] == '.' && tryname[1] == '/') {
3959                             ++tryname;
3960                             while (*++tryname == '/') {}
3961                         }
3962                         break;
3963                     }
3964                     else if (errno == EMFILE || errno == EACCES) {
3965                         /* no point in trying other paths if out of handles;
3966                          * on the other hand, if we couldn't open one of the
3967                          * files, then going on with the search could lead to
3968                          * unexpected results; see perl #113422
3969                          */
3970                         break;
3971                     }
3972                   }
3973                 }
3974             }
3975         }
3976     }
3977     saved_errno = errno; /* sv_2mortal can realloc things */
3978     sv_2mortal(namesv);
3979     if (!tryrsfp) {
3980         if (PL_op->op_type == OP_REQUIRE) {
3981             if(saved_errno == EMFILE || saved_errno == EACCES) {
3982                 /* diag_listed_as: Can't locate %s */
3983                 DIE(aTHX_ "Can't locate %s:   %s: %s",
3984                     name, tryname, Strerror(saved_errno));
3985             } else {
3986                 if (namesv) {                   /* did we lookup @INC? */
3987                     AV * const ar = GvAVn(PL_incgv);
3988                     SSize_t i;
3989                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
3990                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3991                     for (i = 0; i <= AvFILL(ar); i++) {
3992                         sv_catpvs(inc, " ");
3993                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3994                     }
3995                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3996                         const char *c, *e = name + len - 3;
3997                         sv_catpv(msg, " (you may need to install the ");
3998                         for (c = name; c < e; c++) {
3999                             if (*c == '/') {
4000                                 sv_catpvs(msg, "::");
4001                             }
4002                             else {
4003                                 sv_catpvn(msg, c, 1);
4004                             }
4005                         }
4006                         sv_catpv(msg, " module)");
4007                     }
4008                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4009                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4010                     }
4011                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4012                         sv_catpv(msg, " (did you run h2ph?)");
4013                     }
4014
4015                     /* diag_listed_as: Can't locate %s */
4016                     DIE(aTHX_
4017                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4018                         name, msg, inc);
4019                 }
4020             }
4021             DIE(aTHX_ "Can't locate %s", name);
4022         }
4023
4024         CLEAR_ERRSV();
4025         RETPUSHUNDEF;
4026     }
4027     else
4028         SETERRNO(0, SS_NORMAL);
4029
4030     /* Assume success here to prevent recursive requirement. */
4031     /* name is never assigned to again, so len is still strlen(name)  */
4032     /* Check whether a hook in @INC has already filled %INC */
4033     if (!hook_sv) {
4034         (void)hv_store(GvHVn(PL_incgv),
4035                        unixname, unixlen, newSVpv(tryname,0),0);
4036     } else {
4037         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4038         if (!svp)
4039             (void)hv_store(GvHVn(PL_incgv),
4040                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4041     }
4042
4043     ENTER_with_name("eval");
4044     SAVETMPS;
4045     SAVECOPFILE_FREE(&PL_compiling);
4046     CopFILE_set(&PL_compiling, tryname);
4047     lex_start(NULL, tryrsfp, 0);
4048
4049     if (filter_sub || filter_cache) {
4050         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4051            than hanging another SV from it. In turn, filter_add() optionally
4052            takes the SV to use as the filter (or creates a new SV if passed
4053            NULL), so simply pass in whatever value filter_cache has.  */
4054         SV * const fc = filter_cache ? newSV(0) : NULL;
4055         SV *datasv;
4056         if (fc) sv_copypv(fc, filter_cache);
4057         datasv = filter_add(S_run_user_filter, fc);
4058         IoLINES(datasv) = filter_has_file;
4059         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4060         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4061     }
4062
4063     /* switch to eval mode */
4064     PUSHBLOCK(cx, CXt_EVAL, SP);
4065     PUSHEVAL(cx, name);
4066     cx->blk_eval.retop = PL_op->op_next;
4067
4068     SAVECOPLINE(&PL_compiling);
4069     CopLINE_set(&PL_compiling, 0);
4070
4071     PUTBACK;
4072
4073     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4074         op = DOCATCH(PL_eval_start);
4075     else
4076         op = PL_op->op_next;
4077
4078     LOADED_FILE_PROBE(unixname);
4079
4080     return op;
4081 }
4082
4083 /* This is a op added to hold the hints hash for
4084    pp_entereval. The hash can be modified by the code
4085    being eval'ed, so we return a copy instead. */
4086
4087 PP(pp_hintseval)
4088 {
4089     dSP;
4090     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4091     RETURN;
4092 }
4093
4094
4095 PP(pp_entereval)
4096 {
4097     dSP;
4098     PERL_CONTEXT *cx;
4099     SV *sv;
4100     const I32 gimme = GIMME_V;
4101     const U32 was = PL_breakable_sub_gen;
4102     char tbuf[TYPE_DIGITS(long) + 12];
4103     bool saved_delete = FALSE;
4104     char *tmpbuf = tbuf;
4105     STRLEN len;
4106     CV* runcv;
4107     U32 seq, lex_flags = 0;
4108     HV *saved_hh = NULL;
4109     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4110
4111     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4112         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4113     }
4114     else if (PL_hints & HINT_LOCALIZE_HH || (
4115                 PL_op->op_private & OPpEVAL_COPHH
4116              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4117             )) {
4118         saved_hh = cop_hints_2hv(PL_curcop, 0);
4119         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4120     }
4121     sv = POPs;
4122     if (!SvPOK(sv)) {
4123         /* make sure we've got a plain PV (no overload etc) before testing
4124          * for taint. Making a copy here is probably overkill, but better
4125          * safe than sorry */
4126         STRLEN len;
4127         const char * const p = SvPV_const(sv, len);
4128
4129         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4130         lex_flags |= LEX_START_COPIED;
4131
4132         if (bytes && SvUTF8(sv))
4133             SvPVbyte_force(sv, len);
4134     }
4135     else if (bytes && SvUTF8(sv)) {
4136         /* Don't modify someone else's scalar */
4137         STRLEN len;
4138         sv = newSVsv(sv);
4139         (void)sv_2mortal(sv);
4140         SvPVbyte_force(sv,len);
4141         lex_flags |= LEX_START_COPIED;
4142     }
4143
4144     TAINT_IF(SvTAINTED(sv));
4145     TAINT_PROPER("eval");
4146
4147     ENTER_with_name("eval");
4148     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4149                            ? LEX_IGNORE_UTF8_HINTS
4150                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4151                         )
4152              );
4153     SAVETMPS;
4154
4155     /* switch to eval mode */
4156
4157     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4158         SV * const temp_sv = sv_newmortal();
4159         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4160                        (unsigned long)++PL_evalseq,
4161                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4162         tmpbuf = SvPVX(temp_sv);
4163         len = SvCUR(temp_sv);
4164     }
4165     else
4166         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4167     SAVECOPFILE_FREE(&PL_compiling);
4168     CopFILE_set(&PL_compiling, tmpbuf+2);
4169     SAVECOPLINE(&PL_compiling);
4170     CopLINE_set(&PL_compiling, 1);
4171     /* special case: an eval '' executed within the DB package gets lexically
4172      * placed in the first non-DB CV rather than the current CV - this
4173      * allows the debugger to execute code, find lexicals etc, in the
4174      * scope of the code being debugged. Passing &seq gets find_runcv
4175      * to do the dirty work for us */
4176     runcv = find_runcv(&seq);
4177
4178     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4179     PUSHEVAL(cx, 0);
4180     cx->blk_eval.retop = PL_op->op_next;
4181
4182     /* prepare to compile string */
4183
4184     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4185         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4186     else {
4187         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4188            deleting the eval's FILEGV from the stash before gv_check() runs
4189            (i.e. before run-time proper). To work around the coredump that
4190            ensues, we always turn GvMULTI_on for any globals that were
4191            introduced within evals. See force_ident(). GSAR 96-10-12 */
4192         char *const safestr = savepvn(tmpbuf, len);
4193         SAVEDELETE(PL_defstash, safestr, len);
4194         saved_delete = TRUE;
4195     }
4196
4197     PUTBACK;
4198
4199     if (doeval(gimme, runcv, seq, saved_hh)) {
4200         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4201             ?  PERLDB_LINE_OR_SAVESRC
4202             :  PERLDB_SAVESRC_NOSUBS) {
4203             /* Retain the filegv we created.  */
4204         } else if (!saved_delete) {
4205             char *const safestr = savepvn(tmpbuf, len);
4206             SAVEDELETE(PL_defstash, safestr, len);
4207         }
4208         return DOCATCH(PL_eval_start);
4209     } else {
4210         /* We have already left the scope set up earlier thanks to the LEAVE
4211            in doeval().  */
4212         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4213             ?  PERLDB_LINE_OR_SAVESRC
4214             :  PERLDB_SAVESRC_INVALID) {
4215             /* Retain the filegv we created.  */
4216         } else if (!saved_delete) {
4217             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4218         }
4219         return PL_op->op_next;
4220     }
4221 }
4222
4223 PP(pp_leaveeval)
4224 {
4225     dSP;
4226     SV **newsp;
4227     PMOP *newpm;
4228     I32 gimme;
4229     PERL_CONTEXT *cx;
4230     OP *retop;
4231     I32 optype;
4232     SV *namesv;
4233     CV *evalcv;
4234     /* grab this value before POPEVAL restores old PL_in_eval */
4235     bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4236
4237     PERL_ASYNC_CHECK();
4238     POPBLOCK(cx,newpm);
4239     POPEVAL(cx);
4240     namesv = cx->blk_eval.old_namesv;
4241     retop = cx->blk_eval.retop;
4242     evalcv = cx->blk_eval.cv;
4243
4244     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4245                                 gimme, SVs_TEMP, FALSE);
4246     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4247
4248 #ifdef DEBUGGING
4249     assert(CvDEPTH(evalcv) == 1);
4250 #endif
4251     CvDEPTH(evalcv) = 0;
4252
4253     if (optype == OP_REQUIRE &&
4254         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4255     {
4256         /* Unassume the success we assumed earlier. */
4257         (void)hv_delete(GvHVn(PL_incgv),
4258                         SvPVX_const(namesv),
4259                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4260                         G_DISCARD);
4261         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4262         NOT_REACHED; /* NOTREACHED */
4263         /* die_unwind() did LEAVE, or we won't be here */
4264     }
4265     else {
4266         LEAVE_with_name("eval");
4267         if (!keep)
4268             CLEAR_ERRSV();
4269     }
4270
4271     RETURNOP(retop);
4272 }
4273
4274 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4275    close to the related Perl_create_eval_scope.  */
4276 void
4277 Perl_delete_eval_scope(pTHX)
4278 {
4279     SV **newsp;
4280     PMOP *newpm;
4281     I32 gimme;
4282     PERL_CONTEXT *cx;
4283     I32 optype;
4284
4285     POPBLOCK(cx,newpm);
4286     POPEVAL(cx);
4287     PL_curpm = newpm;
4288     LEAVE_with_name("eval_scope");
4289     PERL_UNUSED_VAR(newsp);
4290     PERL_UNUSED_VAR(gimme);
4291     PERL_UNUSED_VAR(optype);
4292 }
4293
4294 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4295    also needed by Perl_fold_constants.  */
4296 PERL_CONTEXT *
4297 Perl_create_eval_scope(pTHX_ U32 flags)
4298 {
4299     PERL_CONTEXT *cx;
4300     const I32 gimme = GIMME_V;
4301
4302     ENTER_with_name("eval_scope");
4303     SAVETMPS;
4304
4305     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4306     PUSHEVAL(cx, 0);
4307
4308     PL_in_eval = EVAL_INEVAL;
4309     if (flags & G_KEEPERR)
4310         PL_in_eval |= EVAL_KEEPERR;
4311     else
4312         CLEAR_ERRSV();
4313     if (flags & G_FAKINGEVAL) {
4314         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4315     }
4316     return cx;
4317 }
4318
4319 PP(pp_entertry)
4320 {
4321     PERL_CONTEXT * const cx = create_eval_scope(0);
4322     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4323     return DOCATCH(PL_op->op_next);
4324 }
4325
4326 PP(pp_leavetry)
4327 {
4328     dSP;
4329     SV **newsp;
4330     PMOP *newpm;
4331     I32 gimme;
4332     PERL_CONTEXT *cx;
4333     I32 optype;
4334     OP *retop;
4335
4336     PERL_ASYNC_CHECK();
4337     POPBLOCK(cx,newpm);
4338     retop = cx->blk_eval.retop;
4339     POPEVAL(cx);
4340     PERL_UNUSED_VAR(optype);
4341
4342     SP = leave_common(newsp, SP, newsp, gimme,
4343                                SVs_PADTMP|SVs_TEMP, FALSE);
4344     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4345
4346     LEAVE_with_name("eval_scope");
4347     CLEAR_ERRSV();
4348     RETURNOP(retop);
4349 }
4350
4351 PP(pp_entergiven)
4352 {
4353     dSP;
4354     PERL_CONTEXT *cx;
4355     const I32 gimme = GIMME_V;
4356
4357     ENTER_with_name("given");
4358     SAVETMPS;
4359
4360     if (PL_op->op_targ) {
4361         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4362         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4363         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4364     }
4365     else {
4366         SAVE_DEFSV;
4367         DEFSV_set(POPs);
4368     }
4369
4370     PUSHBLOCK(cx, CXt_GIVEN, SP);
4371     PUSHGIVEN(cx);
4372
4373     RETURN;
4374 }
4375
4376 PP(pp_leavegiven)
4377 {
4378     dSP;
4379     PERL_CONTEXT *cx;
4380     I32 gimme;
4381     SV **newsp;
4382     PMOP *newpm;
4383     PERL_UNUSED_CONTEXT;
4384
4385     POPBLOCK(cx,newpm);
4386     assert(CxTYPE(cx) == CXt_GIVEN);
4387
4388     SP = leave_common(newsp, SP, newsp, gimme,
4389                                SVs_PADTMP|SVs_TEMP, FALSE);
4390     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4391
4392     LEAVE_with_name("given");
4393     RETURN;
4394 }
4395
4396 /* Helper routines used by pp_smartmatch */
4397 STATIC PMOP *
4398 S_make_matcher(pTHX_ REGEXP *re)
4399 {
4400     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4401
4402     PERL_ARGS_ASSERT_MAKE_MATCHER;
4403
4404     PM_SETRE(matcher, ReREFCNT_inc(re));
4405
4406     SAVEFREEOP((OP *) matcher);
4407     ENTER_with_name("matcher"); SAVETMPS;
4408     SAVEOP();
4409     return matcher;
4410 }
4411
4412 STATIC bool
4413 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4414 {
4415     dSP;
4416     bool result;
4417
4418     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4419
4420     PL_op = (OP *) matcher;
4421     XPUSHs(sv);
4422     PUTBACK;
4423     (void) Perl_pp_match(aTHX);
4424     SPAGAIN;
4425     result = SvTRUEx(POPs);
4426     PUTBACK;
4427
4428     return result;
4429 }
4430
4431 STATIC void
4432 S_destroy_matcher(pTHX_ PMOP *matcher)
4433 {
4434     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4435     PERL_UNUSED_ARG(matcher);
4436
4437     FREETMPS;
4438     LEAVE_with_name("matcher");
4439 }
4440
4441 /* Do a smart match */
4442 PP(pp_smartmatch)
4443 {
4444     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4445     return do_smartmatch(NULL, NULL, 0);
4446 }
4447
4448 /* This version of do_smartmatch() implements the
4449  * table of smart matches that is found in perlsyn.
4450  */
4451 STATIC OP *
4452 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4453 {
4454     dSP;
4455
4456     bool object_on_left = FALSE;
4457     SV *e = TOPs;       /* e is for 'expression' */
4458     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4459
4460     /* Take care only to invoke mg_get() once for each argument.
4461      * Currently we do this by copying the SV if it's magical. */
4462     if (d) {
4463         if (!copied && SvGMAGICAL(d))
4464             d = sv_mortalcopy(d);
4465     }
4466     else
4467         d = &PL_sv_undef;
4468
4469     assert(e);
4470     if (SvGMAGICAL(e))
4471         e = sv_mortalcopy(e);
4472
4473     /* First of all, handle overload magic of the rightmost argument */
4474     if (SvAMAGIC(e)) {
4475         SV * tmpsv;
4476         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4477         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4478
4479         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4480         if (tmpsv) {
4481             SPAGAIN;
4482             (void)POPs;
4483             SETs(tmpsv);
4484             RETURN;
4485         }
4486         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4487     }
4488
4489     SP -= 2;    /* Pop the values */
4490     PUTBACK;
4491
4492     /* ~~ undef */
4493     if (!SvOK(e)) {
4494         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4495         if (SvOK(d))
4496             RETPUSHNO;
4497         else
4498             RETPUSHYES;
4499     }
4500
4501     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4502         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4503         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4504     }
4505     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4506         object_on_left = TRUE;
4507
4508     /* ~~ sub */
4509     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4510         I32 c;
4511         if (object_on_left) {
4512             goto sm_any_sub; /* Treat objects like scalars */
4513         }
4514         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4515             /* Test sub truth for each key */
4516             HE *he;
4517             bool andedresults = TRUE;
4518             HV *hv = (HV*) SvRV(d);
4519             I32 numkeys = hv_iterinit(hv);
4520             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4521             if (numkeys == 0)
4522                 RETPUSHYES;
4523             while ( (he = hv_iternext(hv)) ) {
4524                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4525                 ENTER_with_name("smartmatch_hash_key_test");
4526                 SAVETMPS;
4527                 PUSHMARK(SP);
4528                 PUSHs(hv_iterkeysv(he));
4529                 PUTBACK;
4530                 c = call_sv(e, G_SCALAR);
4531                 SPAGAIN;
4532                 if (c == 0)
4533                     andedresults = FALSE;
4534                 else
4535                     andedresults = SvTRUEx(POPs) && andedresults;
4536                 FREETMPS;
4537                 LEAVE_with_name("smartmatch_hash_key_test");
4538             }
4539             if (andedresults)
4540                 RETPUSHYES;
4541             else
4542                 RETPUSHNO;
4543         }
4544         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4545             /* Test sub truth for each element */
4546             SSize_t i;
4547             bool andedresults = TRUE;
4548             AV *av = (AV*) SvRV(d);
4549             const I32 len = av_tindex(av);
4550             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4551             if (len == -1)
4552                 RETPUSHYES;
4553             for (i = 0; i <= len; ++i) {
4554                 SV * const * const svp = av_fetch(av, i, FALSE);
4555                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4556                 ENTER_with_name("smartmatch_array_elem_test");
4557                 SAVETMPS;
4558                 PUSHMARK(SP);
4559                 if (svp)
4560                     PUSHs(*svp);
4561                 PUTBACK;
4562                 c = call_sv(e, G_SCALAR);
4563                 SPAGAIN;
4564                 if (c == 0)
4565                     andedresults = FALSE;
4566                 else
4567                     andedresults = SvTRUEx(POPs) && andedresults;
4568                 FREETMPS;
4569                 LEAVE_with_name("smartmatch_array_elem_test");
4570             }
4571             if (andedresults)
4572                 RETPUSHYES;
4573             else
4574                 RETPUSHNO;
4575         }
4576         else {
4577           sm_any_sub:
4578             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4579             ENTER_with_name("smartmatch_coderef");
4580             SAVETMPS;
4581             PUSHMARK(SP);
4582             PUSHs(d);
4583             PUTBACK;
4584             c = call_sv(e, G_SCALAR);
4585             SPAGAIN;
4586             if (c == 0)
4587                 PUSHs(&PL_sv_no);
4588             else if (SvTEMP(TOPs))
4589                 SvREFCNT_inc_void(TOPs);
4590             FREETMPS;
4591             LEAVE_with_name("smartmatch_coderef");
4592             RETURN;
4593         }
4594     }
4595     /* ~~ %hash */
4596     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4597         if (object_on_left) {
4598             goto sm_any_hash; /* Treat objects like scalars */
4599         }
4600         else if (!SvOK(d)) {
4601             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4602             RETPUSHNO;
4603         }
4604         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4605             /* Check that the key-sets are identical */
4606             HE *he;
4607             HV *other_hv = MUTABLE_HV(SvRV(d));
4608             bool tied;
4609             bool other_tied;
4610             U32 this_key_count  = 0,
4611                 other_key_count = 0;
4612             HV *hv = MUTABLE_HV(SvRV(e));
4613
4614             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4615             /* Tied hashes don't know how many keys they have. */
4616             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4617             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4618             if (!tied ) {
4619                 if(other_tied) {
4620                     /* swap HV sides */
4621                     HV * const temp = other_hv;
4622                     other_hv = hv;
4623                     hv = temp;
4624                     tied = TRUE;
4625                     other_tied = FALSE;
4626                 }
4627                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4628                     RETPUSHNO;
4629             }
4630
4631             /* The hashes have the same number of keys, so it suffices
4632                to check that one is a subset of the other. */
4633             (void) hv_iterinit(hv);
4634             while ( (he = hv_iternext(hv)) ) {
4635                 SV *key = hv_iterkeysv(he);
4636
4637                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4638                 ++ this_key_count;
4639
4640                 if(!hv_exists_ent(other_hv, key, 0)) {
4641                     (void) hv_iterinit(hv);     /* reset iterator */
4642                     RETPUSHNO;
4643                 }
4644             }
4645
4646             if (other_tied) {
4647                 (void) hv_iterinit(other_hv);
4648                 while ( hv_iternext(other_hv) )
4649                     ++other_key_count;
4650             }
4651             else
4652                 other_key_count = HvUSEDKEYS(other_hv);
4653
4654             if (this_key_count != other_key_count)
4655                 RETPUSHNO;
4656             else
4657                 RETPUSHYES;
4658         }
4659         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4660             AV * const other_av = MUTABLE_AV(SvRV(d));
4661             const SSize_t other_len = av_tindex(other_av) + 1;
4662             SSize_t i;
4663             HV *hv = MUTABLE_HV(SvRV(e));
4664
4665             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4666             for (i = 0; i < other_len; ++i) {
4667                 SV ** const svp = av_fetch(other_av, i, FALSE);
4668                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4669                 if (svp) {      /* ??? When can this not happen? */
4670                     if (hv_exists_ent(hv, *svp, 0))
4671                         RETPUSHYES;
4672                 }
4673             }
4674             RETPUSHNO;
4675         }
4676         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4677             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4678           sm_regex_hash:
4679             {
4680                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4681                 HE *he;
4682                 HV *hv = MUTABLE_HV(SvRV(e));
4683
4684                 (void) hv_iterinit(hv);
4685                 while ( (he = hv_iternext(hv)) ) {
4686                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4687                     PUTBACK;
4688                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4689                         SPAGAIN;
4690                         (void) hv_iterinit(hv);
4691                         destroy_matcher(matcher);
4692                         RETPUSHYES;
4693                     }
4694                     SPAGAIN;
4695                 }
4696                 destroy_matcher(matcher);
4697                 RETPUSHNO;
4698             }
4699         }
4700         else {
4701           sm_any_hash:
4702             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4703             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4704                 RETPUSHYES;
4705             else
4706                 RETPUSHNO;
4707         }
4708     }
4709     /* ~~ @array */
4710     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4711         if (object_on_left) {
4712             goto sm_any_array; /* Treat objects like scalars */
4713         }
4714         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4715             AV * const other_av = MUTABLE_AV(SvRV(e));
4716             const SSize_t other_len = av_tindex(other_av) + 1;
4717             SSize_t i;
4718
4719             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4720             for (i = 0; i < other_len; ++i) {
4721                 SV ** const svp = av_fetch(other_av, i, FALSE);
4722
4723                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4724                 if (svp) {      /* ??? When can this not happen? */
4725                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4726                         RETPUSHYES;
4727                 }
4728             }
4729             RETPUSHNO;
4730         }
4731         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4732             AV *other_av = MUTABLE_AV(SvRV(d));
4733             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4734             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4735                 RETPUSHNO;
4736             else {
4737                 SSize_t i;
4738                 const SSize_t other_len = av_tindex(other_av);
4739
4740                 if (NULL == seen_this) {
4741                     seen_this = newHV();
4742                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4743                 }
4744                 if (NULL == seen_other) {
4745                     seen_other = newHV();
4746                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4747                 }
4748                 for(i = 0; i <= other_len; ++i) {
4749                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4750                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4751
4752                     if (!this_elem || !other_elem) {
4753                         if ((this_elem && SvOK(*this_elem))
4754                                 || (other_elem && SvOK(*other_elem)))
4755                             RETPUSHNO;
4756                     }
4757                     else if (hv_exists_ent(seen_this,
4758                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4759                             hv_exists_ent(seen_other,
4760                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4761                     {
4762                         if (*this_elem != *other_elem)
4763                             RETPUSHNO;
4764                     }
4765                     else {
4766                         (void)hv_store_ent(seen_this,
4767                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4768                                 &PL_sv_undef, 0);
4769                         (void)hv_store_ent(seen_other,
4770                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4771                                 &PL_sv_undef, 0);
4772                         PUSHs(*other_elem);
4773                         PUSHs(*this_elem);
4774
4775                         PUTBACK;
4776                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4777                         (void) do_smartmatch(seen_this, seen_other, 0);
4778                         SPAGAIN;
4779                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4780
4781                         if (!SvTRUEx(POPs))
4782                             RETPUSHNO;
4783                     }
4784                 }
4785                 RETPUSHYES;
4786             }
4787         }
4788         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4789             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4790           sm_regex_array:
4791             {
4792                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4793                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4794                 SSize_t i;
4795
4796                 for(i = 0; i <= this_len; ++i) {
4797                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4798                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4799                     PUTBACK;
4800                     if (svp && matcher_matches_sv(matcher, *svp)) {
4801                         SPAGAIN;
4802                         destroy_matcher(matcher);
4803                         RETPUSHYES;
4804                     }
4805                     SPAGAIN;
4806                 }
4807                 destroy_matcher(matcher);
4808                 RETPUSHNO;
4809             }
4810         }
4811         else if (!SvOK(d)) {
4812             /* undef ~~ array */
4813             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4814             SSize_t i;
4815
4816             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4817             for (i = 0; i <= this_len; ++i) {
4818                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4819                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4820                 if (!svp || !SvOK(*svp))
4821                     RETPUSHYES;
4822             }
4823             RETPUSHNO;
4824         }
4825         else {
4826           sm_any_array:
4827             {
4828                 SSize_t i;
4829                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4830
4831                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4832                 for (i = 0; i <= this_len; ++i) {
4833                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4834                     if (!svp)
4835                         continue;
4836
4837                     PUSHs(d);
4838                     PUSHs(*svp);
4839                     PUTBACK;
4840                     /* infinite recursion isn't supposed to happen here */
4841                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4842                     (void) do_smartmatch(NULL, NULL, 1);
4843                     SPAGAIN;
4844                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4845                     if (SvTRUEx(POPs))
4846                         RETPUSHYES;
4847                 }
4848                 RETPUSHNO;
4849             }
4850         }
4851     }
4852     /* ~~ qr// */
4853     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4854         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4855             SV *t = d; d = e; e = t;
4856             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4857             goto sm_regex_hash;
4858         }
4859         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4860             SV *t = d; d = e; e = t;
4861             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4862             goto sm_regex_array;
4863         }
4864         else {
4865             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4866             bool result;
4867
4868             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4869             PUTBACK;
4870             result = matcher_matches_sv(matcher, d);
4871             SPAGAIN;
4872             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4873             destroy_matcher(matcher);
4874             RETURN;
4875         }
4876     }
4877     /* ~~ scalar */
4878     /* See if there is overload magic on left */
4879     else if (object_on_left && SvAMAGIC(d)) {
4880         SV *tmpsv;
4881         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4882         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4883         PUSHs(d); PUSHs(e);
4884         PUTBACK;
4885         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4886         if (tmpsv) {
4887             SPAGAIN;
4888             (void)POPs;
4889             SETs(tmpsv);
4890             RETURN;
4891         }
4892         SP -= 2;
4893         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4894         goto sm_any_scalar;
4895     }
4896     else if (!SvOK(d)) {
4897         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4898         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4899         RETPUSHNO;
4900     }
4901     else
4902   sm_any_scalar:
4903     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4904         DEBUG_M(if (SvNIOK(e))
4905                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4906                 else
4907                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4908         );
4909         /* numeric comparison */
4910         PUSHs(d); PUSHs(e);
4911         PUTBACK;
4912         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4913             (void) Perl_pp_i_eq(aTHX);
4914         else
4915             (void) Perl_pp_eq(aTHX);
4916         SPAGAIN;
4917         if (SvTRUEx(POPs))
4918             RETPUSHYES;
4919         else
4920             RETPUSHNO;
4921     }
4922
4923     /* As a last resort, use string comparison */
4924     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4925     PUSHs(d); PUSHs(e);
4926     PUTBACK;
4927     return Perl_pp_seq(aTHX);
4928 }
4929
4930 PP(pp_enterwhen)
4931 {
4932     dSP;
4933     PERL_CONTEXT *cx;
4934     const I32 gimme = GIMME_V;
4935
4936     /* This is essentially an optimization: if the match
4937        fails, we don't want to push a context and then
4938        pop it again right away, so we skip straight
4939        to the op that follows the leavewhen.
4940        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4941     */
4942     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4943         RETURNOP(cLOGOP->op_other->op_next);
4944
4945     ENTER_with_name("when");
4946     SAVETMPS;
4947
4948     PUSHBLOCK(cx, CXt_WHEN, SP);
4949     PUSHWHEN(cx);
4950
4951     RETURN;
4952 }
4953
4954 PP(pp_leavewhen)
4955 {
4956     dSP;
4957     I32 cxix;
4958     PERL_CONTEXT *cx;
4959     I32 gimme;
4960     SV **newsp;
4961     PMOP *newpm;
4962
4963     cxix = dopoptogiven(cxstack_ix);
4964     if (cxix < 0)
4965         /* diag_listed_as: Can't "when" outside a topicalizer */
4966         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4967                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4968
4969     POPBLOCK(cx,newpm);
4970     assert(CxTYPE(cx) == CXt_WHEN);
4971
4972     SP = leave_common(newsp, SP, newsp, gimme,
4973                                SVs_PADTMP|SVs_TEMP, FALSE);
4974     PL_curpm = newpm;   /* pop $1 et al */
4975
4976     LEAVE_with_name("when");
4977
4978     if (cxix < cxstack_ix)
4979         dounwind(cxix);
4980
4981     cx = &cxstack[cxix];
4982
4983     if (CxFOREACH(cx)) {
4984         /* clear off anything above the scope we're re-entering */
4985         I32 inner = PL_scopestack_ix;
4986
4987         TOPBLOCK(cx);
4988         if (PL_scopestack_ix < inner)
4989             leave_scope(PL_scopestack[PL_scopestack_ix]);
4990         PL_curcop = cx->blk_oldcop;
4991
4992         PERL_ASYNC_CHECK();
4993         return cx->blk_loop.my_op->op_nextop;
4994     }
4995     else {
4996         PERL_ASYNC_CHECK();
4997         RETURNOP(cx->blk_givwhen.leave_op);
4998     }
4999 }
5000
5001 PP(pp_continue)
5002 {
5003     dSP;
5004     I32 cxix;
5005     PERL_CONTEXT *cx;
5006     I32 gimme;
5007     SV **newsp;
5008     PMOP *newpm;
5009
5010     PERL_UNUSED_VAR(gimme);
5011
5012     cxix = dopoptowhen(cxstack_ix);
5013     if (cxix < 0)
5014         DIE(aTHX_ "Can't \"continue\" outside a when block");
5015
5016     if (cxix < cxstack_ix)
5017         dounwind(cxix);
5018
5019     POPBLOCK(cx,newpm);
5020     assert(CxTYPE(cx) == CXt_WHEN);
5021
5022     SP = newsp;
5023     PL_curpm = newpm;   /* pop $1 et al */
5024
5025     LEAVE_with_name("when");
5026     RETURNOP(cx->blk_givwhen.leave_op->op_next);
5027 }
5028
5029 PP(pp_break)
5030 {
5031     I32 cxix;
5032     PERL_CONTEXT *cx;
5033
5034     cxix = dopoptogiven(cxstack_ix);
5035     if (cxix < 0)
5036         DIE(aTHX_ "Can't \"break\" outside a given block");
5037
5038     cx = &cxstack[cxix];
5039     if (CxFOREACH(cx))
5040         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5041
5042     if (cxix < cxstack_ix)
5043         dounwind(cxix);
5044
5045     /* Restore the sp at the time we entered the given block */
5046     TOPBLOCK(cx);
5047
5048     return cx->blk_givwhen.leave_op;
5049 }
5050
5051 static MAGIC *
5052 S_doparseform(pTHX_ SV *sv)
5053 {
5054     STRLEN len;
5055     char *s = SvPV(sv, len);
5056     char *send;
5057     char *base = NULL; /* start of current field */
5058     I32 skipspaces = 0; /* number of contiguous spaces seen */
5059     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5060     bool repeat    = FALSE; /* ~~ seen on this line */
5061     bool postspace = FALSE; /* a text field may need right padding */
5062     U32 *fops;
5063     U32 *fpc;
5064     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5065     I32 arg;
5066     bool ischop;            /* it's a ^ rather than a @ */
5067     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5068     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5069     MAGIC *mg = NULL;
5070     SV *sv_copy;
5071
5072     PERL_ARGS_ASSERT_DOPARSEFORM;
5073
5074     if (len == 0)
5075         Perl_croak(aTHX_ "Null picture in formline");
5076
5077     if (SvTYPE(sv) >= SVt_PVMG) {
5078         /* This might, of course, still return NULL.  */
5079         mg = mg_find(sv, PERL_MAGIC_fm);
5080     } else {
5081         sv_upgrade(sv, SVt_PVMG);
5082     }
5083
5084     if (mg) {
5085         /* still the same as previously-compiled string? */
5086         SV *old = mg->mg_obj;
5087         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5088               && len == SvCUR(old)
5089               && strnEQ(SvPVX(old), SvPVX(sv), len)
5090         ) {
5091             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5092             return mg;
5093         }
5094
5095         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5096         Safefree(mg->mg_ptr);
5097         mg->mg_ptr = NULL;
5098         SvREFCNT_dec(old);
5099         mg->mg_obj = NULL;
5100     }
5101     else {
5102         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5103         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5104     }
5105
5106     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5107     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5108     send = s + len;
5109
5110
5111     /* estimate the buffer size needed */
5112     for (base = s; s <= send; s++) {
5113         if (*s == '\n' || *s == '@' || *s == '^')
5114             maxops += 10;
5115     }
5116     s = base;
5117     base = NULL;
5118
5119     Newx(fops, maxops, U32);
5120     fpc = fops;
5121
5122     if (s < send) {
5123         linepc = fpc;
5124         *fpc++ = FF_LINEMARK;
5125         noblank = repeat = FALSE;
5126         base = s;
5127     }
5128
5129     while (s <= send) {
5130         switch (*s++) {
5131         default:
5132             skipspaces = 0;
5133             continue;
5134
5135         case '~':
5136             if (*s == '~') {
5137                 repeat = TRUE;
5138                 skipspaces++;
5139                 s++;
5140             }
5141             noblank = TRUE;
5142             /* FALLTHROUGH */
5143         case ' ': case '\t':
5144             skipspaces++;
5145             continue;
5146         case 0:
5147             if (s < send) {
5148                 skipspaces = 0;
5149                 continue;
5150             } /* else FALL THROUGH */
5151         case '\n':
5152             arg = s - base;
5153             skipspaces++;
5154             arg -= skipspaces;
5155             if (arg) {
5156                 if (postspace)
5157                     *fpc++ = FF_SPACE;
5158                 *fpc++ = FF_LITERAL;
5159                 *fpc++ = (U32)arg;
5160             }
5161             postspace = FALSE;
5162             if (s <= send)
5163                 skipspaces--;
5164             if (skipspaces) {
5165                 *fpc++ = FF_SKIP;
5166                 *fpc++ = (U32)skipspaces;
5167             }
5168             skipspaces = 0;
5169             if (s <= send)
5170                 *fpc++ = FF_NEWLINE;
5171             if (noblank) {
5172                 *fpc++ = FF_BLANK;
5173                 if (repeat)
5174                     arg = fpc - linepc + 1;
5175                 else
5176                     arg = 0;
5177                 *fpc++ = (U32)arg;
5178             }
5179             if (s < send) {
5180                 linepc = fpc;
5181                 *fpc++ = FF_LINEMARK;
5182                 noblank = repeat = FALSE;
5183                 base = s;
5184             }
5185             else
5186                 s++;
5187             continue;
5188
5189         case '@':
5190         case '^':
5191             ischop = s[-1] == '^';
5192
5193             if (postspace) {
5194                 *fpc++ = FF_SPACE;
5195                 postspace = FALSE;
5196             }
5197             arg = (s - base) - 1;
5198             if (arg) {
5199                 *fpc++ = FF_LITERAL;
5200                 *fpc++ = (U32)arg;
5201             }
5202
5203             base = s - 1;
5204             *fpc++ = FF_FETCH;
5205             if (*s == '*') { /*  @* or ^*  */
5206                 s++;
5207                 *fpc++ = 2;  /* skip the @* or ^* */
5208                 if (ischop) {
5209                     *fpc++ = FF_LINESNGL;
5210                     *fpc++ = FF_CHOP;
5211                 } else
5212                     *fpc++ = FF_LINEGLOB;
5213             }
5214             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5215                 arg = ischop ? FORM_NUM_BLANK : 0;
5216                 base = s - 1;
5217                 while (*s == '#')
5218                     s++;
5219                 if (*s == '.') {
5220                     const char * const f = ++s;
5221                     while (*s == '#')
5222                         s++;
5223                     arg |= FORM_NUM_POINT + (s - f);
5224                 }
5225                 *fpc++ = s - base;              /* fieldsize for FETCH */
5226                 *fpc++ = FF_DECIMAL;
5227                 *fpc++ = (U32)arg;
5228                 unchopnum |= ! ischop;
5229             }
5230             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5231                 arg = ischop ? FORM_NUM_BLANK : 0;
5232                 base = s - 1;
5233                 s++;                                /* skip the '0' first */
5234                 while (*s == '#')
5235                     s++;
5236                 if (*s == '.') {
5237                     const char * const f = ++s;
5238                     while (*s == '#')
5239                         s++;
5240                     arg |= FORM_NUM_POINT + (s - f);
5241                 }
5242                 *fpc++ = s - base;                /* fieldsize for FETCH */
5243                 *fpc++ = FF_0DECIMAL;
5244                 *fpc++ = (U32)arg;
5245                 unchopnum |= ! ischop;
5246             }
5247             else {                              /* text field */
5248                 I32 prespace = 0;
5249                 bool ismore = FALSE;
5250
5251                 if (*s == '>') {
5252                     while (*++s == '>') ;
5253                     prespace = FF_SPACE;
5254                 }
5255                 else if (*s == '|') {
5256                     while (*++s == '|') ;
5257                     prespace = FF_HALFSPACE;
5258                     postspace = TRUE;
5259                 }
5260                 else {
5261                     if (*s == '<')
5262                         while (*++s == '<') ;
5263                     postspace = TRUE;
5264                 }
5265                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5266                     s += 3;
5267                     ismore = TRUE;
5268                 }
5269                 *fpc++ = s - base;              /* fieldsize for FETCH */
5270
5271                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5272
5273                 if (prespace)
5274                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5275                 *fpc++ = FF_ITEM;
5276                 if (ismore)
5277                     *fpc++ = FF_MORE;
5278                 if (ischop)
5279                     *fpc++ = FF_CHOP;
5280             }
5281             base = s;
5282             skipspaces = 0;
5283             continue;
5284         }
5285     }
5286     *fpc++ = FF_END;
5287
5288     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5289     arg = fpc - fops;
5290
5291     mg->mg_ptr = (char *) fops;
5292     mg->mg_len = arg * sizeof(U32);
5293     mg->mg_obj = sv_copy;
5294     mg->mg_flags |= MGf_REFCOUNTED;
5295
5296     if (unchopnum && repeat)
5297         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5298
5299     return mg;
5300 }
5301
5302
5303 STATIC bool
5304 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5305 {
5306     /* Can value be printed in fldsize chars, using %*.*f ? */
5307     NV pwr = 1;
5308     NV eps = 0.5;
5309     bool res = FALSE;
5310     int intsize = fldsize - (value < 0 ? 1 : 0);
5311
5312     if (frcsize & FORM_NUM_POINT)
5313         intsize--;
5314     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5315     intsize -= frcsize;
5316
5317     while (intsize--) pwr *= 10.0;
5318     while (frcsize--) eps /= 10.0;
5319
5320     if( value >= 0 ){
5321         if (value + eps >= pwr)
5322             res = TRUE;
5323     } else {
5324         if (value - eps <= -pwr)
5325             res = TRUE;
5326     }
5327     return res;
5328 }
5329
5330 static I32
5331 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5332 {
5333     SV * const datasv = FILTER_DATA(idx);
5334     const int filter_has_file = IoLINES(datasv);
5335     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5336     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5337     int status = 0;
5338     SV *upstream;
5339     STRLEN got_len;
5340     char *got_p = NULL;
5341     char *prune_from = NULL;
5342     bool read_from_cache = FALSE;
5343     STRLEN umaxlen;
5344     SV *err = NULL;
5345
5346     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5347
5348     assert(maxlen >= 0);
5349     umaxlen = maxlen;
5350
5351     /* I was having segfault trouble under Linux 2.2.5 after a
5352        parse error occurred.  (Had to hack around it with a test
5353        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5354        not sure where the trouble is yet.  XXX */
5355
5356     {
5357         SV *const cache = datasv;
5358         if (SvOK(cache)) {
5359             STRLEN cache_len;
5360             const char *cache_p = SvPV(cache, cache_len);
5361             STRLEN take = 0;
5362
5363             if (umaxlen) {
5364                 /* Running in block mode and we have some cached data already.
5365                  */
5366                 if (cache_len >= umaxlen) {
5367                     /* In fact, so much data we don't even need to call
5368                        filter_read.  */
5369                     take = umaxlen;
5370                 }
5371             } else {
5372                 const char *const first_nl =
5373                     (const char *)memchr(cache_p, '\n', cache_len);
5374                 if (first_nl) {
5375                     take = first_nl + 1 - cache_p;
5376                 }
5377             }
5378             if (take) {
5379                 sv_catpvn(buf_sv, cache_p, take);
5380                 sv_chop(cache, cache_p + take);
5381                 /* Definitely not EOF  */
5382                 return 1;
5383             }
5384
5385             sv_catsv(buf_sv, cache);
5386             if (umaxlen) {
5387                 umaxlen -= cache_len;
5388             }
5389             SvOK_off(cache);
5390             read_from_cache = TRUE;
5391         }
5392     }
5393
5394     /* Filter API says that the filter appends to the contents of the buffer.
5395        Usually the buffer is "", so the details don't matter. But if it's not,
5396        then clearly what it contains is already filtered by this filter, so we
5397        don't want to pass it in a second time.
5398        I'm going to use a mortal in case the upstream filter croaks.  */
5399     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5400         ? sv_newmortal() : buf_sv;
5401     SvUPGRADE(upstream, SVt_PV);
5402
5403     if (filter_has_file) {
5404         status = FILTER_READ(idx+1, upstream, 0);
5405     }
5406
5407     if (filter_sub && status >= 0) {
5408         dSP;
5409         int count;
5410
5411         ENTER_with_name("call_filter_sub");
5412         SAVE_DEFSV;
5413         SAVETMPS;
5414         EXTEND(SP, 2);
5415
5416         DEFSV_set(upstream);
5417         PUSHMARK(SP);
5418         mPUSHi(0);
5419         if (filter_state) {
5420             PUSHs(filter_state);
5421         }
5422         PUTBACK;
5423         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5424         SPAGAIN;
5425
5426         if (count > 0) {
5427             SV *out = POPs;
5428             SvGETMAGIC(out);
5429             if (SvOK(out)) {
5430                 status = SvIV(out);
5431             }
5432             else {
5433                 SV * const errsv = ERRSV;
5434                 if (SvTRUE_NN(errsv))
5435                     err = newSVsv(errsv);
5436             }
5437         }
5438
5439         PUTBACK;
5440         FREETMPS;
5441         LEAVE_with_name("call_filter_sub");
5442     }
5443
5444     if (SvGMAGICAL(upstream)) {
5445         mg_get(upstream);
5446         if (upstream == buf_sv) mg_free(buf_sv);
5447     }
5448     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5449     if(!err && SvOK(upstream)) {
5450         got_p = SvPV_nomg(upstream, got_len);
5451         if (umaxlen) {
5452             if (got_len > umaxlen) {
5453                 prune_from = got_p + umaxlen;
5454             }
5455         } else {
5456             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5457             if (first_nl && first_nl + 1 < got_p + got_len) {
5458                 /* There's a second line here... */
5459                 prune_from = first_nl + 1;
5460             }
5461         }
5462     }
5463     if (!err && prune_from) {
5464         /* Oh. Too long. Stuff some in our cache.  */
5465         STRLEN cached_len = got_p + got_len - prune_from;
5466         SV *const cache = datasv;
5467
5468         if (SvOK(cache)) {
5469             /* Cache should be empty.  */
5470             assert(!SvCUR(cache));
5471         }
5472
5473         sv_setpvn(cache, prune_from, cached_len);
5474         /* If you ask for block mode, you may well split UTF-8 characters.
5475            "If it breaks, you get to keep both parts"
5476            (Your code is broken if you  don't put them back together again
5477            before something notices.) */
5478         if (SvUTF8(upstream)) {
5479             SvUTF8_on(cache);
5480         }
5481         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5482         else
5483             /* Cannot just use sv_setpvn, as that could free the buffer
5484                before we have a chance to assign it. */
5485             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5486                       got_len - cached_len);
5487         *prune_from = 0;
5488         /* Can't yet be EOF  */
5489         if (status == 0)
5490             status = 1;
5491     }
5492
5493     /* If they are at EOF but buf_sv has something in it, then they may never
5494        have touched the SV upstream, so it may be undefined.  If we naively
5495        concatenate it then we get a warning about use of uninitialised value.
5496     */
5497     if (!err && upstream != buf_sv &&
5498         SvOK(upstream)) {
5499         sv_catsv_nomg(buf_sv, upstream);
5500     }
5501     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5502
5503     if (status <= 0) {
5504         IoLINES(datasv) = 0;
5505         if (filter_state) {
5506             SvREFCNT_dec(filter_state);
5507             IoTOP_GV(datasv) = NULL;
5508         }
5509         if (filter_sub) {
5510             SvREFCNT_dec(filter_sub);
5511             IoBOTTOM_GV(datasv) = NULL;
5512         }
5513         filter_del(S_run_user_filter);
5514     }
5515
5516     if (err)
5517         croak_sv(err);
5518
5519     if (status == 0 && read_from_cache) {
5520         /* If we read some data from the cache (and by getting here it implies
5521            that we emptied the cache) then we aren't yet at EOF, and mustn't
5522            report that to our caller.  */
5523         return 1;
5524     }
5525     return status;
5526 }
5527
5528 /*
5529  * ex: set ts=8 sts=4 sw=4 et:
5530  */