pp_hot.c

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