pp_hot.c

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