pp_hot.c

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