pp_hot.c

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