pp_hot.c

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