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