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     PUTBACK;                            /* EVAL blocks need stack_sp. */
1183     s = SvPV(TARG, len);
1184     strend = s + len;
1185     if (!s)
1186         DIE(aTHX_ "panic: do_match");
1187     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1188                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1189     TAINT_NOT;
1190
1191     if (pm->op_pmdynflags & PMdf_USED) {
1192       failure:
1193         if (gimme == G_ARRAY)
1194             RETURN;
1195         RETPUSHNO;
1196     }
1197
1198     if (!rx->prelen && PL_curpm) {
1199         pm = PL_curpm;
1200         rx = pm->op_pmregexp;
1201     }
1202     if (rx->minlen > len) goto failure;
1203
1204     truebase = t = s;
1205
1206     /* XXXX What part of this is needed with true \G-support? */
1207     if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1208         rx->startp[0] = -1;
1209         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1210             MAGIC* mg = mg_find(TARG, 'g');
1211             if (mg && mg->mg_len >= 0) {
1212                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1213                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1214                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1215                     r_flags |= REXEC_IGNOREPOS;
1216                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1217                 }
1218                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1219                 update_minmatch = 0;
1220             }
1221         }
1222     }
1223     if ((gimme != G_ARRAY && !global && rx->nparens)
1224             || SvTEMP(TARG) || PL_sawampersand)
1225         r_flags |= REXEC_COPY_STR;
1226     if (SvSCREAM(TARG))
1227         r_flags |= REXEC_SCREAM;
1228
1229     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1230         SAVEINT(PL_multiline);
1231         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1232     }
1233
1234 play_it_again:
1235     if (global && rx->startp[0] != -1) {
1236         t = s = rx->endp[0] + truebase;
1237         if ((s + rx->minlen) > strend)
1238             goto nope;
1239         if (update_minmatch++)
1240             minmatch = had_zerolen;
1241     }
1242     if (rx->reganch & RE_USE_INTUIT) {
1243         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1244
1245         if (!s)
1246             goto nope;
1247         if ( (rx->reganch & ROPT_CHECK_ALL)
1248              && !PL_sawampersand
1249              && ((rx->reganch & ROPT_NOSCAN)
1250                  || !((rx->reganch & RE_INTUIT_TAIL)
1251                       && (r_flags & REXEC_SCREAM)))
1252              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1253             goto yup;
1254     }
1255     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1256     {
1257         PL_curpm = pm;
1258         if (pm->op_pmflags & PMf_ONCE)
1259             pm->op_pmdynflags |= PMdf_USED;
1260         goto gotcha;
1261     }
1262     else
1263         goto ret_no;
1264     /*NOTREACHED*/
1265
1266   gotcha:
1267     if (rxtainted)
1268         RX_MATCH_TAINTED_on(rx);
1269     TAINT_IF(RX_MATCH_TAINTED(rx));
1270     if (gimme == G_ARRAY) {
1271         I32 iters, i, len;
1272
1273         iters = rx->nparens;
1274         if (global && !iters)
1275             i = 1;
1276         else
1277             i = 0;
1278         SPAGAIN;                        /* EVAL blocks could move the stack. */
1279         EXTEND(SP, iters + i);
1280         EXTEND_MORTAL(iters + i);
1281         for (i = !i; i <= iters; i++) {
1282             PUSHs(sv_newmortal());
1283             /*SUPPRESS 560*/
1284             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1285                 len = rx->endp[i] - rx->startp[i];
1286                 s = rx->startp[i] + truebase;
1287                 sv_setpvn(*SP, s, len);
1288                 if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
1289                     SvUTF8_on(*SP);
1290                     sv_utf8_downgrade(*SP, TRUE);
1291                 }
1292             }
1293         }
1294         if (global) {
1295             had_zerolen = (rx->startp[0] != -1
1296                            && rx->startp[0] == rx->endp[0]);
1297             PUTBACK;                    /* EVAL blocks may use stack */
1298             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1299             goto play_it_again;
1300         }
1301         else if (!iters)
1302             XPUSHs(&PL_sv_yes);
1303         LEAVE_SCOPE(oldsave);
1304         RETURN;
1305     }
1306     else {
1307         if (global) {
1308             MAGIC* mg = 0;
1309             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1310                 mg = mg_find(TARG, 'g');
1311             if (!mg) {
1312                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1313                 mg = mg_find(TARG, 'g');
1314             }
1315             if (rx->startp[0] != -1) {
1316                 mg->mg_len = rx->endp[0];
1317                 if (rx->startp[0] == rx->endp[0])
1318                     mg->mg_flags |= MGf_MINMATCH;
1319                 else
1320                     mg->mg_flags &= ~MGf_MINMATCH;
1321             }
1322         }
1323         LEAVE_SCOPE(oldsave);
1324         RETPUSHYES;
1325     }
1326
1327 yup:                                    /* Confirmed by INTUIT */
1328     if (rxtainted)
1329         RX_MATCH_TAINTED_on(rx);
1330     TAINT_IF(RX_MATCH_TAINTED(rx));
1331     PL_curpm = pm;
1332     if (pm->op_pmflags & PMf_ONCE)
1333         pm->op_pmdynflags |= PMdf_USED;
1334     if (RX_MATCH_COPIED(rx))
1335         Safefree(rx->subbeg);
1336     RX_MATCH_COPIED_off(rx);
1337     rx->subbeg = Nullch;
1338     if (global) {
1339         rx->subbeg = truebase;
1340         rx->startp[0] = s - truebase;
1341         rx->endp[0] = s - truebase + rx->minlen;
1342         rx->sublen = strend - truebase;
1343         goto gotcha;
1344     }
1345     if (PL_sawampersand) {
1346         I32 off;
1347
1348         rx->subbeg = savepvn(t, strend - t);
1349         rx->sublen = strend - t;
1350         RX_MATCH_COPIED_on(rx);
1351         off = rx->startp[0] = s - t;
1352         rx->endp[0] = off + rx->minlen;
1353     }
1354     else {                      /* startp/endp are used by @- @+. */
1355         rx->startp[0] = s - truebase;
1356         rx->endp[0] = s - truebase + rx->minlen;
1357     }
1358     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1359     LEAVE_SCOPE(oldsave);
1360     RETPUSHYES;
1361
1362 nope:
1363 ret_no:
1364     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1365         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1366             MAGIC* mg = mg_find(TARG, 'g');
1367             if (mg)
1368                 mg->mg_len = -1;
1369         }
1370     }
1371     LEAVE_SCOPE(oldsave);
1372     if (gimme == G_ARRAY)
1373         RETURN;
1374     RETPUSHNO;
1375 }
1376
1377 OP *
1378 Perl_do_readline(pTHX)
1379 {
1380     dSP; dTARGETSTACKED;
1381     register SV *sv;
1382     STRLEN tmplen = 0;
1383     STRLEN offset;
1384     PerlIO *fp;
1385     register IO *io = GvIO(PL_last_in_gv);
1386     register I32 type = PL_op->op_type;
1387     I32 gimme = GIMME_V;
1388     MAGIC *mg;
1389
1390     if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1391         PUSHMARK(SP);
1392         XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1393         PUTBACK;
1394         ENTER;
1395         call_method("READLINE", gimme);
1396         LEAVE;
1397         SPAGAIN;
1398         if (gimme == G_SCALAR)
1399             SvSetMagicSV_nosteal(TARG, TOPs);
1400         RETURN;
1401     }
1402     fp = Nullfp;
1403     if (io) {
1404         fp = IoIFP(io);
1405         if (!fp) {
1406             if (IoFLAGS(io) & IOf_ARGV) {
1407                 if (IoFLAGS(io) & IOf_START) {
1408                     IoLINES(io) = 0;
1409                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1410                         IoFLAGS(io) &= ~IOf_START;
1411                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1412                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1413                         SvSETMAGIC(GvSV(PL_last_in_gv));
1414                         fp = IoIFP(io);
1415                         goto have_fp;
1416                     }
1417                 }
1418                 fp = nextargv(PL_last_in_gv);
1419                 if (!fp) { /* Note: fp != IoIFP(io) */
1420                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1421                 }
1422             }
1423             else if (type == OP_GLOB)
1424                 fp = Perl_start_glob(aTHX_ POPs, io);
1425         }
1426         else if (type == OP_GLOB)
1427             SP--;
1428         else if (ckWARN(WARN_IO)        /* stdout/stderr or other write fh */
1429                  && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1430                      || fp == PerlIO_stderr()))
1431             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1432     }
1433     if (!fp) {
1434         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1435                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1436             if (type == OP_GLOB)
1437                 Perl_warner(aTHX_ WARN_GLOB,
1438                             "glob failed (can't start child: %s)",
1439                             Strerror(errno));
1440             else
1441                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1442         }
1443         if (gimme == G_SCALAR) {
1444             (void)SvOK_off(TARG);
1445             PUSHTARG;
1446         }
1447         RETURN;
1448     }
1449   have_fp:
1450     if (gimme == G_SCALAR) {
1451         sv = TARG;
1452         if (SvROK(sv))
1453             sv_unref(sv);
1454         (void)SvUPGRADE(sv, SVt_PV);
1455         tmplen = SvLEN(sv);     /* remember if already alloced */
1456         if (!tmplen)
1457             Sv_Grow(sv, 80);    /* try short-buffering it */
1458         if (type == OP_RCATLINE)
1459             offset = SvCUR(sv);
1460         else
1461             offset = 0;
1462     }
1463     else {
1464         sv = sv_2mortal(NEWSV(57, 80));
1465         offset = 0;
1466     }
1467
1468     /* This should not be marked tainted if the fp is marked clean */
1469 #define MAYBE_TAINT_LINE(io, sv) \
1470     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1471         TAINT;                          \
1472         SvTAINTED_on(sv);               \
1473     }
1474
1475 /* delay EOF state for a snarfed empty file */
1476 #define SNARF_EOF(gimme,rs,io,sv) \
1477     (gimme != G_SCALAR || SvCUR(sv)                                     \
1478      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1479
1480     for (;;) {
1481         if (!sv_gets(sv, fp, offset)
1482             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1483         {
1484             PerlIO_clearerr(fp);
1485             if (IoFLAGS(io) & IOf_ARGV) {
1486                 fp = nextargv(PL_last_in_gv);
1487                 if (fp)
1488                     continue;
1489                 (void)do_close(PL_last_in_gv, FALSE);
1490             }
1491             else if (type == OP_GLOB) {
1492                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1493                     Perl_warner(aTHX_ WARN_GLOB,
1494                            "glob failed (child exited with status %d%s)",
1495                            (int)(STATUS_CURRENT >> 8),
1496                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1497                 }
1498             }
1499             if (gimme == G_SCALAR) {
1500                 (void)SvOK_off(TARG);
1501                 PUSHTARG;
1502             }
1503             MAYBE_TAINT_LINE(io, sv);
1504             RETURN;
1505         }
1506         MAYBE_TAINT_LINE(io, sv);
1507         IoLINES(io)++;
1508         IoFLAGS(io) |= IOf_NOLINE;
1509         SvSETMAGIC(sv);
1510         XPUSHs(sv);
1511         if (type == OP_GLOB) {
1512             char *tmps;
1513
1514             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1515                 tmps = SvEND(sv) - 1;
1516                 if (*tmps == *SvPVX(PL_rs)) {
1517                     *tmps = '\0';
1518                     SvCUR(sv)--;
1519                 }
1520             }
1521             for (tmps = SvPVX(sv); *tmps; tmps++)
1522                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1523                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1524                         break;
1525             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1526                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1527                 continue;
1528             }
1529         }
1530         if (gimme == G_ARRAY) {
1531             if (SvLEN(sv) - SvCUR(sv) > 20) {
1532                 SvLEN_set(sv, SvCUR(sv)+1);
1533                 Renew(SvPVX(sv), SvLEN(sv), char);
1534             }
1535             sv = sv_2mortal(NEWSV(58, 80));
1536             continue;
1537         }
1538         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1539             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1540             if (SvCUR(sv) < 60)
1541                 SvLEN_set(sv, 80);
1542             else
1543                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1544             Renew(SvPVX(sv), SvLEN(sv), char);
1545         }
1546         RETURN;
1547     }
1548 }
1549
1550 PP(pp_enter)
1551 {
1552     djSP;
1553     register PERL_CONTEXT *cx;
1554     I32 gimme = OP_GIMME(PL_op, -1);
1555
1556     if (gimme == -1) {
1557         if (cxstack_ix >= 0)
1558             gimme = cxstack[cxstack_ix].blk_gimme;
1559         else
1560             gimme = G_SCALAR;
1561     }
1562
1563     ENTER;
1564
1565     SAVETMPS;
1566     PUSHBLOCK(cx, CXt_BLOCK, SP);
1567
1568     RETURN;
1569 }
1570
1571 PP(pp_helem)
1572 {
1573     djSP;
1574     HE* he;
1575     SV **svp;
1576     SV *keysv = POPs;
1577     HV *hv = (HV*)POPs;
1578     U32 lval = PL_op->op_flags & OPf_MOD;
1579     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1580     SV *sv;
1581     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1582     I32 preeminent;
1583
1584     if (SvTYPE(hv) == SVt_PVHV) {
1585         if (PL_op->op_private & OPpLVAL_INTRO)
1586             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1587         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1588         svp = he ? &HeVAL(he) : 0;
1589     }
1590     else if (SvTYPE(hv) == SVt_PVAV) {
1591         if (PL_op->op_private & OPpLVAL_INTRO)
1592             DIE(aTHX_ "Can't localize pseudo-hash element");
1593         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1594     }
1595     else {
1596         RETPUSHUNDEF;
1597     }
1598     if (lval) {
1599         if (!svp || *svp == &PL_sv_undef) {
1600             SV* lv;
1601             SV* key2;
1602             if (!defer) {
1603                 STRLEN n_a;
1604                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1605             }
1606             lv = sv_newmortal();
1607             sv_upgrade(lv, SVt_PVLV);
1608             LvTYPE(lv) = 'y';
1609             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1610             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1611             LvTARG(lv) = SvREFCNT_inc(hv);
1612             LvTARGLEN(lv) = 1;
1613             PUSHs(lv);
1614             RETURN;
1615         }
1616         if (PL_op->op_private & OPpLVAL_INTRO) {
1617             if (HvNAME(hv) && isGV(*svp))
1618                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1619             else {
1620                 if (!preeminent) {
1621                     STRLEN keylen;
1622                     char *key = SvPV(keysv, keylen);
1623                     save_delete(hv, key, keylen);
1624                 } else
1625                     save_helem(hv, keysv, svp);
1626             }
1627         }
1628         else if (PL_op->op_private & OPpDEREF)
1629             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1630     }
1631     sv = (svp ? *svp : &PL_sv_undef);
1632     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1633      * Pushing the magical RHS on to the stack is useless, since
1634      * that magic is soon destined to be misled by the local(),
1635      * and thus the later pp_sassign() will fail to mg_get() the
1636      * old value.  This should also cure problems with delayed
1637      * mg_get()s.  GSAR 98-07-03 */
1638     if (!lval && SvGMAGICAL(sv))
1639         sv = sv_mortalcopy(sv);
1640     PUSHs(sv);
1641     RETURN;
1642 }
1643
1644 PP(pp_leave)
1645 {
1646     djSP;
1647     register PERL_CONTEXT *cx;
1648     register SV **mark;
1649     SV **newsp;
1650     PMOP *newpm;
1651     I32 gimme;
1652
1653     if (PL_op->op_flags & OPf_SPECIAL) {
1654         cx = &cxstack[cxstack_ix];
1655         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1656     }
1657
1658     POPBLOCK(cx,newpm);
1659
1660     gimme = OP_GIMME(PL_op, -1);
1661     if (gimme == -1) {
1662         if (cxstack_ix >= 0)
1663             gimme = cxstack[cxstack_ix].blk_gimme;
1664         else
1665             gimme = G_SCALAR;
1666     }
1667
1668     TAINT_NOT;
1669     if (gimme == G_VOID)
1670         SP = newsp;
1671     else if (gimme == G_SCALAR) {
1672         MARK = newsp + 1;
1673         if (MARK <= SP)
1674             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1675                 *MARK = TOPs;
1676             else
1677                 *MARK = sv_mortalcopy(TOPs);
1678         else {
1679             MEXTEND(mark,0);
1680             *MARK = &PL_sv_undef;
1681         }
1682         SP = MARK;
1683     }
1684     else if (gimme == G_ARRAY) {
1685         /* in case LEAVE wipes old return values */
1686         for (mark = newsp + 1; mark <= SP; mark++) {
1687             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1688                 *mark = sv_mortalcopy(*mark);
1689                 TAINT_NOT;      /* Each item is independent */
1690             }
1691         }
1692     }
1693     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1694
1695     LEAVE;
1696
1697     RETURN;
1698 }
1699
1700 PP(pp_iter)
1701 {
1702     djSP;
1703     register PERL_CONTEXT *cx;
1704     SV* sv;
1705     AV* av;
1706     SV **itersvp;
1707
1708     EXTEND(SP, 1);
1709     cx = &cxstack[cxstack_ix];
1710     if (CxTYPE(cx) != CXt_LOOP)
1711         DIE(aTHX_ "panic: pp_iter");
1712
1713     itersvp = CxITERVAR(cx);
1714     av = cx->blk_loop.iterary;
1715     if (SvTYPE(av) != SVt_PVAV) {
1716         /* iterate ($min .. $max) */
1717         if (cx->blk_loop.iterlval) {
1718             /* string increment */
1719             register SV* cur = cx->blk_loop.iterlval;
1720             STRLEN maxlen;
1721             char *max = SvPV((SV*)av, maxlen);
1722             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1723 #ifndef USE_THREADS                       /* don't risk potential race */
1724                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1725                     /* safe to reuse old SV */
1726                     sv_setsv(*itersvp, cur);
1727                 }
1728                 else
1729 #endif
1730                 {
1731                     /* we need a fresh SV every time so that loop body sees a
1732                      * completely new SV for closures/references to work as
1733                      * they used to */
1734                     SvREFCNT_dec(*itersvp);
1735                     *itersvp = newSVsv(cur);
1736                 }
1737                 if (strEQ(SvPVX(cur), max))
1738                     sv_setiv(cur, 0); /* terminate next time */
1739                 else
1740                     sv_inc(cur);
1741                 RETPUSHYES;
1742             }
1743             RETPUSHNO;
1744         }
1745         /* integer increment */
1746         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1747             RETPUSHNO;
1748
1749 #ifndef USE_THREADS                       /* don't risk potential race */
1750         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1751             /* safe to reuse old SV */
1752             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1753         }
1754         else
1755 #endif
1756         {
1757             /* we need a fresh SV every time so that loop body sees a
1758              * completely new SV for closures/references to work as they
1759              * used to */
1760             SvREFCNT_dec(*itersvp);
1761             *itersvp = newSViv(cx->blk_loop.iterix++);
1762         }
1763         RETPUSHYES;
1764     }
1765
1766     /* iterate array */
1767     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1768         RETPUSHNO;
1769
1770     SvREFCNT_dec(*itersvp);
1771
1772     if ((sv = SvMAGICAL(av)
1773               ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1774               : AvARRAY(av)[++cx->blk_loop.iterix]))
1775         SvTEMP_off(sv);
1776     else
1777         sv = &PL_sv_undef;
1778     if (av != PL_curstack && SvIMMORTAL(sv)) {
1779         SV *lv = cx->blk_loop.iterlval;
1780         if (lv && SvREFCNT(lv) > 1) {
1781             SvREFCNT_dec(lv);
1782             lv = Nullsv;
1783         }
1784         if (lv)
1785             SvREFCNT_dec(LvTARG(lv));
1786         else {
1787             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1788             sv_upgrade(lv, SVt_PVLV);
1789             LvTYPE(lv) = 'y';
1790             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1791         }
1792         LvTARG(lv) = SvREFCNT_inc(av);
1793         LvTARGOFF(lv) = cx->blk_loop.iterix;
1794         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1795         sv = (SV*)lv;
1796     }
1797
1798     *itersvp = SvREFCNT_inc(sv);
1799     RETPUSHYES;
1800 }
1801
1802 PP(pp_subst)
1803 {
1804     djSP; dTARG;
1805     register PMOP *pm = cPMOP;
1806     PMOP *rpm = pm;
1807     register SV *dstr;
1808     register char *s;
1809     char *strend;
1810     register char *m;
1811     char *c;
1812     register char *d;
1813     STRLEN clen;
1814     I32 iters = 0;
1815     I32 maxiters;
1816     register I32 i;
1817     bool once;
1818     bool rxtainted;
1819     char *orig;
1820     I32 r_flags;
1821     register REGEXP *rx = pm->op_pmregexp;
1822     STRLEN len;
1823     int force_on_match = 0;
1824     I32 oldsave = PL_savestack_ix;
1825
1826     /* known replacement string? */
1827     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1828     if (PL_op->op_flags & OPf_STACKED)
1829         TARG = POPs;
1830     else {
1831         TARG = DEFSV;
1832         EXTEND(SP,1);
1833     }
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: do_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         PL_curpm = pm;
2008         if (!c) {
2009             register PERL_CONTEXT *cx;
2010             SPAGAIN;
2011             PUSHSUBST(cx);
2012             RETURNOP(cPMOP->op_pmreplroot);
2013         }
2014         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2015         do {
2016             if (iters++ > maxiters)
2017                 DIE(aTHX_ "Substitution loop");
2018             rxtainted |= RX_MATCH_TAINTED(rx);
2019             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2020                 m = s;
2021                 s = orig;
2022                 orig = rx->subbeg;
2023                 s = orig + (m - s);
2024                 strend = s + (strend - m);
2025             }
2026             m = rx->startp[0] + orig;
2027             sv_catpvn(dstr, s, m-s);
2028             s = rx->endp[0] + orig;
2029             if (clen)
2030                 sv_catpvn(dstr, c, clen);
2031             if (once)
2032                 break;
2033         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
2034         sv_catpvn(dstr, s, strend - s);
2035
2036         (void)SvOOK_off(TARG);
2037         Safefree(SvPVX(TARG));
2038         SvPVX(TARG) = SvPVX(dstr);
2039         SvCUR_set(TARG, SvCUR(dstr));
2040         SvLEN_set(TARG, SvLEN(dstr));
2041         SvPVX(dstr) = 0;
2042         sv_free(dstr);
2043
2044         TAINT_IF(rxtainted & 1);
2045         SPAGAIN;
2046         PUSHs(sv_2mortal(newSViv((I32)iters)));
2047
2048         (void)SvPOK_only(TARG);
2049         TAINT_IF(rxtainted);
2050         SvSETMAGIC(TARG);
2051         SvTAINT(TARG);
2052         LEAVE_SCOPE(oldsave);
2053         RETURN;
2054     }
2055     goto ret_no;
2056
2057 nope:
2058 ret_no:
2059     SPAGAIN;
2060     PUSHs(&PL_sv_no);
2061     LEAVE_SCOPE(oldsave);
2062     RETURN;
2063 }
2064
2065 PP(pp_grepwhile)
2066 {
2067     djSP;
2068
2069     if (SvTRUEx(POPs))
2070         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2071     ++*PL_markstack_ptr;
2072     LEAVE;                                      /* exit inner scope */
2073
2074     /* All done yet? */
2075     if (PL_stack_base + *PL_markstack_ptr > SP) {
2076         I32 items;
2077         I32 gimme = GIMME_V;
2078
2079         LEAVE;                                  /* exit outer scope */
2080         (void)POPMARK;                          /* pop src */
2081         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2082         (void)POPMARK;                          /* pop dst */
2083         SP = PL_stack_base + POPMARK;           /* pop original mark */
2084         if (gimme == G_SCALAR) {
2085             dTARGET;
2086             XPUSHi(items);
2087         }
2088         else if (gimme == G_ARRAY)
2089             SP += items;
2090         RETURN;
2091     }
2092     else {
2093         SV *src;
2094
2095         ENTER;                                  /* enter inner scope */
2096         SAVEVPTR(PL_curpm);
2097
2098         src = PL_stack_base[*PL_markstack_ptr];
2099         SvTEMP_off(src);
2100         DEFSV = src;
2101
2102         RETURNOP(cLOGOP->op_other);
2103     }
2104 }
2105
2106 PP(pp_leavesub)
2107 {
2108     djSP;
2109     SV **mark;
2110     SV **newsp;
2111     PMOP *newpm;
2112     I32 gimme;
2113     register PERL_CONTEXT *cx;
2114     SV *sv;
2115
2116     POPBLOCK(cx,newpm);
2117
2118     TAINT_NOT;
2119     if (gimme == G_SCALAR) {
2120         MARK = newsp + 1;
2121         if (MARK <= SP) {
2122             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2123                 if (SvTEMP(TOPs)) {
2124                     *MARK = SvREFCNT_inc(TOPs);
2125                     FREETMPS;
2126                     sv_2mortal(*MARK);
2127                 }
2128                 else {
2129                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2130                     FREETMPS;
2131                     *MARK = sv_mortalcopy(sv);
2132                     SvREFCNT_dec(sv);
2133                 }
2134             }
2135             else
2136                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2137         }
2138         else {
2139             MEXTEND(MARK, 0);
2140             *MARK = &PL_sv_undef;
2141         }
2142         SP = MARK;
2143     }
2144     else if (gimme == G_ARRAY) {
2145         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2146             if (!SvTEMP(*MARK)) {
2147                 *MARK = sv_mortalcopy(*MARK);
2148                 TAINT_NOT;      /* Each item is independent */
2149             }
2150         }
2151     }
2152     PUTBACK;
2153
2154     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2155     PL_curpm = newpm;   /* ... and pop $1 et al */
2156
2157     LEAVE;
2158     LEAVESUB(sv);
2159     return pop_return();
2160 }
2161
2162 /* This duplicates the above code because the above code must not
2163  * get any slower by more conditions */
2164 PP(pp_leavesublv)
2165 {
2166     djSP;
2167     SV **mark;
2168     SV **newsp;
2169     PMOP *newpm;
2170     I32 gimme;
2171     register PERL_CONTEXT *cx;
2172     SV *sv;
2173
2174     POPBLOCK(cx,newpm);
2175
2176     TAINT_NOT;
2177
2178     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2179         /* We are an argument to a function or grep().
2180          * This kind of lvalueness was legal before lvalue
2181          * subroutines too, so be backward compatible:
2182          * cannot report errors.  */
2183
2184         /* Scalar context *is* possible, on the LHS of -> only,
2185          * as in f()->meth().  But this is not an lvalue. */
2186         if (gimme == G_SCALAR)
2187             goto temporise;
2188         if (gimme == G_ARRAY) {
2189             if (!CvLVALUE(cx->blk_sub.cv))
2190                 goto temporise_array;
2191             EXTEND_MORTAL(SP - newsp);
2192             for (mark = newsp + 1; mark <= SP; mark++) {
2193                 if (SvTEMP(*mark))
2194                     /* empty */ ;
2195                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2196                     *mark = sv_mortalcopy(*mark);
2197                 else {
2198                     /* Can be a localized value subject to deletion. */
2199                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2200                     (void)SvREFCNT_inc(*mark);
2201                 }
2202             }
2203         }
2204     }
2205     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2206         /* Here we go for robustness, not for speed, so we change all
2207          * the refcounts so the caller gets a live guy. Cannot set
2208          * TEMP, so sv_2mortal is out of question. */
2209         if (!CvLVALUE(cx->blk_sub.cv)) {
2210             POPSUB(cx,sv);
2211             PL_curpm = newpm;
2212             LEAVE;
2213             LEAVESUB(sv);
2214             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2215         }
2216         if (gimme == G_SCALAR) {
2217             MARK = newsp + 1;
2218             EXTEND_MORTAL(1);
2219             if (MARK == SP) {
2220                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2221                     POPSUB(cx,sv);
2222                     PL_curpm = newpm;
2223                     LEAVE;
2224                     LEAVESUB(sv);
2225                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2226                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2227                 }
2228                 else {                  /* Can be a localized value
2229                                          * subject to deletion. */
2230                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2231                     (void)SvREFCNT_inc(*mark);
2232                 }
2233             }
2234             else {                      /* Should not happen? */
2235                 POPSUB(cx,sv);
2236                 PL_curpm = newpm;
2237                 LEAVE;
2238                 LEAVESUB(sv);
2239                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2240                     (MARK > SP ? "Empty array" : "Array"));
2241             }
2242             SP = MARK;
2243         }
2244         else if (gimme == G_ARRAY) {
2245             EXTEND_MORTAL(SP - newsp);
2246             for (mark = newsp + 1; mark <= SP; mark++) {
2247                 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2248                     /* Might be flattened array after $#array =  */
2249                     PUTBACK;
2250                     POPSUB(cx,sv);
2251                     PL_curpm = newpm;
2252                     LEAVE;
2253                     LEAVESUB(sv);
2254                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2255                         (*mark != &PL_sv_undef)
2256                         ? (SvREADONLY(TOPs)
2257                             ? "a readonly value" : "a temporary")
2258                         : "an uninitialized value");
2259                 }
2260                 else {
2261                     /* Can be a localized value subject to deletion. */
2262                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2263                     (void)SvREFCNT_inc(*mark);
2264                 }
2265             }
2266         }
2267     }
2268     else {
2269         if (gimme == G_SCALAR) {
2270           temporise:
2271             MARK = newsp + 1;
2272             if (MARK <= SP) {
2273                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2274                     if (SvTEMP(TOPs)) {
2275                         *MARK = SvREFCNT_inc(TOPs);
2276                         FREETMPS;
2277                         sv_2mortal(*MARK);
2278                     }
2279                     else {
2280                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2281                         FREETMPS;
2282                         *MARK = sv_mortalcopy(sv);
2283                         SvREFCNT_dec(sv);
2284                     }
2285                 }
2286                 else
2287                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2288             }
2289             else {
2290                 MEXTEND(MARK, 0);
2291                 *MARK = &PL_sv_undef;
2292             }
2293             SP = MARK;
2294         }
2295         else if (gimme == G_ARRAY) {
2296           temporise_array:
2297             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2298                 if (!SvTEMP(*MARK)) {
2299                     *MARK = sv_mortalcopy(*MARK);
2300                     TAINT_NOT;  /* Each item is independent */
2301                 }
2302             }
2303         }
2304     }
2305     PUTBACK;
2306
2307     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2308     PL_curpm = newpm;   /* ... and pop $1 et al */
2309
2310     LEAVE;
2311     LEAVESUB(sv);
2312     return pop_return();
2313 }
2314
2315
2316 STATIC CV *
2317 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2318 {
2319     SV *dbsv = GvSV(PL_DBsub);
2320
2321     if (!PERLDB_SUB_NN) {
2322         GV *gv = CvGV(cv);
2323
2324         save_item(dbsv);
2325         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2326              || strEQ(GvNAME(gv), "END")
2327              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2328                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2329                     && (gv = (GV*)*svp) ))) {
2330             /* Use GV from the stack as a fallback. */
2331             /* GV is potentially non-unique, or contain different CV. */
2332             SV *tmp = newRV((SV*)cv);
2333             sv_setsv(dbsv, tmp);
2334             SvREFCNT_dec(tmp);
2335         }
2336         else {
2337             gv_efullname3(dbsv, gv, Nullch);
2338         }
2339     }
2340     else {
2341         (void)SvUPGRADE(dbsv, SVt_PVIV);
2342         (void)SvIOK_on(dbsv);
2343         SAVEIV(SvIVX(dbsv));
2344         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2345     }
2346
2347     if (CvXSUB(cv))
2348         PL_curcopdb = PL_curcop;
2349     cv = GvCV(PL_DBsub);
2350     return cv;
2351 }
2352
2353 PP(pp_entersub)
2354 {
2355     djSP; dPOPss;
2356     GV *gv;
2357     HV *stash;
2358     register CV *cv;
2359     register PERL_CONTEXT *cx;
2360     I32 gimme;
2361     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2362
2363     if (!sv)
2364         DIE(aTHX_ "Not a CODE reference");
2365     switch (SvTYPE(sv)) {
2366     default:
2367         if (!SvROK(sv)) {
2368             char *sym;
2369             STRLEN n_a;
2370
2371             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2372                 if (hasargs)
2373                     SP = PL_stack_base + POPMARK;
2374                 RETURN;
2375             }
2376             if (SvGMAGICAL(sv)) {
2377                 mg_get(sv);
2378                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2379             }
2380             else
2381                 sym = SvPV(sv, n_a);
2382             if (!sym)
2383                 DIE(aTHX_ PL_no_usym, "a subroutine");
2384             if (PL_op->op_private & HINT_STRICT_REFS)
2385                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2386             cv = get_cv(sym, TRUE);
2387             break;
2388         }
2389         {
2390             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2391             tryAMAGICunDEREF(to_cv);
2392         }
2393         cv = (CV*)SvRV(sv);
2394         if (SvTYPE(cv) == SVt_PVCV)
2395             break;
2396         /* FALL THROUGH */
2397     case SVt_PVHV:
2398     case SVt_PVAV:
2399         DIE(aTHX_ "Not a CODE reference");
2400     case SVt_PVCV:
2401         cv = (CV*)sv;
2402         break;
2403     case SVt_PVGV:
2404         if (!(cv = GvCVu((GV*)sv)))
2405             cv = sv_2cv(sv, &stash, &gv, FALSE);
2406         if (!cv) {
2407             ENTER;
2408             SAVETMPS;
2409             goto try_autoload;
2410         }
2411         break;
2412     }
2413
2414     ENTER;
2415     SAVETMPS;
2416
2417   retry:
2418     if (!CvROOT(cv) && !CvXSUB(cv)) {
2419         GV* autogv;
2420         SV* sub_name;
2421
2422         /* anonymous or undef'd function leaves us no recourse */
2423         if (CvANON(cv) || !(gv = CvGV(cv)))
2424             DIE(aTHX_ "Undefined subroutine called");
2425
2426         /* autoloaded stub? */
2427         if (cv != GvCV(gv)) {
2428             cv = GvCV(gv);
2429         }
2430         /* should call AUTOLOAD now? */
2431         else {
2432 try_autoload:
2433             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2434                                    FALSE)))
2435             {
2436                 cv = GvCV(autogv);
2437             }
2438             /* sorry */
2439             else {
2440                 sub_name = sv_newmortal();
2441                 gv_efullname3(sub_name, gv, Nullch);
2442                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2443             }
2444         }
2445         if (!cv)
2446             DIE(aTHX_ "Not a CODE reference");
2447         goto retry;
2448     }
2449
2450     gimme = GIMME_V;
2451     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2452         cv = get_db_sub(&sv, cv);
2453         if (!cv)
2454             DIE(aTHX_ "No DBsub routine");
2455     }
2456
2457 #ifdef USE_THREADS
2458     /*
2459      * First we need to check if the sub or method requires locking.
2460      * If so, we gain a lock on the CV, the first argument or the
2461      * stash (for static methods), as appropriate. This has to be
2462      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2463      * reschedule by returning a new op.
2464      */
2465     MUTEX_LOCK(CvMUTEXP(cv));
2466     if (CvFLAGS(cv) & CVf_LOCKED) {
2467         MAGIC *mg;
2468         if (CvFLAGS(cv) & CVf_METHOD) {
2469             if (SP > PL_stack_base + TOPMARK)
2470                 sv = *(PL_stack_base + TOPMARK + 1);
2471             else {
2472                 AV *av = (AV*)PL_curpad[0];
2473                 if (hasargs || !av || AvFILLp(av) < 0
2474                     || !(sv = AvARRAY(av)[0]))
2475                 {
2476                     MUTEX_UNLOCK(CvMUTEXP(cv));
2477                     DIE(aTHX_ "no argument for locked method call");
2478                 }
2479             }
2480             if (SvROK(sv))
2481                 sv = SvRV(sv);
2482             else {
2483                 STRLEN len;
2484                 char *stashname = SvPV(sv, len);
2485                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2486             }
2487         }
2488         else {
2489             sv = (SV*)cv;
2490         }
2491         MUTEX_UNLOCK(CvMUTEXP(cv));
2492         mg = condpair_magic(sv);
2493         MUTEX_LOCK(MgMUTEXP(mg));
2494         if (MgOWNER(mg) == thr)
2495             MUTEX_UNLOCK(MgMUTEXP(mg));
2496         else {
2497             while (MgOWNER(mg))
2498                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2499             MgOWNER(mg) = thr;
2500             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2501                                   thr, sv);)
2502             MUTEX_UNLOCK(MgMUTEXP(mg));
2503             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2504         }
2505         MUTEX_LOCK(CvMUTEXP(cv));
2506     }
2507     /*
2508      * Now we have permission to enter the sub, we must distinguish
2509      * four cases. (0) It's an XSUB (in which case we don't care
2510      * about ownership); (1) it's ours already (and we're recursing);
2511      * (2) it's free (but we may already be using a cached clone);
2512      * (3) another thread owns it. Case (1) is easy: we just use it.
2513      * Case (2) means we look for a clone--if we have one, use it
2514      * otherwise grab ownership of cv. Case (3) means we look for a
2515      * clone (for non-XSUBs) and have to create one if we don't
2516      * already have one.
2517      * Why look for a clone in case (2) when we could just grab
2518      * ownership of cv straight away? Well, we could be recursing,
2519      * i.e. we originally tried to enter cv while another thread
2520      * owned it (hence we used a clone) but it has been freed up
2521      * and we're now recursing into it. It may or may not be "better"
2522      * to use the clone but at least CvDEPTH can be trusted.
2523      */
2524     if (CvOWNER(cv) == thr || CvXSUB(cv))
2525         MUTEX_UNLOCK(CvMUTEXP(cv));
2526     else {
2527         /* Case (2) or (3) */
2528         SV **svp;
2529
2530         /*
2531          * XXX Might it be better to release CvMUTEXP(cv) while we
2532          * do the hv_fetch? We might find someone has pinched it
2533          * when we look again, in which case we would be in case
2534          * (3) instead of (2) so we'd have to clone. Would the fact
2535          * that we released the mutex more quickly make up for this?
2536          */
2537         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2538         {
2539             /* We already have a clone to use */
2540             MUTEX_UNLOCK(CvMUTEXP(cv));
2541             cv = *(CV**)svp;
2542             DEBUG_S(PerlIO_printf(Perl_debug_log,
2543                                   "entersub: %p already has clone %p:%s\n",
2544                                   thr, cv, SvPEEK((SV*)cv)));
2545             CvOWNER(cv) = thr;
2546             SvREFCNT_inc(cv);
2547             if (CvDEPTH(cv) == 0)
2548                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2549         }
2550         else {
2551             /* (2) => grab ownership of cv. (3) => make clone */
2552             if (!CvOWNER(cv)) {
2553                 CvOWNER(cv) = thr;
2554                 SvREFCNT_inc(cv);
2555                 MUTEX_UNLOCK(CvMUTEXP(cv));
2556                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2557                             "entersub: %p grabbing %p:%s in stash %s\n",
2558                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2559                                 HvNAME(CvSTASH(cv)) : "(none)"));
2560             }
2561             else {
2562                 /* Make a new clone. */
2563                 CV *clonecv;
2564                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2565                 MUTEX_UNLOCK(CvMUTEXP(cv));
2566                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2567                                        "entersub: %p cloning %p:%s\n",
2568                                        thr, cv, SvPEEK((SV*)cv))));
2569                 /*
2570                  * We're creating a new clone so there's no race
2571                  * between the original MUTEX_UNLOCK and the
2572                  * SvREFCNT_inc since no one will be trying to undef
2573                  * it out from underneath us. At least, I don't think
2574                  * there's a race...
2575                  */
2576                 clonecv = cv_clone(cv);
2577                 SvREFCNT_dec(cv); /* finished with this */
2578                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2579                 CvOWNER(clonecv) = thr;
2580                 cv = clonecv;
2581                 SvREFCNT_inc(cv);
2582             }
2583             DEBUG_S(if (CvDEPTH(cv) != 0)
2584                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2585                                       CvDEPTH(cv)););
2586             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2587         }
2588     }
2589 #endif /* USE_THREADS */
2590
2591     if (CvXSUB(cv)) {
2592 #ifdef PERL_XSUB_OLDSTYLE
2593         if (CvOLDSTYLE(cv)) {
2594             I32 (*fp3)(int,int,int);
2595             dMARK;
2596             register I32 items = SP - MARK;
2597                                         /* We dont worry to copy from @_. */
2598             while (SP > mark) {
2599                 SP[1] = SP[0];
2600                 SP--;
2601             }
2602             PL_stack_sp = mark + 1;
2603             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2604             items = (*fp3)(CvXSUBANY(cv).any_i32,
2605                            MARK - PL_stack_base + 1,
2606                            items);
2607             PL_stack_sp = PL_stack_base + items;
2608         }
2609         else
2610 #endif /* PERL_XSUB_OLDSTYLE */
2611         {
2612             I32 markix = TOPMARK;
2613
2614             PUTBACK;
2615
2616             if (!hasargs) {
2617                 /* Need to copy @_ to stack. Alternative may be to
2618                  * switch stack to @_, and copy return values
2619                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2620                 AV* av;
2621                 I32 items;
2622 #ifdef USE_THREADS
2623                 av = (AV*)PL_curpad[0];
2624 #else
2625                 av = GvAV(PL_defgv);
2626 #endif /* USE_THREADS */
2627                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2628
2629                 if (items) {
2630                     /* Mark is at the end of the stack. */
2631                     EXTEND(SP, items);
2632                     Copy(AvARRAY(av), SP + 1, items, SV*);
2633                     SP += items;
2634                     PUTBACK ;
2635                 }
2636             }
2637             /* We assume first XSUB in &DB::sub is the called one. */
2638             if (PL_curcopdb) {
2639                 SAVEVPTR(PL_curcop);
2640                 PL_curcop = PL_curcopdb;
2641                 PL_curcopdb = NULL;
2642             }
2643             /* Do we need to open block here? XXXX */
2644             (void)(*CvXSUB(cv))(aTHXo_ cv);
2645
2646             /* Enforce some sanity in scalar context. */
2647             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2648                 if (markix > PL_stack_sp - PL_stack_base)
2649                     *(PL_stack_base + markix) = &PL_sv_undef;
2650                 else
2651                     *(PL_stack_base + markix) = *PL_stack_sp;
2652                 PL_stack_sp = PL_stack_base + markix;
2653             }
2654         }
2655         LEAVE;
2656         return NORMAL;
2657     }
2658     else {
2659         dMARK;
2660         register I32 items = SP - MARK;
2661         AV* padlist = CvPADLIST(cv);
2662         SV** svp = AvARRAY(padlist);
2663         push_return(PL_op->op_next);
2664         PUSHBLOCK(cx, CXt_SUB, MARK);
2665         PUSHSUB(cx);
2666         CvDEPTH(cv)++;
2667         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2668          * that eval'' ops within this sub know the correct lexical space.
2669          * Owing the speed considerations, we choose to search for the cv
2670          * in doeval() instead.
2671          */
2672         if (CvDEPTH(cv) < 2)
2673             (void)SvREFCNT_inc(cv);
2674         else {  /* save temporaries on recursion? */
2675             PERL_STACK_OVERFLOW_CHECK();
2676             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2677                 AV *av;
2678                 AV *newpad = newAV();
2679                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2680                 I32 ix = AvFILLp((AV*)svp[1]);
2681                 I32 names_fill = AvFILLp((AV*)svp[0]);
2682                 svp = AvARRAY(svp[0]);
2683                 for ( ;ix > 0; ix--) {
2684                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2685                         char *name = SvPVX(svp[ix]);
2686                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2687                             || *name == '&')              /* anonymous code? */
2688                         {
2689                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2690                         }
2691                         else {                          /* our own lexical */
2692                             if (*name == '@')
2693                                 av_store(newpad, ix, sv = (SV*)newAV());
2694                             else if (*name == '%')
2695                                 av_store(newpad, ix, sv = (SV*)newHV());
2696                             else
2697                                 av_store(newpad, ix, sv = NEWSV(0,0));
2698                             SvPADMY_on(sv);
2699                         }
2700                     }
2701                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2702                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2703                     }
2704                     else {
2705                         av_store(newpad, ix, sv = NEWSV(0,0));
2706                         SvPADTMP_on(sv);
2707                     }
2708                 }
2709                 av = newAV();           /* will be @_ */
2710                 av_extend(av, 0);
2711                 av_store(newpad, 0, (SV*)av);
2712                 AvFLAGS(av) = AVf_REIFY;
2713                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2714                 AvFILLp(padlist) = CvDEPTH(cv);
2715                 svp = AvARRAY(padlist);
2716             }
2717         }
2718 #ifdef USE_THREADS
2719         if (!hasargs) {
2720             AV* av = (AV*)PL_curpad[0];
2721
2722             items = AvFILLp(av) + 1;
2723             if (items) {
2724                 /* Mark is at the end of the stack. */
2725                 EXTEND(SP, items);
2726                 Copy(AvARRAY(av), SP + 1, items, SV*);
2727                 SP += items;
2728                 PUTBACK ;
2729             }
2730         }
2731 #endif /* USE_THREADS */
2732         SAVEVPTR(PL_curpad);
2733         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2734 #ifndef USE_THREADS
2735         if (hasargs)
2736 #endif /* USE_THREADS */
2737         {
2738             AV* av;
2739             SV** ary;
2740
2741 #if 0
2742             DEBUG_S(PerlIO_printf(Perl_debug_log,
2743                                   "%p entersub preparing @_\n", thr));
2744 #endif
2745             av = (AV*)PL_curpad[0];
2746             if (AvREAL(av)) {
2747                 /* @_ is normally not REAL--this should only ever
2748                  * happen when DB::sub() calls things that modify @_ */
2749                 av_clear(av);
2750                 AvREAL_off(av);
2751                 AvREIFY_on(av);
2752             }
2753 #ifndef USE_THREADS
2754             cx->blk_sub.savearray = GvAV(PL_defgv);
2755             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2756 #endif /* USE_THREADS */
2757             cx->blk_sub.oldcurpad = PL_curpad;
2758             cx->blk_sub.argarray = av;
2759             ++MARK;
2760
2761             if (items > AvMAX(av) + 1) {
2762                 ary = AvALLOC(av);
2763                 if (AvARRAY(av) != ary) {
2764                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2765                     SvPVX(av) = (char*)ary;
2766                 }
2767                 if (items > AvMAX(av) + 1) {
2768                     AvMAX(av) = items - 1;
2769                     Renew(ary,items,SV*);
2770                     AvALLOC(av) = ary;
2771                     SvPVX(av) = (char*)ary;
2772                 }
2773             }
2774             Copy(MARK,AvARRAY(av),items,SV*);
2775             AvFILLp(av) = items - 1;
2776
2777             while (items--) {
2778                 if (*MARK)
2779                     SvTEMP_off(*MARK);
2780                 MARK++;
2781             }
2782         }
2783         /* warning must come *after* we fully set up the context
2784          * stuff so that __WARN__ handlers can safely dounwind()
2785          * if they want to
2786          */
2787         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2788             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2789             sub_crush_depth(cv);
2790 #if 0
2791         DEBUG_S(PerlIO_printf(Perl_debug_log,
2792                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2793 #endif
2794         RETURNOP(CvSTART(cv));
2795     }
2796 }
2797
2798 void
2799 Perl_sub_crush_depth(pTHX_ CV *cv)
2800 {
2801     if (CvANON(cv))
2802         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2803     else {
2804         SV* tmpstr = sv_newmortal();
2805         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2806         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2807                 SvPVX(tmpstr));
2808     }
2809 }
2810
2811 PP(pp_aelem)
2812 {
2813     djSP;
2814     SV** svp;
2815     IV elem = POPi;
2816     AV* av = (AV*)POPs;
2817     U32 lval = PL_op->op_flags & OPf_MOD;
2818     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2819     SV *sv;
2820
2821     if (elem > 0)
2822         elem -= PL_curcop->cop_arybase;
2823     if (SvTYPE(av) != SVt_PVAV)
2824         RETPUSHUNDEF;
2825     svp = av_fetch(av, elem, lval && !defer);
2826     if (lval) {
2827         if (!svp || *svp == &PL_sv_undef) {
2828             SV* lv;
2829             if (!defer)
2830                 DIE(aTHX_ PL_no_aelem, elem);
2831             lv = sv_newmortal();
2832             sv_upgrade(lv, SVt_PVLV);
2833             LvTYPE(lv) = 'y';
2834             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2835             LvTARG(lv) = SvREFCNT_inc(av);
2836             LvTARGOFF(lv) = elem;
2837             LvTARGLEN(lv) = 1;
2838             PUSHs(lv);
2839             RETURN;
2840         }
2841         if (PL_op->op_private & OPpLVAL_INTRO)
2842             save_aelem(av, elem, svp);
2843         else if (PL_op->op_private & OPpDEREF)
2844             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2845     }
2846     sv = (svp ? *svp : &PL_sv_undef);
2847     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2848         sv = sv_mortalcopy(sv);
2849     PUSHs(sv);
2850     RETURN;
2851 }
2852
2853 void
2854 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2855 {
2856     if (SvGMAGICAL(sv))
2857         mg_get(sv);
2858     if (!SvOK(sv)) {
2859         if (SvREADONLY(sv))
2860             Perl_croak(aTHX_ PL_no_modify);
2861         if (SvTYPE(sv) < SVt_RV)
2862             sv_upgrade(sv, SVt_RV);
2863         else if (SvTYPE(sv) >= SVt_PV) {
2864             (void)SvOOK_off(sv);
2865             Safefree(SvPVX(sv));
2866             SvLEN(sv) = SvCUR(sv) = 0;
2867         }
2868         switch (to_what) {
2869         case OPpDEREF_SV:
2870             SvRV(sv) = NEWSV(355,0);
2871             break;
2872         case OPpDEREF_AV:
2873             SvRV(sv) = (SV*)newAV();
2874             break;
2875         case OPpDEREF_HV:
2876             SvRV(sv) = (SV*)newHV();
2877             break;
2878         }
2879         SvROK_on(sv);
2880         SvSETMAGIC(sv);
2881     }
2882 }
2883
2884 PP(pp_method)
2885 {
2886     djSP;
2887     SV* sv = TOPs;
2888
2889     if (SvROK(sv)) {
2890         SV* rsv = SvRV(sv);
2891         if (SvTYPE(rsv) == SVt_PVCV) {
2892             SETs(rsv);
2893             RETURN;
2894         }
2895     }
2896
2897     SETs(method_common(sv, Null(U32*)));
2898     RETURN;
2899 }
2900
2901 PP(pp_method_named)
2902 {
2903     djSP;
2904     SV* sv = cSVOP->op_sv;
2905     U32 hash = SvUVX(sv);
2906
2907     XPUSHs(method_common(sv, &hash));
2908     RETURN;
2909 }
2910
2911 STATIC SV *
2912 S_method_common(pTHX_ SV* meth, U32* hashp)
2913 {
2914     SV* sv;
2915     SV* ob;
2916     GV* gv;
2917     HV* stash;
2918     char* name;
2919     STRLEN namelen;
2920     char* packname;
2921     STRLEN packlen;
2922
2923     name = SvPV(meth, namelen);
2924     sv = *(PL_stack_base + TOPMARK + 1);
2925
2926     if (!sv)
2927         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2928
2929     if (SvGMAGICAL(sv))
2930         mg_get(sv);
2931     if (SvROK(sv))
2932         ob = (SV*)SvRV(sv);
2933     else {
2934         GV* iogv;
2935
2936         packname = Nullch;
2937         if (!SvOK(sv) ||
2938             !(packname = SvPV(sv, packlen)) ||
2939             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2940             !(ob=(SV*)GvIO(iogv)))
2941         {
2942             if (!packname ||
2943                 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
2944                     ? !isIDFIRST_utf8((U8*)packname)
2945                     : !isIDFIRST(*packname)
2946                 ))
2947             {
2948                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2949                            SvOK(sv) ? "without a package or object reference"
2950                                     : "on an undefined value");
2951             }
2952             stash = gv_stashpvn(packname, packlen, TRUE);
2953             goto fetch;
2954         }
2955         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2956     }
2957
2958     if (!ob || !(SvOBJECT(ob)
2959                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2960                      && SvOBJECT(ob))))
2961     {
2962         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2963                    name);
2964     }
2965
2966     stash = SvSTASH(ob);
2967
2968   fetch:
2969     /* shortcut for simple names */
2970     if (hashp) {
2971         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2972         if (he) {
2973             gv = (GV*)HeVAL(he);
2974             if (isGV(gv) && GvCV(gv) &&
2975                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2976                 return (SV*)GvCV(gv);
2977         }
2978     }
2979
2980     gv = gv_fetchmethod(stash, name);
2981     if (!gv) {
2982         char* leaf = name;
2983         char* sep = Nullch;
2984         char* p;
2985         GV* gv;
2986
2987         for (p = name; *p; p++) {
2988             if (*p == '\'')
2989                 sep = p, leaf = p + 1;
2990             else if (*p == ':' && *(p + 1) == ':')
2991                 sep = p, leaf = p + 2;
2992         }
2993         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2994             packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
2995             packlen = strlen(packname);
2996         }
2997         else {
2998             packname = name;
2999             packlen = sep - name;
3000         }
3001         gv = gv_fetchpv(packname, 0, SVt_PVHV);
3002         if (gv && isGV(gv)) {
3003             Perl_croak(aTHX_
3004                        "Can't locate object method \"%s\" via package \"%s\"",
3005                        leaf, packname);
3006         }
3007         else {
3008             Perl_croak(aTHX_
3009                        "Can't locate object method \"%s\" via package \"%s\""
3010                        " (perhaps you forgot to load \"%s\"?)",
3011                        leaf, packname, packname);
3012         }
3013     }
3014     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3015 }
3016
3017 #ifdef USE_THREADS
3018 static void
3019 unset_cvowner(pTHXo_ void *cvarg)
3020 {
3021     register CV* cv = (CV *) cvarg;
3022
3023     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3024                            thr, cv, SvPEEK((SV*)cv))));
3025     MUTEX_LOCK(CvMUTEXP(cv));
3026     DEBUG_S(if (CvDEPTH(cv) != 0)
3027                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3028                               CvDEPTH(cv)););
3029     assert(thr == CvOWNER(cv));
3030     CvOWNER(cv) = 0;
3031     MUTEX_UNLOCK(CvMUTEXP(cv));
3032     SvREFCNT_dec(cv);
3033 }
3034 #endif /* USE_THREADS */