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