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