pp_hot.c

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