pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 PP(pp_const)
  39 {
  40     dVAR;
  41     dSP;
  42     XPUSHs(cSVOP_sv);
  43     RETURN;
  44 }
  45
  46 PP(pp_nextstate)
  47 {
  48     dVAR;
  49     PL_curcop = (COP*)PL_op;
  50     TAINT_NOT;          /* Each statement is presumed innocent */
  51     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  52     FREETMPS;
  53     return NORMAL;
  54 }
  55
  56 PP(pp_gvsv)
  57 {
  58     dVAR;
  59     dSP;
  60     EXTEND(SP,1);
  61     if (PL_op->op_private & OPpLVAL_INTRO)
  62         PUSHs(save_scalar(cGVOP_gv));
  63     else
  64         PUSHs(GvSVn(cGVOP_gv));
  65     RETURN;
  66 }
  67
  68 PP(pp_null)
  69 {
  70     dVAR;
  71     return NORMAL;
  72 }
  73
  74 PP(pp_setstate)
  75 {
  76     dVAR;
  77     PL_curcop = (COP*)PL_op;
  78     return NORMAL;
  79 }
  80
  81 PP(pp_pushmark)
  82 {
  83     dVAR;
  84     PUSHMARK(PL_stack_sp);
  85     return NORMAL;
  86 }
  87
  88 PP(pp_stringify)
  89 {
  90     dVAR; dSP; dTARGET;
  91     sv_copypv(TARG,TOPs);
  92     SETTARG;
  93     RETURN;
  94 }
  95
  96 PP(pp_gv)
  97 {
  98     dVAR; dSP;
  99     XPUSHs((SV*)cGVOP_gv);
 100     RETURN;
 101 }
 102
 103 PP(pp_and)
 104 {
 105     dVAR; dSP;
 106     if (!SvTRUE(TOPs))
 107         RETURN;
 108     else {
 109         if (PL_op->op_type == OP_AND)
 110             --SP;
 111         RETURNOP(cLOGOP->op_other);
 112     }
 113 }
 114
 115 PP(pp_sassign)
 116 {
 117     dVAR; dSP; dPOPTOPssrl;
 118
 119     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 120         SV * const temp = left;
 121         left = right; right = temp;
 122     }
 123     else if (PL_op->op_private & OPpASSIGN_STATE) {
 124         if (SvPADSTALE(right))
 125             SvPADSTALE_off(right);
 126         else
 127             RETURN; /* ignore assignment */
 128     }
 129     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 130         TAINT_NOT;
 131     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 132         SV * const cv = SvRV(left);
 133         const U32 cv_type = SvTYPE(cv);
 134         const U32 gv_type = SvTYPE(right);
 135         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 136
 137         if (!got_coderef) {
 138             assert(SvROK(cv));
 139         }
 140
 141         /* Can do the optimisation if right (LVALUE) is not a typeglob,
 142            left (RVALUE) is a reference to something, and we're in void
 143            context. */
 144         if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 145             /* Is the target symbol table currently empty?  */
 146             GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
 147             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 148                 /* Good. Create a new proxy constant subroutine in the target.
 149                    The gv becomes a(nother) reference to the constant.  */
 150                 SV *const value = SvRV(cv);
 151
 152                 SvUPGRADE((SV *)gv, SVt_RV);
 153                 SvPCS_IMPORTED_on(gv);
 154                 SvRV_set(gv, value);
 155                 SvREFCNT_inc_simple_void(value);
 156                 SETs(right);
 157                 RETURN;
 158             }
 159         }
 160
 161         /* Need to fix things up.  */
 162         if (gv_type != SVt_PVGV) {
 163             /* Need to fix GV.  */
 164             right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
 165         }
 166
 167         if (!got_coderef) {
 168             /* We've been returned a constant rather than a full subroutine,
 169                but they expect a subroutine reference to apply.  */
 170             ENTER;
 171             SvREFCNT_inc_void(SvRV(cv));
 172             /* newCONSTSUB takes a reference count on the passed in SV
 173                from us.  We set the name to NULL, otherwise we get into
 174                all sorts of fun as the reference to our new sub is
 175                donated to the GV that we're about to assign to.
 176             */
 177             SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
 178                                                  SvRV(cv)));
 179             SvREFCNT_dec(cv);
 180             LEAVE;
 181         }
 182
 183         if (strEQ(GvNAME(right),"isa")) {
 184             GvCVGEN(right) = 0;
 185             ++PL_sub_generation;
 186         }
 187     }
 188     SvSetMagicSV(right, left);
 189     SETs(right);
 190     RETURN;
 191 }
 192
 193 PP(pp_cond_expr)
 194 {
 195     dVAR; dSP;
 196     if (SvTRUEx(POPs))
 197         RETURNOP(cLOGOP->op_other);
 198     else
 199         RETURNOP(cLOGOP->op_next);
 200 }
 201
 202 PP(pp_unstack)
 203 {
 204     dVAR;
 205     I32 oldsave;
 206     TAINT_NOT;          /* Each statement is presumed innocent */
 207     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 208     FREETMPS;
 209     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 210     LEAVE_SCOPE(oldsave);
 211     return NORMAL;
 212 }
 213
 214 PP(pp_concat)
 215 {
 216   dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 217   {
 218     dPOPTOPssrl;
 219     bool lbyte;
 220     STRLEN rlen;
 221     const char *rpv = NULL;
 222     bool rbyte = FALSE;
 223     bool rcopied = FALSE;
 224
 225     if (TARG == right && right != left) {
 226         /* mg_get(right) may happen here ... */
 227         rpv = SvPV_const(right, rlen);
 228         rbyte = !DO_UTF8(right);
 229         right = sv_2mortal(newSVpvn(rpv, rlen));
 230         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 231         rcopied = TRUE;
 232     }
 233
 234     if (TARG != left) {
 235         STRLEN llen;
 236         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 237         lbyte = !DO_UTF8(left);
 238         sv_setpvn(TARG, lpv, llen);
 239         if (!lbyte)
 240             SvUTF8_on(TARG);
 241         else
 242             SvUTF8_off(TARG);
 243     }
 244     else { /* TARG == left */
 245         STRLEN llen;
 246         SvGETMAGIC(left);               /* or mg_get(left) may happen here */
 247         if (!SvOK(TARG)) {
 248             if (left == right && ckWARN(WARN_UNINITIALIZED))
 249                 report_uninit(right);
 250             sv_setpvn(left, "", 0);
 251         }
 252         (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
 253         lbyte = !DO_UTF8(left);
 254         if (IN_BYTES)
 255             SvUTF8_off(TARG);
 256     }
 257
 258     /* or mg_get(right) may happen here */
 259     if (!rcopied) {
 260         rpv = SvPV_const(right, rlen);
 261         rbyte = !DO_UTF8(right);
 262     }
 263     if (lbyte != rbyte) {
 264         if (lbyte)
 265             sv_utf8_upgrade_nomg(TARG);
 266         else {
 267             if (!rcopied)
 268                 right = sv_2mortal(newSVpvn(rpv, rlen));
 269             sv_utf8_upgrade_nomg(right);
 270             rpv = SvPV_const(right, rlen);
 271         }
 272     }
 273     sv_catpvn_nomg(TARG, rpv, rlen);
 274
 275     SETTARG;
 276     RETURN;
 277   }
 278 }
 279
 280 PP(pp_padsv)
 281 {
 282     dVAR; dSP; dTARGET;
 283     XPUSHs(TARG);
 284     if (PL_op->op_flags & OPf_MOD) {
 285         if (PL_op->op_private & OPpLVAL_INTRO)
 286             if (!(PL_op->op_private & OPpPAD_STATE))
 287                 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 288         if (PL_op->op_private & OPpDEREF) {
 289             PUTBACK;
 290             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 291             SPAGAIN;
 292         }
 293     }
 294     RETURN;
 295 }
 296
 297 PP(pp_readline)
 298 {
 299     dVAR;
 300     tryAMAGICunTARGET(iter, 0);
 301     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 302     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 303         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 304             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 305         else {
 306             dSP;
 307             XPUSHs((SV*)PL_last_in_gv);
 308             PUTBACK;
 309             pp_rv2gv();
 310             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 311         }
 312     }
 313     return do_readline();
 314 }
 315
 316 PP(pp_eq)
 317 {
 318     dVAR; dSP; tryAMAGICbinSET(eq,0);
 319 #ifndef NV_PRESERVES_UV
 320     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 321         SP--;
 322         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 323         RETURN;
 324     }
 325 #endif
 326 #ifdef PERL_PRESERVE_IVUV
 327     SvIV_please(TOPs);
 328     if (SvIOK(TOPs)) {
 329         /* Unless the left argument is integer in range we are going
 330            to have to use NV maths. Hence only attempt to coerce the
 331            right argument if we know the left is integer.  */
 332       SvIV_please(TOPm1s);
 333         if (SvIOK(TOPm1s)) {
 334             const bool auvok = SvUOK(TOPm1s);
 335             const bool buvok = SvUOK(TOPs);
 336
 337             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 338                 /* Casting IV to UV before comparison isn't going to matter
 339                    on 2s complement. On 1s complement or sign&magnitude
 340                    (if we have any of them) it could to make negative zero
 341                    differ from normal zero. As I understand it. (Need to
 342                    check - is negative zero implementation defined behaviour
 343                    anyway?). NWC  */
 344                 const UV buv = SvUVX(POPs);
 345                 const UV auv = SvUVX(TOPs);
 346
 347                 SETs(boolSV(auv == buv));
 348                 RETURN;
 349             }
 350             {                   /* ## Mixed IV,UV ## */
 351                 SV *ivp, *uvp;
 352                 IV iv;
 353
 354                 /* == is commutative so doesn't matter which is left or right */
 355                 if (auvok) {
 356                     /* top of stack (b) is the iv */
 357                     ivp = *SP;
 358                     uvp = *--SP;
 359                 } else {
 360                     uvp = *SP;
 361                     ivp = *--SP;
 362                 }
 363                 iv = SvIVX(ivp);
 364                 if (iv < 0)
 365                     /* As uv is a UV, it's >0, so it cannot be == */
 366                     SETs(&PL_sv_no);
 367                 else
 368                     /* we know iv is >= 0 */
 369                     SETs(boolSV((UV)iv == SvUVX(uvp)));
 370                 RETURN;
 371             }
 372         }
 373     }
 374 #endif
 375     {
 376 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 377       dPOPTOPnnrl;
 378       if (Perl_isnan(left) || Perl_isnan(right))
 379           RETSETNO;
 380       SETs(boolSV(left == right));
 381 #else
 382       dPOPnv;
 383       SETs(boolSV(TOPn == value));
 384 #endif
 385       RETURN;
 386     }
 387 }
 388
 389 PP(pp_preinc)
 390 {
 391     dVAR; dSP;
 392     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 393         DIE(aTHX_ PL_no_modify);
 394     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 395         && SvIVX(TOPs) != IV_MAX)
 396     {
 397         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 398         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 399     }
 400     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 401         sv_inc(TOPs);
 402     SvSETMAGIC(TOPs);
 403     return NORMAL;
 404 }
 405
 406 PP(pp_or)
 407 {
 408     dVAR; dSP;
 409     if (SvTRUE(TOPs))
 410         RETURN;
 411     else {
 412         if (PL_op->op_type == OP_OR)
 413             --SP;
 414         RETURNOP(cLOGOP->op_other);
 415     }
 416 }
 417
 418 PP(pp_defined)
 419 {
 420     dVAR; dSP;
 421     register SV* sv;
 422     bool defined;
 423     const int op_type = PL_op->op_type;
 424     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 425
 426     if (is_dor) {
 427         sv = TOPs;
 428         if (!sv || !SvANY(sv)) {
 429             if (op_type == OP_DOR)
 430                 --SP;
 431             RETURNOP(cLOGOP->op_other);
 432         }
 433     } else if (op_type == OP_DEFINED) {
 434         sv = POPs;
 435         if (!sv || !SvANY(sv))
 436             RETPUSHNO;
 437     } else
 438         DIE(aTHX_ "panic:  Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
 439
 440     defined = FALSE;
 441     switch (SvTYPE(sv)) {
 442     case SVt_PVAV:
 443         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 444             defined = TRUE;
 445         break;
 446     case SVt_PVHV:
 447         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 448             defined = TRUE;
 449         break;
 450     case SVt_PVCV:
 451         if (CvROOT(sv) || CvXSUB(sv))
 452             defined = TRUE;
 453         break;
 454     default:
 455         SvGETMAGIC(sv);
 456         if (SvOK(sv))
 457             defined = TRUE;
 458         break;
 459     }
 460
 461     if (is_dor) {
 462         if(defined)
 463             RETURN;
 464         if(op_type == OP_DOR)
 465             --SP;
 466         RETURNOP(cLOGOP->op_other);
 467     }
 468     /* assuming OP_DEFINED */
 469     if(defined)
 470         RETPUSHYES;
 471     RETPUSHNO;
 472 }
 473
 474 PP(pp_add)
 475 {
 476     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
 477     useleft = USE_LEFT(TOPm1s);
 478 #ifdef PERL_PRESERVE_IVUV
 479     /* We must see if we can perform the addition with integers if possible,
 480        as the integer code detects overflow while the NV code doesn't.
 481        If either argument hasn't had a numeric conversion yet attempt to get
 482        the IV. It's important to do this now, rather than just assuming that
 483        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 484        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 485        integer in case the second argument is IV=9223372036854775806
 486        We can (now) rely on sv_2iv to do the right thing, only setting the
 487        public IOK flag if the value in the NV (or PV) slot is truly integer.
 488
 489        A side effect is that this also aggressively prefers integer maths over
 490        fp maths for integer values.
 491
 492        How to detect overflow?
 493
 494        C 99 section 6.2.6.1 says
 495
 496        The range of nonnegative values of a signed integer type is a subrange
 497        of the corresponding unsigned integer type, and the representation of
 498        the same value in each type is the same. A computation involving
 499        unsigned operands can never overflow, because a result that cannot be
 500        represented by the resulting unsigned integer type is reduced modulo
 501        the number that is one greater than the largest value that can be
 502        represented by the resulting type.
 503
 504        (the 9th paragraph)
 505
 506        which I read as "unsigned ints wrap."
 507
 508        signed integer overflow seems to be classed as "exception condition"
 509
 510        If an exceptional condition occurs during the evaluation of an
 511        expression (that is, if the result is not mathematically defined or not
 512        in the range of representable values for its type), the behavior is
 513        undefined.
 514
 515        (6.5, the 5th paragraph)
 516
 517        I had assumed that on 2s complement machines signed arithmetic would
 518        wrap, hence coded pp_add and pp_subtract on the assumption that
 519        everything perl builds on would be happy.  After much wailing and
 520        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 521        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 522        unsigned code below is actually shorter than the old code. :-)
 523     */
 524
 525     SvIV_please(TOPs);
 526     if (SvIOK(TOPs)) {
 527         /* Unless the left argument is integer in range we are going to have to
 528            use NV maths. Hence only attempt to coerce the right argument if
 529            we know the left is integer.  */
 530         register UV auv = 0;
 531         bool auvok = FALSE;
 532         bool a_valid = 0;
 533
 534         if (!useleft) {
 535             auv = 0;
 536             a_valid = auvok = 1;
 537             /* left operand is undef, treat as zero. + 0 is identity,
 538                Could SETi or SETu right now, but space optimise by not adding
 539                lots of code to speed up what is probably a rarish case.  */
 540         } else {
 541             /* Left operand is defined, so is it IV? */
 542             SvIV_please(TOPm1s);
 543             if (SvIOK(TOPm1s)) {
 544                 if ((auvok = SvUOK(TOPm1s)))
 545                     auv = SvUVX(TOPm1s);
 546                 else {
 547                     register const IV aiv = SvIVX(TOPm1s);
 548                     if (aiv >= 0) {
 549                         auv = aiv;
 550                         auvok = 1;      /* Now acting as a sign flag.  */
 551                     } else { /* 2s complement assumption for IV_MIN */
 552                         auv = (UV)-aiv;
 553                     }
 554                 }
 555                 a_valid = 1;
 556             }
 557         }
 558         if (a_valid) {
 559             bool result_good = 0;
 560             UV result;
 561             register UV buv;
 562             bool buvok = SvUOK(TOPs);
 563
 564             if (buvok)
 565                 buv = SvUVX(TOPs);
 566             else {
 567                 register const IV biv = SvIVX(TOPs);
 568                 if (biv >= 0) {
 569                     buv = biv;
 570                     buvok = 1;
 571                 } else
 572                     buv = (UV)-biv;
 573             }
 574             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 575                else "IV" now, independent of how it came in.
 576                if a, b represents positive, A, B negative, a maps to -A etc
 577                a + b =>  (a + b)
 578                A + b => -(a - b)
 579                a + B =>  (a - b)
 580                A + B => -(a + b)
 581                all UV maths. negate result if A negative.
 582                add if signs same, subtract if signs differ. */
 583
 584             if (auvok ^ buvok) {
 585                 /* Signs differ.  */
 586                 if (auv >= buv) {
 587                     result = auv - buv;
 588                     /* Must get smaller */
 589                     if (result <= auv)
 590                         result_good = 1;
 591                 } else {
 592                     result = buv - auv;
 593                     if (result <= buv) {
 594                         /* result really should be -(auv-buv). as its negation
 595                            of true value, need to swap our result flag  */
 596                         auvok = !auvok;
 597                         result_good = 1;
 598                     }
 599                 }
 600             } else {
 601                 /* Signs same */
 602                 result = auv + buv;
 603                 if (result >= auv)
 604                     result_good = 1;
 605             }
 606             if (result_good) {
 607                 SP--;
 608                 if (auvok)
 609                     SETu( result );
 610                 else {
 611                     /* Negate result */
 612                     if (result <= (UV)IV_MIN)
 613                         SETi( -(IV)result );
 614                     else {
 615                         /* result valid, but out of range for IV.  */
 616                         SETn( -(NV)result );
 617                     }
 618                 }
 619                 RETURN;
 620             } /* Overflow, drop through to NVs.  */
 621         }
 622     }
 623 #endif
 624     {
 625         dPOPnv;
 626         if (!useleft) {
 627             /* left operand is undef, treat as zero. + 0.0 is identity. */
 628             SETn(value);
 629             RETURN;
 630         }
 631         SETn( value + TOPn );
 632         RETURN;
 633     }
 634 }
 635
 636 PP(pp_aelemfast)
 637 {
 638     dVAR; dSP;
 639     AV * const av = PL_op->op_flags & OPf_SPECIAL ?
 640                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 641     const U32 lval = PL_op->op_flags & OPf_MOD;
 642     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 643     SV *sv = (svp ? *svp : &PL_sv_undef);
 644     EXTEND(SP, 1);
 645     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 646         sv = sv_mortalcopy(sv);
 647     PUSHs(sv);
 648     RETURN;
 649 }
 650
 651 PP(pp_join)
 652 {
 653     dVAR; dSP; dMARK; dTARGET;
 654     MARK++;
 655     do_join(TARG, *MARK, MARK, SP);
 656     SP = MARK;
 657     SETs(TARG);
 658     RETURN;
 659 }
 660
 661 PP(pp_pushre)
 662 {
 663     dVAR; dSP;
 664 #ifdef DEBUGGING
 665     /*
 666      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 667      * will be enough to hold an OP*.
 668      */
 669     SV* const sv = sv_newmortal();
 670     sv_upgrade(sv, SVt_PVLV);
 671     LvTYPE(sv) = '/';
 672     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 673     XPUSHs(sv);
 674 #else
 675     XPUSHs((SV*)PL_op);
 676 #endif
 677     RETURN;
 678 }
 679
 680 /* Oversized hot code. */
 681
 682 PP(pp_print)
 683 {
 684     dVAR; dSP; dMARK; dORIGMARK;
 685     IO *io;
 686     register PerlIO *fp;
 687     MAGIC *mg;
 688     GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
 689
 690     if (gv && (io = GvIO(gv))
 691         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 692     {
 693       had_magic:
 694         if (MARK == ORIGMARK) {
 695             /* If using default handle then we need to make space to
 696              * pass object as 1st arg, so move other args up ...
 697              */
 698             MEXTEND(SP, 1);
 699             ++MARK;
 700             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 701             ++SP;
 702         }
 703         PUSHMARK(MARK - 1);
 704         *MARK = SvTIED_obj((SV*)io, mg);
 705         PUTBACK;
 706         ENTER;
 707         call_method("PRINT", G_SCALAR);
 708         LEAVE;
 709         SPAGAIN;
 710         MARK = ORIGMARK + 1;
 711         *MARK = *SP;
 712         SP = MARK;
 713         RETURN;
 714     }
 715     if (!(io = GvIO(gv))) {
 716         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 717             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 718             goto had_magic;
 719         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 720             report_evil_fh(gv, io, PL_op->op_type);
 721         SETERRNO(EBADF,RMS_IFI);
 722         goto just_say_no;
 723     }
 724     else if (!(fp = IoOFP(io))) {
 725         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 726             if (IoIFP(io))
 727                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 728             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 729                 report_evil_fh(gv, io, PL_op->op_type);
 730         }
 731         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 732         goto just_say_no;
 733     }
 734     else {
 735         MARK++;
 736         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 737             while (MARK <= SP) {
 738                 if (!do_print(*MARK, fp))
 739                     break;
 740                 MARK++;
 741                 if (MARK <= SP) {
 742                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 743                         MARK--;
 744                         break;
 745                     }
 746                 }
 747             }
 748         }
 749         else {
 750             while (MARK <= SP) {
 751                 if (!do_print(*MARK, fp))
 752                     break;
 753                 MARK++;
 754             }
 755         }
 756         if (MARK <= SP)
 757             goto just_say_no;
 758         else {
 759             if (PL_op->op_type == OP_SAY) {
 760                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 761                     goto just_say_no;
 762             }
 763             else if (PL_ors_sv && SvOK(PL_ors_sv))
 764                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 765                     goto just_say_no;
 766
 767             if (IoFLAGS(io) & IOf_FLUSH)
 768                 if (PerlIO_flush(fp) == EOF)
 769                     goto just_say_no;
 770         }
 771     }
 772     SP = ORIGMARK;
 773     XPUSHs(&PL_sv_yes);
 774     RETURN;
 775
 776   just_say_no:
 777     SP = ORIGMARK;
 778     XPUSHs(&PL_sv_undef);
 779     RETURN;
 780 }
 781
 782 PP(pp_rv2av)
 783 {
 784     dVAR; dSP; dTOPss;
 785     const I32 gimme = GIMME_V;
 786     static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
 787     static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
 788     static const char an_array[] = "an ARRAY";
 789     static const char a_hash[] = "a HASH";
 790     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 791     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 792
 793     if (SvROK(sv)) {
 794       wasref:
 795         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 796
 797         sv = SvRV(sv);
 798         if (SvTYPE(sv) != type)
 799             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 800         if (PL_op->op_flags & OPf_REF) {
 801             SETs(sv);
 802             RETURN;
 803         }
 804         else if (LVRET) {
 805             if (gimme != G_ARRAY)
 806                 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
 807                            : return_hash_to_lvalue_scalar);
 808             SETs(sv);
 809             RETURN;
 810         }
 811         else if (PL_op->op_flags & OPf_MOD
 812                 && PL_op->op_private & OPpLVAL_INTRO)
 813             Perl_croak(aTHX_ PL_no_localize_ref);
 814     }
 815     else {
 816         if (SvTYPE(sv) == type) {
 817             if (PL_op->op_flags & OPf_REF) {
 818                 SETs(sv);
 819                 RETURN;
 820             }
 821             else if (LVRET) {
 822                 if (gimme != G_ARRAY)
 823                     Perl_croak(aTHX_
 824                                is_pp_rv2av ? return_array_to_lvalue_scalar
 825                                : return_hash_to_lvalue_scalar);
 826                 SETs(sv);
 827                 RETURN;
 828             }
 829         }
 830         else {
 831             GV *gv;
 832
 833             if (SvTYPE(sv) != SVt_PVGV) {
 834                 if (SvGMAGICAL(sv)) {
 835                     mg_get(sv);
 836                     if (SvROK(sv))
 837                         goto wasref;
 838                 }
 839                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 840                                      type, &sp);
 841                 if (!gv)
 842                     RETURN;
 843             }
 844             else {
 845                 gv = (GV*)sv;
 846             }
 847             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
 848             if (PL_op->op_private & OPpLVAL_INTRO)
 849                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
 850             if (PL_op->op_flags & OPf_REF) {
 851                 SETs(sv);
 852                 RETURN;
 853             }
 854             else if (LVRET) {
 855                 if (gimme != G_ARRAY)
 856                     Perl_croak(aTHX_
 857                                is_pp_rv2av ? return_array_to_lvalue_scalar
 858                                : return_hash_to_lvalue_scalar);
 859                 SETs(sv);
 860                 RETURN;
 861             }
 862         }
 863     }
 864
 865     if (is_pp_rv2av) {
 866         AV *const av = (AV*)sv;
 867         /* The guts of pp_rv2av, with no intenting change to preserve history
 868            (until such time as we get tools that can do blame annotation across
 869            whitespace changes.  */
 870     if (gimme == G_ARRAY) {
 871         const I32 maxarg = AvFILL(av) + 1;
 872         (void)POPs;                     /* XXXX May be optimized away? */
 873         EXTEND(SP, maxarg);
 874         if (SvRMAGICAL(av)) {
 875             U32 i;
 876             for (i=0; i < (U32)maxarg; i++) {
 877                 SV ** const svp = av_fetch(av, i, FALSE);
 878                 /* See note in pp_helem, and bug id #27839 */
 879                 SP[i+1] = svp
 880                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 881                     : &PL_sv_undef;
 882             }
 883         }
 884         else {
 885             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 886         }
 887         SP += maxarg;
 888     }
 889     else if (gimme == G_SCALAR) {
 890         dTARGET;
 891         const I32 maxarg = AvFILL(av) + 1;
 892         SETi(maxarg);
 893     }
 894     } else {
 895         /* The guts of pp_rv2hv  */
 896     if (gimme == G_ARRAY) { /* array wanted */
 897         *PL_stack_sp = sv;
 898         return do_kv();
 899     }
 900     else if (gimme == G_SCALAR) {
 901         dTARGET;
 902     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
 903         SPAGAIN;
 904         SETTARG;
 905     }
 906     }
 907     RETURN;
 908 }
 909
 910 STATIC void
 911 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 912 {
 913     dVAR;
 914     if (*relem) {
 915         SV *tmpstr;
 916         const HE *didstore;
 917
 918         if (ckWARN(WARN_MISC)) {
 919             const char *err;
 920             if (relem == firstrelem &&
 921                 SvROK(*relem) &&
 922                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 923                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 924             {
 925                 err = "Reference found where even-sized list expected";
 926             }
 927             else
 928                 err = "Odd number of elements in hash assignment";
 929             Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 930         }
 931
 932         tmpstr = newSV(0);
 933         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 934         if (SvMAGICAL(hash)) {
 935             if (SvSMAGICAL(tmpstr))
 936                 mg_set(tmpstr);
 937             if (!didstore)
 938                 sv_2mortal(tmpstr);
 939         }
 940         TAINT_NOT;
 941     }
 942 }
 943
 944 PP(pp_aassign)
 945 {
 946     dVAR; dSP;
 947     SV **lastlelem = PL_stack_sp;
 948     SV **lastrelem = PL_stack_base + POPMARK;
 949     SV **firstrelem = PL_stack_base + POPMARK + 1;
 950     SV **firstlelem = lastrelem + 1;
 951
 952     register SV **relem;
 953     register SV **lelem;
 954
 955     register SV *sv;
 956     register AV *ary;
 957
 958     I32 gimme;
 959     HV *hash;
 960     I32 i;
 961     int magic;
 962     int duplicates = 0;
 963     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 964
 965
 966     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 967     gimme = GIMME_V;
 968
 969     /* If there's a common identifier on both sides we have to take
 970      * special care that assigning the identifier on the left doesn't
 971      * clobber a value on the right that's used later in the list.
 972      */
 973     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 974         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 975         for (relem = firstrelem; relem <= lastrelem; relem++) {
 976             if ((sv = *relem)) {
 977                 TAINT_NOT;      /* Each item is independent */
 978                 *relem = sv_mortalcopy(sv);
 979             }
 980         }
 981     }
 982     if (PL_op->op_private & OPpASSIGN_STATE) {
 983         if (SvPADSTALE(*firstlelem))
 984             SvPADSTALE_off(*firstlelem);
 985         else
 986             RETURN; /* ignore assignment */
 987     }
 988
 989     relem = firstrelem;
 990     lelem = firstlelem;
 991     ary = NULL;
 992     hash = NULL;
 993
 994     while (lelem <= lastlelem) {
 995         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 996         sv = *lelem++;
 997         switch (SvTYPE(sv)) {
 998         case SVt_PVAV:
 999             ary = (AV*)sv;
1000             magic = SvMAGICAL(ary) != 0;
1001             av_clear(ary);
1002             av_extend(ary, lastrelem - relem);
1003             i = 0;
1004             while (relem <= lastrelem) {        /* gobble up all the rest */
1005                 SV **didstore;
1006                 assert(*relem);
1007                 sv = newSVsv(*relem);
1008                 *(relem++) = sv;
1009                 didstore = av_store(ary,i++,sv);
1010                 if (magic) {
1011                     if (SvSMAGICAL(sv))
1012                         mg_set(sv);
1013                     if (!didstore)
1014                         sv_2mortal(sv);
1015                 }
1016                 TAINT_NOT;
1017             }
1018             break;
1019         case SVt_PVHV: {                                /* normal hash */
1020                 SV *tmpstr;
1021
1022                 hash = (HV*)sv;
1023                 magic = SvMAGICAL(hash) != 0;
1024                 hv_clear(hash);
1025                 firsthashrelem = relem;
1026
1027                 while (relem < lastrelem) {     /* gobble up all the rest */
1028                     HE *didstore;
1029                     sv = *relem ? *relem : &PL_sv_no;
1030                     relem++;
1031                     tmpstr = newSV(0);
1032                     if (*relem)
1033                         sv_setsv(tmpstr,*relem);        /* value */
1034                     *(relem++) = tmpstr;
1035                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1036                         /* key overwrites an existing entry */
1037                         duplicates += 2;
1038                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1039                     if (magic) {
1040                         if (SvSMAGICAL(tmpstr))
1041                             mg_set(tmpstr);
1042                         if (!didstore)
1043                             sv_2mortal(tmpstr);
1044                     }
1045                     TAINT_NOT;
1046                 }
1047                 if (relem == lastrelem) {
1048                     do_oddball(hash, relem, firstrelem);
1049                     relem++;
1050                 }
1051             }
1052             break;
1053         default:
1054             if (SvIMMORTAL(sv)) {
1055                 if (relem <= lastrelem)
1056                     relem++;
1057                 break;
1058             }
1059             if (relem <= lastrelem) {
1060                 sv_setsv(sv, *relem);
1061                 *(relem++) = sv;
1062             }
1063             else
1064                 sv_setsv(sv, &PL_sv_undef);
1065             SvSETMAGIC(sv);
1066             break;
1067         }
1068     }
1069     if (PL_delaymagic & ~DM_DELAY) {
1070         if (PL_delaymagic & DM_UID) {
1071 #ifdef HAS_SETRESUID
1072             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1073                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1074                             (Uid_t)-1);
1075 #else
1076 #  ifdef HAS_SETREUID
1077             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1078                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1079 #  else
1080 #    ifdef HAS_SETRUID
1081             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1082                 (void)setruid(PL_uid);
1083                 PL_delaymagic &= ~DM_RUID;
1084             }
1085 #    endif /* HAS_SETRUID */
1086 #    ifdef HAS_SETEUID
1087             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1088                 (void)seteuid(PL_euid);
1089                 PL_delaymagic &= ~DM_EUID;
1090             }
1091 #    endif /* HAS_SETEUID */
1092             if (PL_delaymagic & DM_UID) {
1093                 if (PL_uid != PL_euid)
1094                     DIE(aTHX_ "No setreuid available");
1095                 (void)PerlProc_setuid(PL_uid);
1096             }
1097 #  endif /* HAS_SETREUID */
1098 #endif /* HAS_SETRESUID */
1099             PL_uid = PerlProc_getuid();
1100             PL_euid = PerlProc_geteuid();
1101         }
1102         if (PL_delaymagic & DM_GID) {
1103 #ifdef HAS_SETRESGID
1104             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1105                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1106                             (Gid_t)-1);
1107 #else
1108 #  ifdef HAS_SETREGID
1109             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1110                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1111 #  else
1112 #    ifdef HAS_SETRGID
1113             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1114                 (void)setrgid(PL_gid);
1115                 PL_delaymagic &= ~DM_RGID;
1116             }
1117 #    endif /* HAS_SETRGID */
1118 #    ifdef HAS_SETEGID
1119             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1120                 (void)setegid(PL_egid);
1121                 PL_delaymagic &= ~DM_EGID;
1122             }
1123 #    endif /* HAS_SETEGID */
1124             if (PL_delaymagic & DM_GID) {
1125                 if (PL_gid != PL_egid)
1126                     DIE(aTHX_ "No setregid available");
1127                 (void)PerlProc_setgid(PL_gid);
1128             }
1129 #  endif /* HAS_SETREGID */
1130 #endif /* HAS_SETRESGID */
1131             PL_gid = PerlProc_getgid();
1132             PL_egid = PerlProc_getegid();
1133         }
1134         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1135     }
1136     PL_delaymagic = 0;
1137
1138     if (gimme == G_VOID)
1139         SP = firstrelem - 1;
1140     else if (gimme == G_SCALAR) {
1141         dTARGET;
1142         SP = firstrelem;
1143         SETi(lastrelem - firstrelem + 1 - duplicates);
1144     }
1145     else {
1146         if (ary)
1147             SP = lastrelem;
1148         else if (hash) {
1149             if (duplicates) {
1150                 /* Removes from the stack the entries which ended up as
1151                  * duplicated keys in the hash (fix for [perl #24380]) */
1152                 Move(firsthashrelem + duplicates,
1153                         firsthashrelem, duplicates, SV**);
1154                 lastrelem -= duplicates;
1155             }
1156             SP = lastrelem;
1157         }
1158         else
1159             SP = firstrelem + (lastlelem - firstlelem);
1160         lelem = firstlelem + (relem - firstrelem);
1161         while (relem <= SP)
1162             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1163     }
1164     RETURN;
1165 }
1166
1167 PP(pp_qr)
1168 {
1169     dVAR; dSP;
1170     register PMOP * const pm = cPMOP;
1171     SV * const rv = sv_newmortal();
1172     SV * const sv = newSVrv(rv, "Regexp");
1173     if (pm->op_pmdynflags & PMdf_TAINTED)
1174         SvTAINTED_on(rv);
1175     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1176     XPUSHs(rv);
1177     RETURN;
1178 }
1179
1180 PP(pp_match)
1181 {
1182     dVAR; dSP; dTARG;
1183     register PMOP *pm = cPMOP;
1184     PMOP *dynpm = pm;
1185     register const char *t;
1186     register const char *s;
1187     const char *strend;
1188     I32 global;
1189     I32 r_flags = REXEC_CHECKED;
1190     const char *truebase;                       /* Start of string  */
1191     register REGEXP *rx = PM_GETRE(pm);
1192     bool rxtainted;
1193     const I32 gimme = GIMME;
1194     STRLEN len;
1195     I32 minmatch = 0;
1196     const I32 oldsave = PL_savestack_ix;
1197     I32 update_minmatch = 1;
1198     I32 had_zerolen = 0;
1199     U32 gpos = 0;
1200
1201     if (PL_op->op_flags & OPf_STACKED)
1202         TARG = POPs;
1203     else if (PL_op->op_private & OPpTARGET_MY)
1204         GETTARGET;
1205     else {
1206         TARG = DEFSV;
1207         EXTEND(SP,1);
1208     }
1209
1210     PUTBACK;                            /* EVAL blocks need stack_sp. */
1211     s = SvPV_const(TARG, len);
1212     if (!s)
1213         DIE(aTHX_ "panic: pp_match");
1214     strend = s + len;
1215     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1216                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1217     TAINT_NOT;
1218
1219     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1220
1221     /* PMdf_USED is set after a ?? matches once */
1222     if (pm->op_pmdynflags & PMdf_USED) {
1223       failure:
1224         if (gimme == G_ARRAY)
1225             RETURN;
1226         RETPUSHNO;
1227     }
1228
1229     /* empty pattern special-cased to use last successful pattern if possible */
1230     if (!rx->prelen && PL_curpm) {
1231         pm = PL_curpm;
1232         rx = PM_GETRE(pm);
1233     }
1234
1235     if (rx->minlen > (I32)len)
1236         goto failure;
1237
1238     truebase = t = s;
1239
1240     /* XXXX What part of this is needed with true \G-support? */
1241     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1242         rx->startp[0] = -1;
1243         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1244             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1245             if (mg && mg->mg_len >= 0) {
1246                 if (!(rx->extflags & RXf_GPOS_SEEN))
1247                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1248                 else if (rx->extflags & RXf_ANCH_GPOS) {
1249                     r_flags |= REXEC_IGNOREPOS;
1250                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1251                 } else if (rx->extflags & RXf_GPOS_FLOAT)
1252                     gpos = mg->mg_len;
1253                 else
1254                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1255                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1256                 update_minmatch = 0;
1257             }
1258         }
1259     }
1260     /* remove comment to get faster /g but possibly unsafe $1 vars after a
1261        match. Test for the unsafe vars will fail as well*/
1262     if (( /* !global &&  */ rx->nparens)
1263             || SvTEMP(TARG) || PL_sawampersand ||
1264             (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
1265         r_flags |= REXEC_COPY_STR;
1266     if (SvSCREAM(TARG))
1267         r_flags |= REXEC_SCREAM;
1268
1269 play_it_again:
1270     if (global && rx->startp[0] != -1) {
1271         t = s = rx->endp[0] + truebase - rx->gofs;
1272         if ((s + rx->minlen) > strend || s < truebase)
1273             goto nope;
1274         if (update_minmatch++)
1275             minmatch = had_zerolen;
1276     }
1277     if (rx->extflags & RXf_USE_INTUIT &&
1278         DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1279         /* FIXME - can PL_bostr be made const char *?  */
1280         PL_bostr = (char *)truebase;
1281         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1282
1283         if (!s)
1284             goto nope;
1285         if ( (rx->extflags & RXf_CHECK_ALL)
1286              && !PL_sawampersand
1287              && !(pm->op_pmflags & PMf_KEEPCOPY)
1288              && ((rx->extflags & RXf_NOSCAN)
1289                  || !((rx->extflags & RXf_INTUIT_TAIL)
1290                       && (r_flags & REXEC_SCREAM)))
1291              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1292             goto yup;
1293     }
1294     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1295     {
1296         PL_curpm = pm;
1297         if (dynpm->op_pmflags & PMf_ONCE)
1298             dynpm->op_pmdynflags |= PMdf_USED;
1299         goto gotcha;
1300     }
1301     else
1302         goto ret_no;
1303     /*NOTREACHED*/
1304
1305   gotcha:
1306     if (rxtainted)
1307         RX_MATCH_TAINTED_on(rx);
1308     TAINT_IF(RX_MATCH_TAINTED(rx));
1309     if (gimme == G_ARRAY) {
1310         const I32 nparens = rx->nparens;
1311         I32 i = (global && !nparens) ? 1 : 0;
1312
1313         SPAGAIN;                        /* EVAL blocks could move the stack. */
1314         EXTEND(SP, nparens + i);
1315         EXTEND_MORTAL(nparens + i);
1316         for (i = !i; i <= nparens; i++) {
1317             PUSHs(sv_newmortal());
1318             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1319                 const I32 len = rx->endp[i] - rx->startp[i];
1320                 s = rx->startp[i] + truebase;
1321                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1322                     len < 0 || len > strend - s)
1323                     DIE(aTHX_ "panic: pp_match start/end pointers");
1324                 sv_setpvn(*SP, s, len);
1325                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1326                     SvUTF8_on(*SP);
1327             }
1328         }
1329         if (global) {
1330             if (dynpm->op_pmflags & PMf_CONTINUE) {
1331                 MAGIC* mg = NULL;
1332                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1333                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1334                 if (!mg) {
1335 #ifdef PERL_OLD_COPY_ON_WRITE
1336                     if (SvIsCOW(TARG))
1337                         sv_force_normal_flags(TARG, 0);
1338 #endif
1339                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1340                                      &PL_vtbl_mglob, NULL, 0);
1341                 }
1342                 if (rx->startp[0] != -1) {
1343                     mg->mg_len = rx->endp[0];
1344                     if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1345                         mg->mg_flags |= MGf_MINMATCH;
1346                     else
1347                         mg->mg_flags &= ~MGf_MINMATCH;
1348                 }
1349             }
1350             had_zerolen = (rx->startp[0] != -1
1351                            && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
1352             PUTBACK;                    /* EVAL blocks may use stack */
1353             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1354             goto play_it_again;
1355         }
1356         else if (!nparens)
1357             XPUSHs(&PL_sv_yes);
1358         LEAVE_SCOPE(oldsave);
1359         RETURN;
1360     }
1361     else {
1362         if (global) {
1363             MAGIC* mg;
1364             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1365                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1366             else
1367                 mg = NULL;
1368             if (!mg) {
1369 #ifdef PERL_OLD_COPY_ON_WRITE
1370                 if (SvIsCOW(TARG))
1371                     sv_force_normal_flags(TARG, 0);
1372 #endif
1373                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1374                                  &PL_vtbl_mglob, NULL, 0);
1375             }
1376             if (rx->startp[0] != -1) {
1377                 mg->mg_len = rx->endp[0];
1378                 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1379                     mg->mg_flags |= MGf_MINMATCH;
1380                 else
1381                     mg->mg_flags &= ~MGf_MINMATCH;
1382             }
1383         }
1384         LEAVE_SCOPE(oldsave);
1385         RETPUSHYES;
1386     }
1387
1388 yup:                                    /* Confirmed by INTUIT */
1389     if (rxtainted)
1390         RX_MATCH_TAINTED_on(rx);
1391     TAINT_IF(RX_MATCH_TAINTED(rx));
1392     PL_curpm = pm;
1393     if (dynpm->op_pmflags & PMf_ONCE)
1394         dynpm->op_pmdynflags |= PMdf_USED;
1395     if (RX_MATCH_COPIED(rx))
1396         Safefree(rx->subbeg);
1397     RX_MATCH_COPIED_off(rx);
1398     rx->subbeg = NULL;
1399     if (global) {
1400         /* FIXME - should rx->subbeg be const char *?  */
1401         rx->subbeg = (char *) truebase;
1402         rx->startp[0] = s - truebase;
1403         if (RX_MATCH_UTF8(rx)) {
1404             char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1405             rx->endp[0] = t - truebase;
1406         }
1407         else {
1408             rx->endp[0] = s - truebase + rx->minlenret;
1409         }
1410         rx->sublen = strend - truebase;
1411         goto gotcha;
1412     }
1413     if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
1414         I32 off;
1415 #ifdef PERL_OLD_COPY_ON_WRITE
1416         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1417             if (DEBUG_C_TEST) {
1418                 PerlIO_printf(Perl_debug_log,
1419                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1420                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1421                               (int)(t-truebase));
1422             }
1423             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1424             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1425             assert (SvPOKp(rx->saved_copy));
1426         } else
1427 #endif
1428         {
1429
1430             rx->subbeg = savepvn(t, strend - t);
1431 #ifdef PERL_OLD_COPY_ON_WRITE
1432             rx->saved_copy = NULL;
1433 #endif
1434         }
1435         rx->sublen = strend - t;
1436         RX_MATCH_COPIED_on(rx);
1437         off = rx->startp[0] = s - t;
1438         rx->endp[0] = off + rx->minlenret;
1439     }
1440     else {                      /* startp/endp are used by @- @+. */
1441         rx->startp[0] = s - truebase;
1442         rx->endp[0] = s - truebase + rx->minlenret;
1443     }
1444     /* including rx->nparens in the below code seems highly suspicious.
1445        -dmq */
1446     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1447     LEAVE_SCOPE(oldsave);
1448     RETPUSHYES;
1449
1450 nope:
1451 ret_no:
1452     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1453         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1454             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1455             if (mg)
1456                 mg->mg_len = -1;
1457         }
1458     }
1459     LEAVE_SCOPE(oldsave);
1460     if (gimme == G_ARRAY)
1461         RETURN;
1462     RETPUSHNO;
1463 }
1464
1465 OP *
1466 Perl_do_readline(pTHX)
1467 {
1468     dVAR; dSP; dTARGETSTACKED;
1469     register SV *sv;
1470     STRLEN tmplen = 0;
1471     STRLEN offset;
1472     PerlIO *fp;
1473     register IO * const io = GvIO(PL_last_in_gv);
1474     register const I32 type = PL_op->op_type;
1475     const I32 gimme = GIMME_V;
1476
1477     if (io) {
1478         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1479         if (mg) {
1480             PUSHMARK(SP);
1481             XPUSHs(SvTIED_obj((SV*)io, mg));
1482             PUTBACK;
1483             ENTER;
1484             call_method("READLINE", gimme);
1485             LEAVE;
1486             SPAGAIN;
1487             if (gimme == G_SCALAR) {
1488                 SV* const result = POPs;
1489                 SvSetSV_nosteal(TARG, result);
1490                 PUSHTARG;
1491             }
1492             RETURN;
1493         }
1494     }
1495     fp = NULL;
1496     if (io) {
1497         fp = IoIFP(io);
1498         if (!fp) {
1499             if (IoFLAGS(io) & IOf_ARGV) {
1500                 if (IoFLAGS(io) & IOf_START) {
1501                     IoLINES(io) = 0;
1502                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1503                         IoFLAGS(io) &= ~IOf_START;
1504                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1505                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1506                         SvSETMAGIC(GvSV(PL_last_in_gv));
1507                         fp = IoIFP(io);
1508                         goto have_fp;
1509                     }
1510                 }
1511                 fp = nextargv(PL_last_in_gv);
1512                 if (!fp) { /* Note: fp != IoIFP(io) */
1513                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1514                 }
1515             }
1516             else if (type == OP_GLOB)
1517                 fp = Perl_start_glob(aTHX_ POPs, io);
1518         }
1519         else if (type == OP_GLOB)
1520             SP--;
1521         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1522             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1523         }
1524     }
1525     if (!fp) {
1526         if ((!io || !(IoFLAGS(io) & IOf_START))
1527             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1528         {
1529             if (type == OP_GLOB)
1530                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1531                             "glob failed (can't start child: %s)",
1532                             Strerror(errno));
1533             else
1534                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1535         }
1536         if (gimme == G_SCALAR) {
1537             /* undef TARG, and push that undefined value */
1538             if (type != OP_RCATLINE) {
1539                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1540                 SvOK_off(TARG);
1541             }
1542             PUSHTARG;
1543         }
1544         RETURN;
1545     }
1546   have_fp:
1547     if (gimme == G_SCALAR) {
1548         sv = TARG;
1549         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1550             mg_get(sv);
1551         if (SvROK(sv)) {
1552             if (type == OP_RCATLINE)
1553                 SvPV_force_nolen(sv);
1554             else
1555                 sv_unref(sv);
1556         }
1557         else if (isGV_with_GP(sv)) {
1558             SvPV_force_nolen(sv);
1559         }
1560         SvUPGRADE(sv, SVt_PV);
1561         tmplen = SvLEN(sv);     /* remember if already alloced */
1562         if (!tmplen && !SvREADONLY(sv))
1563             Sv_Grow(sv, 80);    /* try short-buffering it */
1564         offset = 0;
1565         if (type == OP_RCATLINE && SvOK(sv)) {
1566             if (!SvPOK(sv)) {
1567                 SvPV_force_nolen(sv);
1568             }
1569             offset = SvCUR(sv);
1570         }
1571     }
1572     else {
1573         sv = sv_2mortal(newSV(80));
1574         offset = 0;
1575     }
1576
1577     /* This should not be marked tainted if the fp is marked clean */
1578 #define MAYBE_TAINT_LINE(io, sv) \
1579     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1580         TAINT;                          \
1581         SvTAINTED_on(sv);               \
1582     }
1583
1584 /* delay EOF state for a snarfed empty file */
1585 #define SNARF_EOF(gimme,rs,io,sv) \
1586     (gimme != G_SCALAR || SvCUR(sv)                                     \
1587      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1588
1589     for (;;) {
1590         PUTBACK;
1591         if (!sv_gets(sv, fp, offset)
1592             && (type == OP_GLOB
1593                 || SNARF_EOF(gimme, PL_rs, io, sv)
1594                 || PerlIO_error(fp)))
1595         {
1596             PerlIO_clearerr(fp);
1597             if (IoFLAGS(io) & IOf_ARGV) {
1598                 fp = nextargv(PL_last_in_gv);
1599                 if (fp)
1600                     continue;
1601                 (void)do_close(PL_last_in_gv, FALSE);
1602             }
1603             else if (type == OP_GLOB) {
1604                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1605                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1606                            "glob failed (child exited with status %d%s)",
1607                            (int)(STATUS_CURRENT >> 8),
1608                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1609                 }
1610             }
1611             if (gimme == G_SCALAR) {
1612                 if (type != OP_RCATLINE) {
1613                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1614                     SvOK_off(TARG);
1615                 }
1616                 SPAGAIN;
1617                 PUSHTARG;
1618             }
1619             MAYBE_TAINT_LINE(io, sv);
1620             RETURN;
1621         }
1622         MAYBE_TAINT_LINE(io, sv);
1623         IoLINES(io)++;
1624         IoFLAGS(io) |= IOf_NOLINE;
1625         SvSETMAGIC(sv);
1626         SPAGAIN;
1627         XPUSHs(sv);
1628         if (type == OP_GLOB) {
1629             const char *t1;
1630
1631             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1632                 char * const tmps = SvEND(sv) - 1;
1633                 if (*tmps == *SvPVX_const(PL_rs)) {
1634                     *tmps = '\0';
1635                     SvCUR_set(sv, SvCUR(sv) - 1);
1636                 }
1637             }
1638             for (t1 = SvPVX_const(sv); *t1; t1++)
1639                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1640                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1641                         break;
1642             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1643                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1644                 continue;
1645             }
1646         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1647              if (ckWARN(WARN_UTF8)) {
1648                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1649                 const STRLEN len = SvCUR(sv) - offset;
1650                 const U8 *f;
1651
1652                 if (!is_utf8_string_loc(s, len, &f))
1653                     /* Emulate :encoding(utf8) warning in the same case. */
1654                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1655                                 "utf8 \"\\x%02X\" does not map to Unicode",
1656                                 f < (U8*)SvEND(sv) ? *f : 0);
1657              }
1658         }
1659         if (gimme == G_ARRAY) {
1660             if (SvLEN(sv) - SvCUR(sv) > 20) {
1661                 SvPV_shrink_to_cur(sv);
1662             }
1663             sv = sv_2mortal(newSV(80));
1664             continue;
1665         }
1666         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1667             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1668             const STRLEN new_len
1669                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1670             SvPV_renew(sv, new_len);
1671         }
1672         RETURN;
1673     }
1674 }
1675
1676 PP(pp_enter)
1677 {
1678     dVAR; dSP;
1679     register PERL_CONTEXT *cx;
1680     I32 gimme = OP_GIMME(PL_op, -1);
1681
1682     if (gimme == -1) {
1683         if (cxstack_ix >= 0)
1684             gimme = cxstack[cxstack_ix].blk_gimme;
1685         else
1686             gimme = G_SCALAR;
1687     }
1688
1689     ENTER;
1690
1691     SAVETMPS;
1692     PUSHBLOCK(cx, CXt_BLOCK, SP);
1693
1694     RETURN;
1695 }
1696
1697 PP(pp_helem)
1698 {
1699     dVAR; dSP;
1700     HE* he;
1701     SV **svp;
1702     SV * const keysv = POPs;
1703     HV * const hv = (HV*)POPs;
1704     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1705     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1706     SV *sv;
1707     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1708     I32 preeminent = 0;
1709
1710     if (SvTYPE(hv) != SVt_PVHV)
1711         RETPUSHUNDEF;
1712
1713     if (PL_op->op_private & OPpLVAL_INTRO) {
1714         MAGIC *mg;
1715         HV *stash;
1716         /* does the element we're localizing already exist? */
1717         preeminent = /* can we determine whether it exists? */
1718             (    !SvRMAGICAL(hv)
1719                 || mg_find((SV*)hv, PERL_MAGIC_env)
1720                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1721                         /* Try to preserve the existenceness of a tied hash
1722                         * element by using EXISTS and DELETE if possible.
1723                         * Fallback to FETCH and STORE otherwise */
1724                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1725                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1726                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1727                 )
1728             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1729     }
1730     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1731     svp = he ? &HeVAL(he) : NULL;
1732     if (lval) {
1733         if (!svp || *svp == &PL_sv_undef) {
1734             SV* lv;
1735             SV* key2;
1736             if (!defer) {
1737                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1738             }
1739             lv = sv_newmortal();
1740             sv_upgrade(lv, SVt_PVLV);
1741             LvTYPE(lv) = 'y';
1742             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1743             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1744             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1745             LvTARGLEN(lv) = 1;
1746             PUSHs(lv);
1747             RETURN;
1748         }
1749         if (PL_op->op_private & OPpLVAL_INTRO) {
1750             if (HvNAME_get(hv) && isGV(*svp))
1751                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1752             else {
1753                 if (!preeminent) {
1754                     STRLEN keylen;
1755                     const char * const key = SvPV_const(keysv, keylen);
1756                     SAVEDELETE(hv, savepvn(key,keylen),
1757                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1758                 } else
1759                     save_helem(hv, keysv, svp);
1760             }
1761         }
1762         else if (PL_op->op_private & OPpDEREF)
1763             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1764     }
1765     sv = (svp ? *svp : &PL_sv_undef);
1766     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1767      * Pushing the magical RHS on to the stack is useless, since
1768      * that magic is soon destined to be misled by the local(),
1769      * and thus the later pp_sassign() will fail to mg_get() the
1770      * old value.  This should also cure problems with delayed
1771      * mg_get()s.  GSAR 98-07-03 */
1772     if (!lval && SvGMAGICAL(sv))
1773         sv = sv_mortalcopy(sv);
1774     PUSHs(sv);
1775     RETURN;
1776 }
1777
1778 PP(pp_leave)
1779 {
1780     dVAR; dSP;
1781     register PERL_CONTEXT *cx;
1782     SV **newsp;
1783     PMOP *newpm;
1784     I32 gimme;
1785
1786     if (PL_op->op_flags & OPf_SPECIAL) {
1787         cx = &cxstack[cxstack_ix];
1788         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1789     }
1790
1791     POPBLOCK(cx,newpm);
1792
1793     gimme = OP_GIMME(PL_op, -1);
1794     if (gimme == -1) {
1795         if (cxstack_ix >= 0)
1796             gimme = cxstack[cxstack_ix].blk_gimme;
1797         else
1798             gimme = G_SCALAR;
1799     }
1800
1801     TAINT_NOT;
1802     if (gimme == G_VOID)
1803         SP = newsp;
1804     else if (gimme == G_SCALAR) {
1805         register SV **mark;
1806         MARK = newsp + 1;
1807         if (MARK <= SP) {
1808             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1809                 *MARK = TOPs;
1810             else
1811                 *MARK = sv_mortalcopy(TOPs);
1812         } else {
1813             MEXTEND(mark,0);
1814             *MARK = &PL_sv_undef;
1815         }
1816         SP = MARK;
1817     }
1818     else if (gimme == G_ARRAY) {
1819         /* in case LEAVE wipes old return values */
1820         register SV **mark;
1821         for (mark = newsp + 1; mark <= SP; mark++) {
1822             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1823                 *mark = sv_mortalcopy(*mark);
1824                 TAINT_NOT;      /* Each item is independent */
1825             }
1826         }
1827     }
1828     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1829
1830     LEAVE;
1831
1832     RETURN;
1833 }
1834
1835 PP(pp_iter)
1836 {
1837     dVAR; dSP;
1838     register PERL_CONTEXT *cx;
1839     SV *sv, *oldsv;
1840     AV* av;
1841     SV **itersvp;
1842
1843     EXTEND(SP, 1);
1844     cx = &cxstack[cxstack_ix];
1845     if (CxTYPE(cx) != CXt_LOOP)
1846         DIE(aTHX_ "panic: pp_iter");
1847
1848     itersvp = CxITERVAR(cx);
1849     av = cx->blk_loop.iterary;
1850     if (SvTYPE(av) != SVt_PVAV) {
1851         /* iterate ($min .. $max) */
1852         if (cx->blk_loop.iterlval) {
1853             /* string increment */
1854             register SV* cur = cx->blk_loop.iterlval;
1855             STRLEN maxlen = 0;
1856             const char *max =
1857               SvOK((SV*)av) ?
1858               SvPV_const((SV*)av, maxlen) : (const char *)"";
1859             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1860                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1861                     /* safe to reuse old SV */
1862                     sv_setsv(*itersvp, cur);
1863                 }
1864                 else
1865                 {
1866                     /* we need a fresh SV every time so that loop body sees a
1867                      * completely new SV for closures/references to work as
1868                      * they used to */
1869                     oldsv = *itersvp;
1870                     *itersvp = newSVsv(cur);
1871                     SvREFCNT_dec(oldsv);
1872                 }
1873                 if (strEQ(SvPVX_const(cur), max))
1874                     sv_setiv(cur, 0); /* terminate next time */
1875                 else
1876                     sv_inc(cur);
1877                 RETPUSHYES;
1878             }
1879             RETPUSHNO;
1880         }
1881         /* integer increment */
1882         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1883             RETPUSHNO;
1884
1885         /* don't risk potential race */
1886         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1887             /* safe to reuse old SV */
1888             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1889         }
1890         else
1891         {
1892             /* we need a fresh SV every time so that loop body sees a
1893              * completely new SV for closures/references to work as they
1894              * used to */
1895             oldsv = *itersvp;
1896             *itersvp = newSViv(cx->blk_loop.iterix++);
1897             SvREFCNT_dec(oldsv);
1898         }
1899         RETPUSHYES;
1900     }
1901
1902     /* iterate array */
1903     if (PL_op->op_private & OPpITER_REVERSED) {
1904         /* In reverse, use itermax as the min :-)  */
1905         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1906             RETPUSHNO;
1907
1908         if (SvMAGICAL(av) || AvREIFY(av)) {
1909             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1910             sv = svp ? *svp : NULL;
1911         }
1912         else {
1913             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1914         }
1915     }
1916     else {
1917         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1918                                     AvFILL(av)))
1919             RETPUSHNO;
1920
1921         if (SvMAGICAL(av) || AvREIFY(av)) {
1922             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1923             sv = svp ? *svp : NULL;
1924         }
1925         else {
1926             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1927         }
1928     }
1929
1930     if (sv && SvIS_FREED(sv)) {
1931         *itersvp = NULL;
1932         Perl_croak(aTHX_ "Use of freed value in iteration");
1933     }
1934
1935     if (sv)
1936         SvTEMP_off(sv);
1937     else
1938         sv = &PL_sv_undef;
1939     if (av != PL_curstack && sv == &PL_sv_undef) {
1940         SV *lv = cx->blk_loop.iterlval;
1941         if (lv && SvREFCNT(lv) > 1) {
1942             SvREFCNT_dec(lv);
1943             lv = NULL;
1944         }
1945         if (lv)
1946             SvREFCNT_dec(LvTARG(lv));
1947         else {
1948             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1949             LvTYPE(lv) = 'y';
1950             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1951         }
1952         LvTARG(lv) = SvREFCNT_inc_simple(av);
1953         LvTARGOFF(lv) = cx->blk_loop.iterix;
1954         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1955         sv = (SV*)lv;
1956     }
1957
1958     oldsv = *itersvp;
1959     *itersvp = SvREFCNT_inc_simple_NN(sv);
1960     SvREFCNT_dec(oldsv);
1961
1962     RETPUSHYES;
1963 }
1964
1965 PP(pp_subst)
1966 {
1967     dVAR; dSP; dTARG;
1968     register PMOP *pm = cPMOP;
1969     PMOP *rpm = pm;
1970     register char *s;
1971     char *strend;
1972     register char *m;
1973     const char *c;
1974     register char *d;
1975     STRLEN clen;
1976     I32 iters = 0;
1977     I32 maxiters;
1978     register I32 i;
1979     bool once;
1980     bool rxtainted;
1981     char *orig;
1982     I32 r_flags;
1983     register REGEXP *rx = PM_GETRE(pm);
1984     STRLEN len;
1985     int force_on_match = 0;
1986     const I32 oldsave = PL_savestack_ix;
1987     STRLEN slen;
1988     bool doutf8 = FALSE;
1989 #ifdef PERL_OLD_COPY_ON_WRITE
1990     bool is_cow;
1991 #endif
1992     SV *nsv = NULL;
1993
1994     /* known replacement string? */
1995     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
1996     if (PL_op->op_flags & OPf_STACKED)
1997         TARG = POPs;
1998     else if (PL_op->op_private & OPpTARGET_MY)
1999         GETTARGET;
2000     else {
2001         TARG = DEFSV;
2002         EXTEND(SP,1);
2003     }
2004
2005 #ifdef PERL_OLD_COPY_ON_WRITE
2006     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2007        because they make integers such as 256 "false".  */
2008     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2009 #else
2010     if (SvIsCOW(TARG))
2011         sv_force_normal_flags(TARG,0);
2012 #endif
2013     if (
2014 #ifdef PERL_OLD_COPY_ON_WRITE
2015         !is_cow &&
2016 #endif
2017         (SvREADONLY(TARG)
2018          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2019                || SvTYPE(TARG) > SVt_PVLV)
2020              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2021         DIE(aTHX_ PL_no_modify);
2022     PUTBACK;
2023
2024     s = SvPV_mutable(TARG, len);
2025     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2026         force_on_match = 1;
2027     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2028                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2029     if (PL_tainted)
2030         rxtainted |= 2;
2031     TAINT_NOT;
2032
2033     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2034
2035   force_it:
2036     if (!pm || !s)
2037         DIE(aTHX_ "panic: pp_subst");
2038
2039     strend = s + len;
2040     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2041     maxiters = 2 * slen + 10;   /* We can match twice at each
2042                                    position, once with zero-length,
2043                                    second time with non-zero. */
2044
2045     if (!rx->prelen && PL_curpm) {
2046         pm = PL_curpm;
2047         rx = PM_GETRE(pm);
2048     }
2049     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2050             || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
2051                ? REXEC_COPY_STR : 0;
2052     if (SvSCREAM(TARG))
2053         r_flags |= REXEC_SCREAM;
2054
2055     orig = m = s;
2056     if (rx->extflags & RXf_USE_INTUIT) {
2057         PL_bostr = orig;
2058         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2059
2060         if (!s)
2061             goto nope;
2062         /* How to do it in subst? */
2063 /*      if ( (rx->extflags & RXf_CHECK_ALL)
2064              && !PL_sawampersand
2065              && !(pm->op_pmflags & PMf_KEEPCOPY)
2066              && ((rx->extflags & RXf_NOSCAN)
2067                  || !((rx->extflags & RXf_INTUIT_TAIL)
2068                       && (r_flags & REXEC_SCREAM))))
2069             goto yup;
2070 */
2071     }
2072
2073     /* only replace once? */
2074     once = !(rpm->op_pmflags & PMf_GLOBAL);
2075
2076     /* known replacement string? */
2077     if (dstr) {
2078         /* replacement needing upgrading? */
2079         if (DO_UTF8(TARG) && !doutf8) {
2080              nsv = sv_newmortal();
2081              SvSetSV(nsv, dstr);
2082              if (PL_encoding)
2083                   sv_recode_to_utf8(nsv, PL_encoding);
2084              else
2085                   sv_utf8_upgrade(nsv);
2086              c = SvPV_const(nsv, clen);
2087              doutf8 = TRUE;
2088         }
2089         else {
2090             c = SvPV_const(dstr, clen);
2091             doutf8 = DO_UTF8(dstr);
2092         }
2093     }
2094     else {
2095         c = NULL;
2096         doutf8 = FALSE;
2097     }
2098
2099     /* can do inplace substitution? */
2100     if (c
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102         && !is_cow
2103 #endif
2104         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2105         && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2106         && (!doutf8 || SvUTF8(TARG))) {
2107         if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2108                          r_flags | REXEC_CHECKED))
2109         {
2110             SPAGAIN;
2111             PUSHs(&PL_sv_no);
2112             LEAVE_SCOPE(oldsave);
2113             RETURN;
2114         }
2115 #ifdef PERL_OLD_COPY_ON_WRITE
2116         if (SvIsCOW(TARG)) {
2117             assert (!force_on_match);
2118             goto have_a_cow;
2119         }
2120 #endif
2121         if (force_on_match) {
2122             force_on_match = 0;
2123             s = SvPV_force(TARG, len);
2124             goto force_it;
2125         }
2126         d = s;
2127         PL_curpm = pm;
2128         SvSCREAM_off(TARG);     /* disable possible screamer */
2129         if (once) {
2130             rxtainted |= RX_MATCH_TAINTED(rx);
2131             m = orig + rx->startp[0];
2132             d = orig + rx->endp[0];
2133             s = orig;
2134             if (m - s > strend - d) {  /* faster to shorten from end */
2135                 if (clen) {
2136                     Copy(c, m, clen, char);
2137                     m += clen;
2138                 }
2139                 i = strend - d;
2140                 if (i > 0) {
2141                     Move(d, m, i, char);
2142                     m += i;
2143                 }
2144                 *m = '\0';
2145                 SvCUR_set(TARG, m - s);
2146             }
2147             else if ((i = m - s)) {     /* faster from front */
2148                 d -= clen;
2149                 m = d;
2150                 sv_chop(TARG, d-i);
2151                 s += i;
2152                 while (i--)
2153                     *--d = *--s;
2154                 if (clen)
2155                     Copy(c, m, clen, char);
2156             }
2157             else if (clen) {
2158                 d -= clen;
2159                 sv_chop(TARG, d);
2160                 Copy(c, d, clen, char);
2161             }
2162             else {
2163                 sv_chop(TARG, d);
2164             }
2165             TAINT_IF(rxtainted & 1);
2166             SPAGAIN;
2167             PUSHs(&PL_sv_yes);
2168         }
2169         else {
2170             do {
2171                 if (iters++ > maxiters)
2172                     DIE(aTHX_ "Substitution loop");
2173                 rxtainted |= RX_MATCH_TAINTED(rx);
2174                 m = rx->startp[0] + orig;
2175                 if ((i = m - s)) {
2176                     if (s != d)
2177                         Move(s, d, i, char);
2178                     d += i;
2179                 }
2180                 if (clen) {
2181                     Copy(c, d, clen, char);
2182                     d += clen;
2183                 }
2184                 s = rx->endp[0] + orig;
2185             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2186                                  TARG, NULL,
2187                                  /* don't match same null twice */
2188                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2189             if (s != d) {
2190                 i = strend - s;
2191                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2192                 Move(s, d, i+1, char);          /* include the NUL */
2193             }
2194             TAINT_IF(rxtainted & 1);
2195             SPAGAIN;
2196             PUSHs(sv_2mortal(newSViv((I32)iters)));
2197         }
2198         (void)SvPOK_only_UTF8(TARG);
2199         TAINT_IF(rxtainted);
2200         if (SvSMAGICAL(TARG)) {
2201             PUTBACK;
2202             mg_set(TARG);
2203             SPAGAIN;
2204         }
2205         SvTAINT(TARG);
2206         if (doutf8)
2207             SvUTF8_on(TARG);
2208         LEAVE_SCOPE(oldsave);
2209         RETURN;
2210     }
2211
2212     if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2213                     r_flags | REXEC_CHECKED))
2214     {
2215         if (force_on_match) {
2216             force_on_match = 0;
2217             s = SvPV_force(TARG, len);
2218             goto force_it;
2219         }
2220 #ifdef PERL_OLD_COPY_ON_WRITE
2221       have_a_cow:
2222 #endif
2223         rxtainted |= RX_MATCH_TAINTED(rx);
2224         dstr = newSVpvn(m, s-m);
2225         SAVEFREESV(dstr);
2226         if (DO_UTF8(TARG))
2227             SvUTF8_on(dstr);
2228         PL_curpm = pm;
2229         if (!c) {
2230             register PERL_CONTEXT *cx;
2231             SPAGAIN;
2232             PUSHSUBST(cx);
2233             RETURNOP(cPMOP->op_pmreplroot);
2234         }
2235         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2236         do {
2237             if (iters++ > maxiters)
2238                 DIE(aTHX_ "Substitution loop");
2239             rxtainted |= RX_MATCH_TAINTED(rx);
2240             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2241                 m = s;
2242                 s = orig;
2243                 orig = rx->subbeg;
2244                 s = orig + (m - s);
2245                 strend = s + (strend - m);
2246             }
2247             m = rx->startp[0] + orig;
2248             if (doutf8 && !SvUTF8(dstr))
2249                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2250             else
2251                 sv_catpvn(dstr, s, m-s);
2252             s = rx->endp[0] + orig;
2253             if (clen)
2254                 sv_catpvn(dstr, c, clen);
2255             if (once)
2256                 break;
2257         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2258                              TARG, NULL, r_flags));
2259         if (doutf8 && !DO_UTF8(TARG))
2260             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2261         else
2262             sv_catpvn(dstr, s, strend - s);
2263
2264 #ifdef PERL_OLD_COPY_ON_WRITE
2265         /* The match may make the string COW. If so, brilliant, because that's
2266            just saved us one malloc, copy and free - the regexp has donated
2267            the old buffer, and we malloc an entirely new one, rather than the
2268            regexp malloc()ing a buffer and copying our original, only for
2269            us to throw it away here during the substitution.  */
2270         if (SvIsCOW(TARG)) {
2271             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2272         } else
2273 #endif
2274         {
2275             SvPV_free(TARG);
2276         }
2277         SvPV_set(TARG, SvPVX(dstr));
2278         SvCUR_set(TARG, SvCUR(dstr));
2279         SvLEN_set(TARG, SvLEN(dstr));
2280         doutf8 |= DO_UTF8(dstr);
2281         SvPV_set(dstr, NULL);
2282
2283         TAINT_IF(rxtainted & 1);
2284         SPAGAIN;
2285         PUSHs(sv_2mortal(newSViv((I32)iters)));
2286
2287         (void)SvPOK_only(TARG);
2288         if (doutf8)
2289             SvUTF8_on(TARG);
2290         TAINT_IF(rxtainted);
2291         SvSETMAGIC(TARG);
2292         SvTAINT(TARG);
2293         LEAVE_SCOPE(oldsave);
2294         RETURN;
2295     }
2296     goto ret_no;
2297
2298 nope:
2299 ret_no:
2300     SPAGAIN;
2301     PUSHs(&PL_sv_no);
2302     LEAVE_SCOPE(oldsave);
2303     RETURN;
2304 }
2305
2306 PP(pp_grepwhile)
2307 {
2308     dVAR; dSP;
2309
2310     if (SvTRUEx(POPs))
2311         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2312     ++*PL_markstack_ptr;
2313     LEAVE;                                      /* exit inner scope */
2314
2315     /* All done yet? */
2316     if (PL_stack_base + *PL_markstack_ptr > SP) {
2317         I32 items;
2318         const I32 gimme = GIMME_V;
2319
2320         LEAVE;                                  /* exit outer scope */
2321         (void)POPMARK;                          /* pop src */
2322         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2323         (void)POPMARK;                          /* pop dst */
2324         SP = PL_stack_base + POPMARK;           /* pop original mark */
2325         if (gimme == G_SCALAR) {
2326             if (PL_op->op_private & OPpGREP_LEX) {
2327                 SV* const sv = sv_newmortal();
2328                 sv_setiv(sv, items);
2329                 PUSHs(sv);
2330             }
2331             else {
2332                 dTARGET;
2333                 XPUSHi(items);
2334             }
2335         }
2336         else if (gimme == G_ARRAY)
2337             SP += items;
2338         RETURN;
2339     }
2340     else {
2341         SV *src;
2342
2343         ENTER;                                  /* enter inner scope */
2344         SAVEVPTR(PL_curpm);
2345
2346         src = PL_stack_base[*PL_markstack_ptr];
2347         SvTEMP_off(src);
2348         if (PL_op->op_private & OPpGREP_LEX)
2349             PAD_SVl(PL_op->op_targ) = src;
2350         else
2351             DEFSV = src;
2352
2353         RETURNOP(cLOGOP->op_other);
2354     }
2355 }
2356
2357 PP(pp_leavesub)
2358 {
2359     dVAR; dSP;
2360     SV **mark;
2361     SV **newsp;
2362     PMOP *newpm;
2363     I32 gimme;
2364     register PERL_CONTEXT *cx;
2365     SV *sv;
2366
2367     if (CxMULTICALL(&cxstack[cxstack_ix]))
2368         return 0;
2369
2370     POPBLOCK(cx,newpm);
2371     cxstack_ix++; /* temporarily protect top context */
2372
2373     TAINT_NOT;
2374     if (gimme == G_SCALAR) {
2375         MARK = newsp + 1;
2376         if (MARK <= SP) {
2377             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2378                 if (SvTEMP(TOPs)) {
2379                     *MARK = SvREFCNT_inc(TOPs);
2380                     FREETMPS;
2381                     sv_2mortal(*MARK);
2382                 }
2383                 else {
2384                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2385                     FREETMPS;
2386                     *MARK = sv_mortalcopy(sv);
2387                     SvREFCNT_dec(sv);
2388                 }
2389             }
2390             else
2391                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2392         }
2393         else {
2394             MEXTEND(MARK, 0);
2395             *MARK = &PL_sv_undef;
2396         }
2397         SP = MARK;
2398     }
2399     else if (gimme == G_ARRAY) {
2400         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2401             if (!SvTEMP(*MARK)) {
2402                 *MARK = sv_mortalcopy(*MARK);
2403                 TAINT_NOT;      /* Each item is independent */
2404             }
2405         }
2406     }
2407     PUTBACK;
2408
2409     LEAVE;
2410     cxstack_ix--;
2411     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2412     PL_curpm = newpm;   /* ... and pop $1 et al */
2413
2414     LEAVESUB(sv);
2415     return cx->blk_sub.retop;
2416 }
2417
2418 /* This duplicates the above code because the above code must not
2419  * get any slower by more conditions */
2420 PP(pp_leavesublv)
2421 {
2422     dVAR; dSP;
2423     SV **mark;
2424     SV **newsp;
2425     PMOP *newpm;
2426     I32 gimme;
2427     register PERL_CONTEXT *cx;
2428     SV *sv;
2429
2430     if (CxMULTICALL(&cxstack[cxstack_ix]))
2431         return 0;
2432
2433     POPBLOCK(cx,newpm);
2434     cxstack_ix++; /* temporarily protect top context */
2435
2436     TAINT_NOT;
2437
2438     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2439         /* We are an argument to a function or grep().
2440          * This kind of lvalueness was legal before lvalue
2441          * subroutines too, so be backward compatible:
2442          * cannot report errors.  */
2443
2444         /* Scalar context *is* possible, on the LHS of -> only,
2445          * as in f()->meth().  But this is not an lvalue. */
2446         if (gimme == G_SCALAR)
2447             goto temporise;
2448         if (gimme == G_ARRAY) {
2449             if (!CvLVALUE(cx->blk_sub.cv))
2450                 goto temporise_array;
2451             EXTEND_MORTAL(SP - newsp);
2452             for (mark = newsp + 1; mark <= SP; mark++) {
2453                 if (SvTEMP(*mark))
2454                     NOOP;
2455                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2456                     *mark = sv_mortalcopy(*mark);
2457                 else {
2458                     /* Can be a localized value subject to deletion. */
2459                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2460                     SvREFCNT_inc_void(*mark);
2461                 }
2462             }
2463         }
2464     }
2465     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2466         /* Here we go for robustness, not for speed, so we change all
2467          * the refcounts so the caller gets a live guy. Cannot set
2468          * TEMP, so sv_2mortal is out of question. */
2469         if (!CvLVALUE(cx->blk_sub.cv)) {
2470             LEAVE;
2471             cxstack_ix--;
2472             POPSUB(cx,sv);
2473             PL_curpm = newpm;
2474             LEAVESUB(sv);
2475             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2476         }
2477         if (gimme == G_SCALAR) {
2478             MARK = newsp + 1;
2479             EXTEND_MORTAL(1);
2480             if (MARK == SP) {
2481                 /* Temporaries are bad unless they happen to be elements
2482                  * of a tied hash or array */
2483                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2484                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2485                     LEAVE;
2486                     cxstack_ix--;
2487                     POPSUB(cx,sv);
2488                     PL_curpm = newpm;
2489                     LEAVESUB(sv);
2490                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2491                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2492                         : "a readonly value" : "a temporary");
2493                 }
2494                 else {                  /* Can be a localized value
2495                                          * subject to deletion. */
2496                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2497                     SvREFCNT_inc_void(*mark);
2498                 }
2499             }
2500             else {                      /* Should not happen? */
2501                 LEAVE;
2502                 cxstack_ix--;
2503                 POPSUB(cx,sv);
2504                 PL_curpm = newpm;
2505                 LEAVESUB(sv);
2506                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2507                     (MARK > SP ? "Empty array" : "Array"));
2508             }
2509             SP = MARK;
2510         }
2511         else if (gimme == G_ARRAY) {
2512             EXTEND_MORTAL(SP - newsp);
2513             for (mark = newsp + 1; mark <= SP; mark++) {
2514                 if (*mark != &PL_sv_undef
2515                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2516                     /* Might be flattened array after $#array =  */
2517                     PUTBACK;
2518                     LEAVE;
2519                     cxstack_ix--;
2520                     POPSUB(cx,sv);
2521                     PL_curpm = newpm;
2522                     LEAVESUB(sv);
2523                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2524                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2525                 }
2526                 else {
2527                     /* Can be a localized value subject to deletion. */
2528                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2529                     SvREFCNT_inc_void(*mark);
2530                 }
2531             }
2532         }
2533     }
2534     else {
2535         if (gimme == G_SCALAR) {
2536           temporise:
2537             MARK = newsp + 1;
2538             if (MARK <= SP) {
2539                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2540                     if (SvTEMP(TOPs)) {
2541                         *MARK = SvREFCNT_inc(TOPs);
2542                         FREETMPS;
2543                         sv_2mortal(*MARK);
2544                     }
2545                     else {
2546                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2547                         FREETMPS;
2548                         *MARK = sv_mortalcopy(sv);
2549                         SvREFCNT_dec(sv);
2550                     }
2551                 }
2552                 else
2553                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2554             }
2555             else {
2556                 MEXTEND(MARK, 0);
2557                 *MARK = &PL_sv_undef;
2558             }
2559             SP = MARK;
2560         }
2561         else if (gimme == G_ARRAY) {
2562           temporise_array:
2563             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2564                 if (!SvTEMP(*MARK)) {
2565                     *MARK = sv_mortalcopy(*MARK);
2566                     TAINT_NOT;  /* Each item is independent */
2567                 }
2568             }
2569         }
2570     }
2571     PUTBACK;
2572
2573     LEAVE;
2574     cxstack_ix--;
2575     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2576     PL_curpm = newpm;   /* ... and pop $1 et al */
2577
2578     LEAVESUB(sv);
2579     return cx->blk_sub.retop;
2580 }
2581
2582 PP(pp_entersub)
2583 {
2584     dVAR; dSP; dPOPss;
2585     GV *gv;
2586     register CV *cv;
2587     register PERL_CONTEXT *cx;
2588     I32 gimme;
2589     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2590
2591     if (!sv)
2592         DIE(aTHX_ "Not a CODE reference");
2593     switch (SvTYPE(sv)) {
2594         /* This is overwhelming the most common case:  */
2595     case SVt_PVGV:
2596         if (!(cv = GvCVu((GV*)sv))) {
2597             HV *stash;
2598             cv = sv_2cv(sv, &stash, &gv, 0);
2599         }
2600         if (!cv) {
2601             ENTER;
2602             SAVETMPS;
2603             goto try_autoload;
2604         }
2605         break;
2606     default:
2607         if (!SvROK(sv)) {
2608             const char *sym;
2609             STRLEN len;
2610             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2611                 if (hasargs)
2612                     SP = PL_stack_base + POPMARK;
2613                 RETURN;
2614             }
2615             if (SvGMAGICAL(sv)) {
2616                 mg_get(sv);
2617                 if (SvROK(sv))
2618                     goto got_rv;
2619                 if (SvPOKp(sv)) {
2620                     sym = SvPVX_const(sv);
2621                     len = SvCUR(sv);
2622                 } else {
2623                     sym = NULL;
2624                     len = 0;
2625                 }
2626             }
2627             else {
2628                 sym = SvPV_const(sv, len);
2629             }
2630             if (!sym)
2631                 DIE(aTHX_ PL_no_usym, "a subroutine");
2632             if (PL_op->op_private & HINT_STRICT_REFS)
2633                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2634             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2635             break;
2636         }
2637   got_rv:
2638         {
2639             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2640             tryAMAGICunDEREF(to_cv);
2641         }
2642         cv = (CV*)SvRV(sv);
2643         if (SvTYPE(cv) == SVt_PVCV)
2644             break;
2645         /* FALL THROUGH */
2646     case SVt_PVHV:
2647     case SVt_PVAV:
2648         DIE(aTHX_ "Not a CODE reference");
2649         /* This is the second most common case:  */
2650     case SVt_PVCV:
2651         cv = (CV*)sv;
2652         break;
2653     }
2654
2655     ENTER;
2656     SAVETMPS;
2657
2658   retry:
2659     if (!CvROOT(cv) && !CvXSUB(cv)) {
2660         GV* autogv;
2661         SV* sub_name;
2662
2663         /* anonymous or undef'd function leaves us no recourse */
2664         if (CvANON(cv) || !(gv = CvGV(cv)))
2665             DIE(aTHX_ "Undefined subroutine called");
2666
2667         /* autoloaded stub? */
2668         if (cv != GvCV(gv)) {
2669             cv = GvCV(gv);
2670         }
2671         /* should call AUTOLOAD now? */
2672         else {
2673 try_autoload:
2674             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2675                                    FALSE)))
2676             {
2677                 cv = GvCV(autogv);
2678             }
2679             /* sorry */
2680             else {
2681                 sub_name = sv_newmortal();
2682                 gv_efullname3(sub_name, gv, NULL);
2683                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2684             }
2685         }
2686         if (!cv)
2687             DIE(aTHX_ "Not a CODE reference");
2688         goto retry;
2689     }
2690
2691     gimme = GIMME_V;
2692     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2693         if (CvASSERTION(cv) && PL_DBassertion)
2694             sv_setiv(PL_DBassertion, 1);
2695
2696          Perl_get_db_sub(aTHX_ &sv, cv);
2697          if (CvISXSUB(cv))
2698              PL_curcopdb = PL_curcop;
2699          cv = GvCV(PL_DBsub);
2700
2701         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2702             DIE(aTHX_ "No DB::sub routine defined");
2703     }
2704
2705     if (!(CvISXSUB(cv))) {
2706         /* This path taken at least 75% of the time   */
2707         dMARK;
2708         register I32 items = SP - MARK;
2709         AV* const padlist = CvPADLIST(cv);
2710         PUSHBLOCK(cx, CXt_SUB, MARK);
2711         PUSHSUB(cx);
2712         cx->blk_sub.retop = PL_op->op_next;
2713         CvDEPTH(cv)++;
2714         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2715          * that eval'' ops within this sub know the correct lexical space.
2716          * Owing the speed considerations, we choose instead to search for
2717          * the cv using find_runcv() when calling doeval().
2718          */
2719         if (CvDEPTH(cv) >= 2) {
2720             PERL_STACK_OVERFLOW_CHECK();
2721             pad_push(padlist, CvDEPTH(cv));
2722         }
2723         SAVECOMPPAD();
2724         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2725         if (hasargs) {
2726             AV* const av = (AV*)PAD_SVl(0);
2727             if (AvREAL(av)) {
2728                 /* @_ is normally not REAL--this should only ever
2729                  * happen when DB::sub() calls things that modify @_ */
2730                 av_clear(av);
2731                 AvREAL_off(av);
2732                 AvREIFY_on(av);
2733             }
2734             cx->blk_sub.savearray = GvAV(PL_defgv);
2735             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2736             CX_CURPAD_SAVE(cx->blk_sub);
2737             cx->blk_sub.argarray = av;
2738             ++MARK;
2739
2740             if (items > AvMAX(av) + 1) {
2741                 SV **ary = AvALLOC(av);
2742                 if (AvARRAY(av) != ary) {
2743                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2744                     AvARRAY(av) = ary;
2745                 }
2746                 if (items > AvMAX(av) + 1) {
2747                     AvMAX(av) = items - 1;
2748                     Renew(ary,items,SV*);
2749                     AvALLOC(av) = ary;
2750                     AvARRAY(av) = ary;
2751                 }
2752             }
2753             Copy(MARK,AvARRAY(av),items,SV*);
2754             AvFILLp(av) = items - 1;
2755
2756             while (items--) {
2757                 if (*MARK)
2758                     SvTEMP_off(*MARK);
2759                 MARK++;
2760             }
2761         }
2762         /* warning must come *after* we fully set up the context
2763          * stuff so that __WARN__ handlers can safely dounwind()
2764          * if they want to
2765          */
2766         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2767             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2768             sub_crush_depth(cv);
2769 #if 0
2770         DEBUG_S(PerlIO_printf(Perl_debug_log,
2771                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2772 #endif
2773         RETURNOP(CvSTART(cv));
2774     }
2775     else {
2776         I32 markix = TOPMARK;
2777
2778         PUTBACK;
2779
2780         if (!hasargs) {
2781             /* Need to copy @_ to stack. Alternative may be to
2782              * switch stack to @_, and copy return values
2783              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2784             AV * const av = GvAV(PL_defgv);
2785             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2786
2787             if (items) {
2788                 /* Mark is at the end of the stack. */
2789                 EXTEND(SP, items);
2790                 Copy(AvARRAY(av), SP + 1, items, SV*);
2791                 SP += items;
2792                 PUTBACK ;
2793             }
2794         }
2795         /* We assume first XSUB in &DB::sub is the called one. */
2796         if (PL_curcopdb) {
2797             SAVEVPTR(PL_curcop);
2798             PL_curcop = PL_curcopdb;
2799             PL_curcopdb = NULL;
2800         }
2801         /* Do we need to open block here? XXXX */
2802         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2803             (void)(*CvXSUB(cv))(aTHX_ cv);
2804
2805         /* Enforce some sanity in scalar context. */
2806         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2807             if (markix > PL_stack_sp - PL_stack_base)
2808                 *(PL_stack_base + markix) = &PL_sv_undef;
2809             else
2810                 *(PL_stack_base + markix) = *PL_stack_sp;
2811             PL_stack_sp = PL_stack_base + markix;
2812         }
2813         LEAVE;
2814         return NORMAL;
2815     }
2816 }
2817
2818 void
2819 Perl_sub_crush_depth(pTHX_ CV *cv)
2820 {
2821     if (CvANON(cv))
2822         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2823     else {
2824         SV* const tmpstr = sv_newmortal();
2825         gv_efullname3(tmpstr, CvGV(cv), NULL);
2826         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2827                     SVfARG(tmpstr));
2828     }
2829 }
2830
2831 PP(pp_aelem)
2832 {
2833     dVAR; dSP;
2834     SV** svp;
2835     SV* const elemsv = POPs;
2836     IV elem = SvIV(elemsv);
2837     AV* const av = (AV*)POPs;
2838     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2839     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2840     SV *sv;
2841
2842     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2843         Perl_warner(aTHX_ packWARN(WARN_MISC),
2844                     "Use of reference \"%"SVf"\" as array index",
2845                     SVfARG(elemsv));
2846     if (elem > 0)
2847         elem -= CopARYBASE_get(PL_curcop);
2848     if (SvTYPE(av) != SVt_PVAV)
2849         RETPUSHUNDEF;
2850     svp = av_fetch(av, elem, lval && !defer);
2851     if (lval) {
2852 #ifdef PERL_MALLOC_WRAP
2853          if (SvUOK(elemsv)) {
2854               const UV uv = SvUV(elemsv);
2855               elem = uv > IV_MAX ? IV_MAX : uv;
2856          }
2857          else if (SvNOK(elemsv))
2858               elem = (IV)SvNV(elemsv);
2859          if (elem > 0) {
2860               static const char oom_array_extend[] =
2861                 "Out of memory during array extend"; /* Duplicated in av.c */
2862               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2863          }
2864 #endif
2865         if (!svp || *svp == &PL_sv_undef) {
2866             SV* lv;
2867             if (!defer)
2868                 DIE(aTHX_ PL_no_aelem, elem);
2869             lv = sv_newmortal();
2870             sv_upgrade(lv, SVt_PVLV);
2871             LvTYPE(lv) = 'y';
2872             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2873             LvTARG(lv) = SvREFCNT_inc_simple(av);
2874             LvTARGOFF(lv) = elem;
2875             LvTARGLEN(lv) = 1;
2876             PUSHs(lv);
2877             RETURN;
2878         }
2879         if (PL_op->op_private & OPpLVAL_INTRO)
2880             save_aelem(av, elem, svp);
2881         else if (PL_op->op_private & OPpDEREF)
2882             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2883     }
2884     sv = (svp ? *svp : &PL_sv_undef);
2885     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2886         sv = sv_mortalcopy(sv);
2887     PUSHs(sv);
2888     RETURN;
2889 }
2890
2891 void
2892 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2893 {
2894     SvGETMAGIC(sv);
2895     if (!SvOK(sv)) {
2896         if (SvREADONLY(sv))
2897             Perl_croak(aTHX_ PL_no_modify);
2898         if (SvTYPE(sv) < SVt_RV)
2899             sv_upgrade(sv, SVt_RV);
2900         else if (SvTYPE(sv) >= SVt_PV) {
2901             SvPV_free(sv);
2902             SvLEN_set(sv, 0);
2903             SvCUR_set(sv, 0);
2904         }
2905         switch (to_what) {
2906         case OPpDEREF_SV:
2907             SvRV_set(sv, newSV(0));
2908             break;
2909         case OPpDEREF_AV:
2910             SvRV_set(sv, (SV*)newAV());
2911             break;
2912         case OPpDEREF_HV:
2913             SvRV_set(sv, (SV*)newHV());
2914             break;
2915         }
2916         SvROK_on(sv);
2917         SvSETMAGIC(sv);
2918     }
2919 }
2920
2921 PP(pp_method)
2922 {
2923     dVAR; dSP;
2924     SV* const sv = TOPs;
2925
2926     if (SvROK(sv)) {
2927         SV* const rsv = SvRV(sv);
2928         if (SvTYPE(rsv) == SVt_PVCV) {
2929             SETs(rsv);
2930             RETURN;
2931         }
2932     }
2933
2934     SETs(method_common(sv, NULL));
2935     RETURN;
2936 }
2937
2938 PP(pp_method_named)
2939 {
2940     dVAR; dSP;
2941     SV* const sv = cSVOP_sv;
2942     U32 hash = SvSHARED_HASH(sv);
2943
2944     XPUSHs(method_common(sv, &hash));
2945     RETURN;
2946 }
2947
2948 STATIC SV *
2949 S_method_common(pTHX_ SV* meth, U32* hashp)
2950 {
2951     dVAR;
2952     SV* ob;
2953     GV* gv;
2954     HV* stash;
2955     STRLEN namelen;
2956     const char* packname = NULL;
2957     SV *packsv = NULL;
2958     STRLEN packlen;
2959     const char * const name = SvPV_const(meth, namelen);
2960     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2961
2962     if (!sv)
2963         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2964
2965     SvGETMAGIC(sv);
2966     if (SvROK(sv))
2967         ob = (SV*)SvRV(sv);
2968     else {
2969         GV* iogv;
2970
2971         /* this isn't a reference */
2972         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2973           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2974           if (he) {
2975             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2976             goto fetch;
2977           }
2978         }
2979
2980         if (!SvOK(sv) ||
2981             !(packname) ||
2982             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2983             !(ob=(SV*)GvIO(iogv)))
2984         {
2985             /* this isn't the name of a filehandle either */
2986             if (!packname ||
2987                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2988                     ? !isIDFIRST_utf8((U8*)packname)
2989                     : !isIDFIRST(*packname)
2990                 ))
2991             {
2992                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2993                            SvOK(sv) ? "without a package or object reference"
2994                                     : "on an undefined value");
2995             }
2996             /* assume it's a package name */
2997             stash = gv_stashpvn(packname, packlen, 0);
2998             if (!stash)
2999                 packsv = sv;
3000             else {
3001                 SV* const ref = newSViv(PTR2IV(stash));
3002                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3003             }
3004             goto fetch;
3005         }
3006         /* it _is_ a filehandle name -- replace with a reference */
3007         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3008     }
3009
3010     /* if we got here, ob should be a reference or a glob */
3011     if (!ob || !(SvOBJECT(ob)
3012                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3013                      && SvOBJECT(ob))))
3014     {
3015         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3016                    name);
3017     }
3018
3019     stash = SvSTASH(ob);
3020
3021   fetch:
3022     /* NOTE: stash may be null, hope hv_fetch_ent and
3023        gv_fetchmethod can cope (it seems they can) */
3024
3025     /* shortcut for simple names */
3026     if (hashp) {
3027         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3028         if (he) {
3029             gv = (GV*)HeVAL(he);
3030             if (isGV(gv) && GvCV(gv) &&
3031                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3032                 return (SV*)GvCV(gv);
3033         }
3034     }
3035
3036     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3037
3038     if (!gv) {
3039         /* This code tries to figure out just what went wrong with
3040            gv_fetchmethod.  It therefore needs to duplicate a lot of
3041            the internals of that function.  We can't move it inside
3042            Perl_gv_fetchmethod_autoload(), however, since that would
3043            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3044            don't want that.
3045         */
3046         const char* leaf = name;
3047         const char* sep = NULL;
3048         const char* p;
3049
3050         for (p = name; *p; p++) {
3051             if (*p == '\'')
3052                 sep = p, leaf = p + 1;
3053             else if (*p == ':' && *(p + 1) == ':')
3054                 sep = p, leaf = p + 2;
3055         }
3056         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3057             /* the method name is unqualified or starts with SUPER:: */
3058             bool need_strlen = 1;
3059             if (sep) {
3060                 packname = CopSTASHPV(PL_curcop);
3061             }
3062             else if (stash) {
3063                 HEK * const packhek = HvNAME_HEK(stash);
3064                 if (packhek) {
3065                     packname = HEK_KEY(packhek);
3066                     packlen = HEK_LEN(packhek);
3067                     need_strlen = 0;
3068                 } else {
3069                     goto croak;
3070                 }
3071             }
3072
3073             if (!packname) {
3074             croak:
3075                 Perl_croak(aTHX_
3076                            "Can't use anonymous symbol table for method lookup");
3077             }
3078             else if (need_strlen)
3079                 packlen = strlen(packname);
3080
3081         }
3082         else {
3083             /* the method name is qualified */
3084             packname = name;
3085             packlen = sep - name;
3086         }
3087
3088         /* we're relying on gv_fetchmethod not autovivifying the stash */
3089         if (gv_stashpvn(packname, packlen, 0)) {
3090             Perl_croak(aTHX_
3091                        "Can't locate object method \"%s\" via package \"%.*s\"",
3092                        leaf, (int)packlen, packname);
3093         }
3094         else {
3095             Perl_croak(aTHX_
3096                        "Can't locate object method \"%s\" via package \"%.*s\""
3097                        " (perhaps you forgot to load \"%.*s\"?)",
3098                        leaf, (int)packlen, packname, (int)packlen, packname);
3099         }
3100     }
3101     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3102 }
3103
3104 /*
3105  * Local variables:
3106  * c-indentation-style: bsd
3107  * c-basic-offset: 4
3108  * indent-tabs-mode: t
3109  * End:
3110  *
3111  * ex: set ts=8 sts=4 sw=4 noet:
3112  */