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