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