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