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