pp_hot.c

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