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