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