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