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