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