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