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