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