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