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