pp_hot.c

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