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