pp_ctl.c

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