pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_HOT_C
  21 #include "perl.h"
  22
  23 /* Hot code. */
  24
  25 PP(pp_const)
  26 {
  27     dSP;
  28     XPUSHs(cSVOP_sv);
  29     RETURN;
  30 }
  31
  32 PP(pp_nextstate)
  33 {
  34     PL_curcop = (COP*)PL_op;
  35     TAINT_NOT;          /* Each statement is presumed innocent */
  36     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  37     FREETMPS;
  38     return NORMAL;
  39 }
  40
  41 PP(pp_gvsv)
  42 {
  43     dSP;
  44     EXTEND(SP,1);
  45     if (PL_op->op_private & OPpLVAL_INTRO)
  46         PUSHs(save_scalar(cGVOP_gv));
  47     else
  48         PUSHs(GvSV(cGVOP_gv));
  49     RETURN;
  50 }
  51
  52 PP(pp_null)
  53 {
  54     return NORMAL;
  55 }
  56
  57 PP(pp_setstate)
  58 {
  59     PL_curcop = (COP*)PL_op;
  60     return NORMAL;
  61 }
  62
  63 PP(pp_pushmark)
  64 {
  65     PUSHMARK(PL_stack_sp);
  66     return NORMAL;
  67 }
  68
  69 PP(pp_stringify)
  70 {
  71     dSP; dTARGET;
  72     sv_copypv(TARG,TOPs);
  73     SETTARG;
  74     RETURN;
  75 }
  76
  77 PP(pp_gv)
  78 {
  79     dSP;
  80     XPUSHs((SV*)cGVOP_gv);
  81     RETURN;
  82 }
  83
  84 PP(pp_and)
  85 {
  86     dSP;
  87     if (!SvTRUE(TOPs))
  88         RETURN;
  89     else {
  90         --SP;
  91         RETURNOP(cLOGOP->op_other);
  92     }
  93 }
  94
  95 PP(pp_sassign)
  96 {
  97     dSP; dPOPTOPssrl;
  98
  99     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 100         SV *temp;
 101         temp = left; left = right; right = temp;
 102     }
 103     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 104         TAINT_NOT;
 105     SvSetMagicSV(right, left);
 106     SETs(right);
 107     RETURN;
 108 }
 109
 110 PP(pp_cond_expr)
 111 {
 112     dSP;
 113     if (SvTRUEx(POPs))
 114         RETURNOP(cLOGOP->op_other);
 115     else
 116         RETURNOP(cLOGOP->op_next);
 117 }
 118
 119 PP(pp_unstack)
 120 {
 121     I32 oldsave;
 122     TAINT_NOT;          /* Each statement is presumed innocent */
 123     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 124     FREETMPS;
 125     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 126     LEAVE_SCOPE(oldsave);
 127     return NORMAL;
 128 }
 129
 130 PP(pp_concat)
 131 {
 132   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 133   {
 134     dPOPTOPssrl;
 135     STRLEN llen;
 136     char* lpv;
 137     bool lbyte;
 138     STRLEN rlen;
 139     char* rpv = SvPV(right, rlen);      /* mg_get(right) happens here */
 140     bool rbyte = !SvUTF8(right), rcopied = FALSE;
 141
 142     if (TARG == right && right != left) {
 143         right = sv_2mortal(newSVpvn(rpv, rlen));
 144         rpv = SvPV(right, rlen);        /* no point setting UTF8 here */
 145         rcopied = TRUE;
 146     }
 147
 148     if (TARG != left) {
 149         lpv = SvPV(left, llen);         /* mg_get(left) may happen here */
 150         lbyte = !SvUTF8(left);
 151         sv_setpvn(TARG, lpv, llen);
 152         if (!lbyte)
 153             SvUTF8_on(TARG);
 154         else
 155             SvUTF8_off(TARG);
 156     }
 157     else { /* TARG == left */
 158         if (SvGMAGICAL(left))
 159             mg_get(left);               /* or mg_get(left) may happen here */
 160         if (!SvOK(TARG))
 161             sv_setpv(left, "");
 162         lpv = SvPV_nomg(left, llen);
 163         lbyte = !SvUTF8(left);
 164     }
 165
 166 #if defined(PERL_Y2KWARN)
 167     if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
 168         if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
 169             && (llen == 2 || !isDIGIT(lpv[llen - 3])))
 170         {
 171             Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
 172                         "about to append an integer to '19'");
 173         }
 174     }
 175 #endif
 176
 177     if (lbyte != rbyte) {
 178         if (lbyte)
 179             sv_utf8_upgrade_nomg(TARG);
 180         else {
 181             if (!rcopied)
 182                 right = sv_2mortal(newSVpvn(rpv, rlen));
 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(PAD_SVl(PL_op->op_targ));
 201         else if (PL_op->op_private & OPpDEREF) {
 202             PUTBACK;
 203             vivify_ref(PAD_SVl(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         else if (PL_op->op_flags & OPf_MOD
 690                 && PL_op->op_private & OPpLVAL_INTRO)
 691             Perl_croak(aTHX_ PL_no_localize_ref);
 692     }
 693     else {
 694         if (SvTYPE(sv) == SVt_PVAV) {
 695             av = (AV*)sv;
 696             if (PL_op->op_flags & OPf_REF) {
 697                 SETs((SV*)av);
 698                 RETURN;
 699             }
 700             else if (LVRET) {
 701                 if (GIMME == G_SCALAR)
 702                     Perl_croak(aTHX_ "Can't return array to lvalue"
 703                                " scalar context");
 704                 SETs((SV*)av);
 705                 RETURN;
 706             }
 707         }
 708         else {
 709             GV *gv;
 710
 711             if (SvTYPE(sv) != SVt_PVGV) {
 712                 char *sym;
 713                 STRLEN len;
 714
 715                 if (SvGMAGICAL(sv)) {
 716                     mg_get(sv);
 717                     if (SvROK(sv))
 718                         goto wasref;
 719                 }
 720                 if (!SvOK(sv)) {
 721                     if (PL_op->op_flags & OPf_REF ||
 722                       PL_op->op_private & HINT_STRICT_REFS)
 723                         DIE(aTHX_ PL_no_usym, "an ARRAY");
 724                     if (ckWARN(WARN_UNINITIALIZED))
 725                         report_uninit();
 726                     if (GIMME == G_ARRAY) {
 727                         (void)POPs;
 728                         RETURN;
 729                     }
 730                     RETSETUNDEF;
 731                 }
 732                 sym = SvPV(sv,len);
 733                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 734                     !(PL_op->op_flags & OPf_MOD))
 735                 {
 736                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
 737                     if (!gv
 738                         && (!is_gv_magical(sym,len,0)
 739                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
 740                     {
 741                         RETSETUNDEF;
 742                     }
 743                 }
 744                 else {
 745                     if (PL_op->op_private & HINT_STRICT_REFS)
 746                         DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
 747                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 748                 }
 749             }
 750             else {
 751                 gv = (GV*)sv;
 752             }
 753             av = GvAVn(gv);
 754             if (PL_op->op_private & OPpLVAL_INTRO)
 755                 av = save_ary(gv);
 756             if (PL_op->op_flags & OPf_REF) {
 757                 SETs((SV*)av);
 758                 RETURN;
 759             }
 760             else if (LVRET) {
 761                 if (GIMME == G_SCALAR)
 762                     Perl_croak(aTHX_ "Can't return array to lvalue"
 763                                " scalar context");
 764                 SETs((SV*)av);
 765                 RETURN;
 766             }
 767         }
 768     }
 769
 770     if (GIMME == G_ARRAY) {
 771         I32 maxarg = AvFILL(av) + 1;
 772         (void)POPs;                     /* XXXX May be optimized away? */
 773         EXTEND(SP, maxarg);
 774         if (SvRMAGICAL(av)) {
 775             U32 i;
 776             for (i=0; i < (U32)maxarg; i++) {
 777                 SV **svp = av_fetch(av, i, FALSE);
 778                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 779             }
 780         }
 781         else {
 782             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 783         }
 784         SP += maxarg;
 785     }
 786     else if (GIMME_V == G_SCALAR) {
 787         dTARGET;
 788         I32 maxarg = AvFILL(av) + 1;
 789         SETi(maxarg);
 790     }
 791     RETURN;
 792 }
 793
 794 PP(pp_rv2hv)
 795 {
 796     dSP; dTOPss;
 797     HV *hv;
 798     I32 gimme = GIMME_V;
 799
 800     if (SvROK(sv)) {
 801       wasref:
 802         tryAMAGICunDEREF(to_hv);
 803
 804         hv = (HV*)SvRV(sv);
 805         if (SvTYPE(hv) != SVt_PVHV)
 806             DIE(aTHX_ "Not a HASH reference");
 807         if (PL_op->op_flags & OPf_REF) {
 808             SETs((SV*)hv);
 809             RETURN;
 810         }
 811         else if (LVRET) {
 812             if (GIMME != G_SCALAR)
 813                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 814             SETs((SV*)hv);
 815             RETURN;
 816         }
 817         else if (PL_op->op_flags & OPf_MOD
 818                 && PL_op->op_private & OPpLVAL_INTRO)
 819             Perl_croak(aTHX_ PL_no_localize_ref);
 820     }
 821     else {
 822         if (SvTYPE(sv) == SVt_PVHV) {
 823             hv = (HV*)sv;
 824             if (PL_op->op_flags & OPf_REF) {
 825                 SETs((SV*)hv);
 826                 RETURN;
 827             }
 828             else if (LVRET) {
 829                 if (GIMME == G_SCALAR)
 830                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 831                                " scalar context");
 832                 SETs((SV*)hv);
 833                 RETURN;
 834             }
 835         }
 836         else {
 837             GV *gv;
 838
 839             if (SvTYPE(sv) != SVt_PVGV) {
 840                 char *sym;
 841                 STRLEN len;
 842
 843                 if (SvGMAGICAL(sv)) {
 844                     mg_get(sv);
 845                     if (SvROK(sv))
 846                         goto wasref;
 847                 }
 848                 if (!SvOK(sv)) {
 849                     if (PL_op->op_flags & OPf_REF ||
 850                       PL_op->op_private & HINT_STRICT_REFS)
 851                         DIE(aTHX_ PL_no_usym, "a HASH");
 852                     if (ckWARN(WARN_UNINITIALIZED))
 853                         report_uninit();
 854                     if (GIMME == G_ARRAY) {
 855                         SP--;
 856                         RETURN;
 857                     }
 858                     RETSETUNDEF;
 859                 }
 860                 sym = SvPV(sv,len);
 861                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 862                     !(PL_op->op_flags & OPf_MOD))
 863                 {
 864                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
 865                     if (!gv
 866                         && (!is_gv_magical(sym,len,0)
 867                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
 868                     {
 869                         RETSETUNDEF;
 870                     }
 871                 }
 872                 else {
 873                     if (PL_op->op_private & HINT_STRICT_REFS)
 874                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
 875                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 876                 }
 877             }
 878             else {
 879                 gv = (GV*)sv;
 880             }
 881             hv = GvHVn(gv);
 882             if (PL_op->op_private & OPpLVAL_INTRO)
 883                 hv = save_hash(gv);
 884             if (PL_op->op_flags & OPf_REF) {
 885                 SETs((SV*)hv);
 886                 RETURN;
 887             }
 888             else if (LVRET) {
 889                 if (GIMME == G_SCALAR)
 890                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 891                                " scalar context");
 892                 SETs((SV*)hv);
 893                 RETURN;
 894             }
 895         }
 896     }
 897
 898     if (GIMME == G_ARRAY) { /* array wanted */
 899         *PL_stack_sp = (SV*)hv;
 900         return do_kv();
 901     }
 902     else {
 903         dTARGET;
 904         if (HvFILL(hv))
 905             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
 906                            (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
 907         else
 908             sv_setiv(TARG, 0);
 909
 910         SETTARG;
 911         RETURN;
 912     }
 913 }
 914
 915 STATIC void
 916 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 917 {
 918     if (*relem) {
 919         SV *tmpstr;
 920         HE *didstore;
 921
 922         if (ckWARN(WARN_MISC)) {
 923             if (relem == firstrelem &&
 924                 SvROK(*relem) &&
 925                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 926                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 927             {
 928                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 929                             "Reference found where even-sized list expected");
 930             }
 931             else
 932                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 933                             "Odd number of elements in hash assignment");
 934         }
 935
 936         tmpstr = NEWSV(29,0);
 937         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 938         if (SvMAGICAL(hash)) {
 939             if (SvSMAGICAL(tmpstr))
 940                 mg_set(tmpstr);
 941             if (!didstore)
 942                 sv_2mortal(tmpstr);
 943         }
 944         TAINT_NOT;
 945     }
 946 }
 947
 948 PP(pp_aassign)
 949 {
 950     dSP;
 951     SV **lastlelem = PL_stack_sp;
 952     SV **lastrelem = PL_stack_base + POPMARK;
 953     SV **firstrelem = PL_stack_base + POPMARK + 1;
 954     SV **firstlelem = lastrelem + 1;
 955
 956     register SV **relem;
 957     register SV **lelem;
 958
 959     register SV *sv;
 960     register AV *ary;
 961
 962     I32 gimme;
 963     HV *hash;
 964     I32 i;
 965     int magic;
 966
 967     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 968
 969     /* If there's a common identifier on both sides we have to take
 970      * special care that assigning the identifier on the left doesn't
 971      * clobber a value on the right that's used later in the list.
 972      */
 973     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 974         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 975         for (relem = firstrelem; relem <= lastrelem; relem++) {
 976             /*SUPPRESS 560*/
 977             if ((sv = *relem)) {
 978                 TAINT_NOT;      /* Each item is independent */
 979                 *relem = sv_mortalcopy(sv);
 980             }
 981         }
 982     }
 983
 984     relem = firstrelem;
 985     lelem = firstlelem;
 986     ary = Null(AV*);
 987     hash = Null(HV*);
 988
 989     while (lelem <= lastlelem) {
 990         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 991         sv = *lelem++;
 992         switch (SvTYPE(sv)) {
 993         case SVt_PVAV:
 994             ary = (AV*)sv;
 995             magic = SvMAGICAL(ary) != 0;
 996             av_clear(ary);
 997             av_extend(ary, lastrelem - relem);
 998             i = 0;
 999             while (relem <= lastrelem) {        /* gobble up all the rest */
1000                 SV **didstore;
1001                 sv = NEWSV(28,0);
1002                 assert(*relem);
1003                 sv_setsv(sv,*relem);
1004                 *(relem++) = sv;
1005                 didstore = av_store(ary,i++,sv);
1006                 if (magic) {
1007                     if (SvSMAGICAL(sv))
1008                         mg_set(sv);
1009                     if (!didstore)
1010                         sv_2mortal(sv);
1011                 }
1012                 TAINT_NOT;
1013             }
1014             break;
1015         case SVt_PVHV: {                                /* normal hash */
1016                 SV *tmpstr;
1017
1018                 hash = (HV*)sv;
1019                 magic = SvMAGICAL(hash) != 0;
1020                 hv_clear(hash);
1021
1022                 while (relem < lastrelem) {     /* gobble up all the rest */
1023                     HE *didstore;
1024                     if (*relem)
1025                         sv = *(relem++);
1026                     else
1027                         sv = &PL_sv_no, relem++;
1028                     tmpstr = NEWSV(29,0);
1029                     if (*relem)
1030                         sv_setsv(tmpstr,*relem);        /* value */
1031                     *(relem++) = tmpstr;
1032                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1033                     if (magic) {
1034                         if (SvSMAGICAL(tmpstr))
1035                             mg_set(tmpstr);
1036                         if (!didstore)
1037                             sv_2mortal(tmpstr);
1038                     }
1039                     TAINT_NOT;
1040                 }
1041                 if (relem == lastrelem) {
1042                     do_oddball(hash, relem, firstrelem);
1043                     relem++;
1044                 }
1045             }
1046             break;
1047         default:
1048             if (SvIMMORTAL(sv)) {
1049                 if (relem <= lastrelem)
1050                     relem++;
1051                 break;
1052             }
1053             if (relem <= lastrelem) {
1054                 sv_setsv(sv, *relem);
1055                 *(relem++) = sv;
1056             }
1057             else
1058                 sv_setsv(sv, &PL_sv_undef);
1059             SvSETMAGIC(sv);
1060             break;
1061         }
1062     }
1063     if (PL_delaymagic & ~DM_DELAY) {
1064         if (PL_delaymagic & DM_UID) {
1065 #ifdef HAS_SETRESUID
1066             (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1067 #else
1068 #  ifdef HAS_SETREUID
1069             (void)setreuid(PL_uid,PL_euid);
1070 #  else
1071 #    ifdef HAS_SETRUID
1072             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1073                 (void)setruid(PL_uid);
1074                 PL_delaymagic &= ~DM_RUID;
1075             }
1076 #    endif /* HAS_SETRUID */
1077 #    ifdef HAS_SETEUID
1078             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1079                 (void)seteuid(PL_uid);
1080                 PL_delaymagic &= ~DM_EUID;
1081             }
1082 #    endif /* HAS_SETEUID */
1083             if (PL_delaymagic & DM_UID) {
1084                 if (PL_uid != PL_euid)
1085                     DIE(aTHX_ "No setreuid available");
1086                 (void)PerlProc_setuid(PL_uid);
1087             }
1088 #  endif /* HAS_SETREUID */
1089 #endif /* HAS_SETRESUID */
1090             PL_uid = PerlProc_getuid();
1091             PL_euid = PerlProc_geteuid();
1092         }
1093         if (PL_delaymagic & DM_GID) {
1094 #ifdef HAS_SETRESGID
1095             (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1096 #else
1097 #  ifdef HAS_SETREGID
1098             (void)setregid(PL_gid,PL_egid);
1099 #  else
1100 #    ifdef HAS_SETRGID
1101             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1102                 (void)setrgid(PL_gid);
1103                 PL_delaymagic &= ~DM_RGID;
1104             }
1105 #    endif /* HAS_SETRGID */
1106 #    ifdef HAS_SETEGID
1107             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1108                 (void)setegid(PL_gid);
1109                 PL_delaymagic &= ~DM_EGID;
1110             }
1111 #    endif /* HAS_SETEGID */
1112             if (PL_delaymagic & DM_GID) {
1113                 if (PL_gid != PL_egid)
1114                     DIE(aTHX_ "No setregid available");
1115                 (void)PerlProc_setgid(PL_gid);
1116             }
1117 #  endif /* HAS_SETREGID */
1118 #endif /* HAS_SETRESGID */
1119             PL_gid = PerlProc_getgid();
1120             PL_egid = PerlProc_getegid();
1121         }
1122         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1123     }
1124     PL_delaymagic = 0;
1125
1126     gimme = GIMME_V;
1127     if (gimme == G_VOID)
1128         SP = firstrelem - 1;
1129     else if (gimme == G_SCALAR) {
1130         dTARGET;
1131         SP = firstrelem;
1132         SETi(lastrelem - firstrelem + 1);
1133     }
1134     else {
1135         if (ary || hash)
1136             SP = lastrelem;
1137         else
1138             SP = firstrelem + (lastlelem - firstlelem);
1139         lelem = firstlelem + (relem - firstrelem);
1140         while (relem <= SP)
1141             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1142     }
1143     RETURN;
1144 }
1145
1146 PP(pp_qr)
1147 {
1148     dSP;
1149     register PMOP *pm = cPMOP;
1150     SV *rv = sv_newmortal();
1151     SV *sv = newSVrv(rv, "Regexp");
1152     if (pm->op_pmdynflags & PMdf_TAINTED)
1153         SvTAINTED_on(rv);
1154     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1155     RETURNX(PUSHs(rv));
1156 }
1157
1158 PP(pp_match)
1159 {
1160     dSP; dTARG;
1161     register PMOP *pm = cPMOP;
1162     PMOP *dynpm = pm;
1163     register char *t;
1164     register char *s;
1165     char *strend;
1166     I32 global;
1167     I32 r_flags = REXEC_CHECKED;
1168     char *truebase;                     /* Start of string  */
1169     register REGEXP *rx = PM_GETRE(pm);
1170     bool rxtainted;
1171     I32 gimme = GIMME;
1172     STRLEN len;
1173     I32 minmatch = 0;
1174     I32 oldsave = PL_savestack_ix;
1175     I32 update_minmatch = 1;
1176     I32 had_zerolen = 0;
1177
1178     if (PL_op->op_flags & OPf_STACKED)
1179         TARG = POPs;
1180     else {
1181         TARG = DEFSV;
1182         EXTEND(SP,1);
1183     }
1184
1185     PUTBACK;                            /* EVAL blocks need stack_sp. */
1186     s = SvPV(TARG, len);
1187     strend = s + len;
1188     if (!s)
1189         DIE(aTHX_ "panic: pp_match");
1190     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1191                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1192     TAINT_NOT;
1193
1194     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1195
1196     /* PMdf_USED is set after a ?? matches once */
1197     if (pm->op_pmdynflags & PMdf_USED) {
1198       failure:
1199         if (gimme == G_ARRAY)
1200             RETURN;
1201         RETPUSHNO;
1202     }
1203
1204     /* empty pattern special-cased to use last successful pattern if possible */
1205     if (!rx->prelen && PL_curpm) {
1206         pm = PL_curpm;
1207         rx = PM_GETRE(pm);
1208     }
1209
1210     if (rx->minlen > (I32)len)
1211         goto failure;
1212
1213     truebase = t = s;
1214
1215     /* XXXX What part of this is needed with true \G-support? */
1216     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1217         rx->startp[0] = -1;
1218         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1219             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1220             if (mg && mg->mg_len >= 0) {
1221                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1222                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1223                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1224                     r_flags |= REXEC_IGNOREPOS;
1225                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1226                 }
1227                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1228                 update_minmatch = 0;
1229             }
1230         }
1231     }
1232     if ((!global && rx->nparens)
1233             || SvTEMP(TARG) || PL_sawampersand)
1234         r_flags |= REXEC_COPY_STR;
1235     if (SvSCREAM(TARG))
1236         r_flags |= REXEC_SCREAM;
1237
1238     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1239         SAVEINT(PL_multiline);
1240         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1241     }
1242
1243 play_it_again:
1244     if (global && rx->startp[0] != -1) {
1245         t = s = rx->endp[0] + truebase;
1246         if ((s + rx->minlen) > strend)
1247             goto nope;
1248         if (update_minmatch++)
1249             minmatch = had_zerolen;
1250     }
1251     if (rx->reganch & RE_USE_INTUIT &&
1252         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1253         PL_bostr = truebase;
1254         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1255
1256         if (!s)
1257             goto nope;
1258         if ( (rx->reganch & ROPT_CHECK_ALL)
1259              && !PL_sawampersand
1260              && ((rx->reganch & ROPT_NOSCAN)
1261                  || !((rx->reganch & RE_INTUIT_TAIL)
1262                       && (r_flags & REXEC_SCREAM)))
1263              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1264             goto yup;
1265     }
1266     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1267     {
1268         PL_curpm = pm;
1269         if (dynpm->op_pmflags & PMf_ONCE)
1270             dynpm->op_pmdynflags |= PMdf_USED;
1271         goto gotcha;
1272     }
1273     else
1274         goto ret_no;
1275     /*NOTREACHED*/
1276
1277   gotcha:
1278     if (rxtainted)
1279         RX_MATCH_TAINTED_on(rx);
1280     TAINT_IF(RX_MATCH_TAINTED(rx));
1281     if (gimme == G_ARRAY) {
1282         I32 nparens, i, len;
1283
1284         nparens = rx->nparens;
1285         if (global && !nparens)
1286             i = 1;
1287         else
1288             i = 0;
1289         SPAGAIN;                        /* EVAL blocks could move the stack. */
1290         EXTEND(SP, nparens + i);
1291         EXTEND_MORTAL(nparens + i);
1292         for (i = !i; i <= nparens; i++) {
1293             PUSHs(sv_newmortal());
1294             /*SUPPRESS 560*/
1295             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1296                 len = rx->endp[i] - rx->startp[i];
1297                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1298                     len < 0 || len > strend - s)
1299                     DIE(aTHX_ "panic: pp_match start/end pointers");
1300                 s = rx->startp[i] + truebase;
1301                 sv_setpvn(*SP, s, len);
1302                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1303                     SvUTF8_on(*SP);
1304             }
1305         }
1306         if (global) {
1307             if (dynpm->op_pmflags & PMf_CONTINUE) {
1308                 MAGIC* mg = 0;
1309                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1310                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1311                 if (!mg) {
1312                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1313                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1314                 }
1315                 if (rx->startp[0] != -1) {
1316                     mg->mg_len = rx->endp[0];
1317                     if (rx->startp[0] == rx->endp[0])
1318                         mg->mg_flags |= MGf_MINMATCH;
1319                     else
1320                         mg->mg_flags &= ~MGf_MINMATCH;
1321                 }
1322             }
1323             had_zerolen = (rx->startp[0] != -1
1324                            && rx->startp[0] == rx->endp[0]);
1325             PUTBACK;                    /* EVAL blocks may use stack */
1326             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1327             goto play_it_again;
1328         }
1329         else if (!nparens)
1330             XPUSHs(&PL_sv_yes);
1331         LEAVE_SCOPE(oldsave);
1332         RETURN;
1333     }
1334     else {
1335         if (global) {
1336             MAGIC* mg = 0;
1337             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1338                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339             if (!mg) {
1340                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1341                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342             }
1343             if (rx->startp[0] != -1) {
1344                 mg->mg_len = rx->endp[0];
1345                 if (rx->startp[0] == rx->endp[0])
1346                     mg->mg_flags |= MGf_MINMATCH;
1347                 else
1348                     mg->mg_flags &= ~MGf_MINMATCH;
1349             }
1350         }
1351         LEAVE_SCOPE(oldsave);
1352         RETPUSHYES;
1353     }
1354
1355 yup:                                    /* Confirmed by INTUIT */
1356     if (rxtainted)
1357         RX_MATCH_TAINTED_on(rx);
1358     TAINT_IF(RX_MATCH_TAINTED(rx));
1359     PL_curpm = pm;
1360     if (dynpm->op_pmflags & PMf_ONCE)
1361         dynpm->op_pmdynflags |= PMdf_USED;
1362     if (RX_MATCH_COPIED(rx))
1363         Safefree(rx->subbeg);
1364     RX_MATCH_COPIED_off(rx);
1365     rx->subbeg = Nullch;
1366     if (global) {
1367         rx->subbeg = truebase;
1368         rx->startp[0] = s - truebase;
1369         if (RX_MATCH_UTF8(rx)) {
1370             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1371             rx->endp[0] = t - truebase;
1372         }
1373         else {
1374             rx->endp[0] = s - truebase + rx->minlen;
1375         }
1376         rx->sublen = strend - truebase;
1377         goto gotcha;
1378     }
1379     if (PL_sawampersand) {
1380         I32 off;
1381 #ifdef PERL_COPY_ON_WRITE
1382         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1383             if (DEBUG_C_TEST) {
1384                 PerlIO_printf(Perl_debug_log,
1385                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1386                               (int) SvTYPE(TARG), truebase, t,
1387                               (int)(t-truebase));
1388             }
1389             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1390             rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1391             assert (SvPOKp(rx->saved_copy));
1392         } else
1393 #endif
1394         {
1395
1396             rx->subbeg = savepvn(t, strend - t);
1397 #ifdef PERL_COPY_ON_WRITE
1398             rx->saved_copy = Nullsv;
1399 #endif
1400         }
1401         rx->sublen = strend - t;
1402         RX_MATCH_COPIED_on(rx);
1403         off = rx->startp[0] = s - t;
1404         rx->endp[0] = off + rx->minlen;
1405     }
1406     else {                      /* startp/endp are used by @- @+. */
1407         rx->startp[0] = s - truebase;
1408         rx->endp[0] = s - truebase + rx->minlen;
1409     }
1410     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1411     LEAVE_SCOPE(oldsave);
1412     RETPUSHYES;
1413
1414 nope:
1415 ret_no:
1416     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1417         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1418             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1419             if (mg)
1420                 mg->mg_len = -1;
1421         }
1422     }
1423     LEAVE_SCOPE(oldsave);
1424     if (gimme == G_ARRAY)
1425         RETURN;
1426     RETPUSHNO;
1427 }
1428
1429 OP *
1430 Perl_do_readline(pTHX)
1431 {
1432     dSP; dTARGETSTACKED;
1433     register SV *sv;
1434     STRLEN tmplen = 0;
1435     STRLEN offset;
1436     PerlIO *fp;
1437     register IO *io = GvIO(PL_last_in_gv);
1438     register I32 type = PL_op->op_type;
1439     I32 gimme = GIMME_V;
1440     MAGIC *mg;
1441
1442     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1443         PUSHMARK(SP);
1444         XPUSHs(SvTIED_obj((SV*)io, mg));
1445         PUTBACK;
1446         ENTER;
1447         call_method("READLINE", gimme);
1448         LEAVE;
1449         SPAGAIN;
1450         if (gimme == G_SCALAR) {
1451             SV* result = POPs;
1452             SvSetSV_nosteal(TARG, result);
1453             PUSHTARG;
1454         }
1455         RETURN;
1456     }
1457     fp = Nullfp;
1458     if (io) {
1459         fp = IoIFP(io);
1460         if (!fp) {
1461             if (IoFLAGS(io) & IOf_ARGV) {
1462                 if (IoFLAGS(io) & IOf_START) {
1463                     IoLINES(io) = 0;
1464                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1465                         IoFLAGS(io) &= ~IOf_START;
1466                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1467                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1468                         SvSETMAGIC(GvSV(PL_last_in_gv));
1469                         fp = IoIFP(io);
1470                         goto have_fp;
1471                     }
1472                 }
1473                 fp = nextargv(PL_last_in_gv);
1474                 if (!fp) { /* Note: fp != IoIFP(io) */
1475                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1476                 }
1477             }
1478             else if (type == OP_GLOB)
1479                 fp = Perl_start_glob(aTHX_ POPs, io);
1480         }
1481         else if (type == OP_GLOB)
1482             SP--;
1483         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1484             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1485         }
1486     }
1487     if (!fp) {
1488         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1489                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1490             if (type == OP_GLOB)
1491                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1492                             "glob failed (can't start child: %s)",
1493                             Strerror(errno));
1494             else
1495                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1496         }
1497         if (gimme == G_SCALAR) {
1498             /* undef TARG, and push that undefined value */
1499             if (type != OP_RCATLINE) {
1500                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1501                 SvOK_off(TARG);
1502             }
1503             PUSHTARG;
1504         }
1505         RETURN;
1506     }
1507   have_fp:
1508     if (gimme == G_SCALAR) {
1509         sv = TARG;
1510         if (SvROK(sv))
1511             sv_unref(sv);
1512         (void)SvUPGRADE(sv, SVt_PV);
1513         tmplen = SvLEN(sv);     /* remember if already alloced */
1514         if (!tmplen && !SvREADONLY(sv))
1515             Sv_Grow(sv, 80);    /* try short-buffering it */
1516         offset = 0;
1517         if (type == OP_RCATLINE && SvOK(sv)) {
1518             if (!SvPOK(sv)) {
1519                 STRLEN n_a;
1520                 (void)SvPV_force(sv, n_a);
1521             }
1522             offset = SvCUR(sv);
1523         }
1524     }
1525     else {
1526         sv = sv_2mortal(NEWSV(57, 80));
1527         offset = 0;
1528     }
1529
1530     /* This should not be marked tainted if the fp is marked clean */
1531 #define MAYBE_TAINT_LINE(io, sv) \
1532     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1533         TAINT;                          \
1534         SvTAINTED_on(sv);               \
1535     }
1536
1537 /* delay EOF state for a snarfed empty file */
1538 #define SNARF_EOF(gimme,rs,io,sv) \
1539     (gimme != G_SCALAR || SvCUR(sv)                                     \
1540      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1541
1542     for (;;) {
1543         PUTBACK;
1544         if (!sv_gets(sv, fp, offset)
1545             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1546         {
1547             PerlIO_clearerr(fp);
1548             if (IoFLAGS(io) & IOf_ARGV) {
1549                 fp = nextargv(PL_last_in_gv);
1550                 if (fp)
1551                     continue;
1552                 (void)do_close(PL_last_in_gv, FALSE);
1553             }
1554             else if (type == OP_GLOB) {
1555                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1556                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1557                            "glob failed (child exited with status %d%s)",
1558                            (int)(STATUS_CURRENT >> 8),
1559                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1560                 }
1561             }
1562             if (gimme == G_SCALAR) {
1563                 if (type != OP_RCATLINE) {
1564                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1565                     SvOK_off(TARG);
1566                 }
1567                 SPAGAIN;
1568                 PUSHTARG;
1569             }
1570             MAYBE_TAINT_LINE(io, sv);
1571             RETURN;
1572         }
1573         MAYBE_TAINT_LINE(io, sv);
1574         IoLINES(io)++;
1575         IoFLAGS(io) |= IOf_NOLINE;
1576         SvSETMAGIC(sv);
1577         SPAGAIN;
1578         XPUSHs(sv);
1579         if (type == OP_GLOB) {
1580             char *tmps;
1581
1582             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1583                 tmps = SvEND(sv) - 1;
1584                 if (*tmps == *SvPVX(PL_rs)) {
1585                     *tmps = '\0';
1586                     SvCUR(sv)--;
1587                 }
1588             }
1589             for (tmps = SvPVX(sv); *tmps; tmps++)
1590                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1591                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1592                         break;
1593             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1594                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1595                 continue;
1596             }
1597         }
1598         if (gimme == G_ARRAY) {
1599             if (SvLEN(sv) - SvCUR(sv) > 20) {
1600                 SvLEN_set(sv, SvCUR(sv)+1);
1601                 Renew(SvPVX(sv), SvLEN(sv), char);
1602             }
1603             sv = sv_2mortal(NEWSV(58, 80));
1604             continue;
1605         }
1606         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1607             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1608             if (SvCUR(sv) < 60)
1609                 SvLEN_set(sv, 80);
1610             else
1611                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1612             Renew(SvPVX(sv), SvLEN(sv), char);
1613         }
1614         RETURN;
1615     }
1616 }
1617
1618 PP(pp_enter)
1619 {
1620     dSP;
1621     register PERL_CONTEXT *cx;
1622     I32 gimme = OP_GIMME(PL_op, -1);
1623
1624     if (gimme == -1) {
1625         if (cxstack_ix >= 0)
1626             gimme = cxstack[cxstack_ix].blk_gimme;
1627         else
1628             gimme = G_SCALAR;
1629     }
1630
1631     ENTER;
1632
1633     SAVETMPS;
1634     PUSHBLOCK(cx, CXt_BLOCK, SP);
1635
1636     RETURN;
1637 }
1638
1639 PP(pp_helem)
1640 {
1641     dSP;
1642     HE* he;
1643     SV **svp;
1644     SV *keysv = POPs;
1645     HV *hv = (HV*)POPs;
1646     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1647     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1648     SV *sv;
1649 #ifdef PERL_COPY_ON_WRITE
1650     U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1651 #else
1652     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1653 #endif
1654     I32 preeminent = 0;
1655
1656     if (SvTYPE(hv) == SVt_PVHV) {
1657         if (PL_op->op_private & OPpLVAL_INTRO) {
1658             MAGIC *mg;
1659             HV *stash;
1660             /* does the element we're localizing already exist? */
1661             preeminent =
1662                 /* can we determine whether it exists? */
1663                 (    !SvRMAGICAL(hv)
1664                   || mg_find((SV*)hv, PERL_MAGIC_env)
1665                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1666                         /* Try to preserve the existenceness of a tied hash
1667                          * element by using EXISTS and DELETE if possible.
1668                          * Fallback to FETCH and STORE otherwise */
1669                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1670                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1671                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1672                     )
1673                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1674
1675         }
1676         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1677         svp = he ? &HeVAL(he) : 0;
1678     }
1679     else {
1680         RETPUSHUNDEF;
1681     }
1682     if (lval) {
1683         if (!svp || *svp == &PL_sv_undef) {
1684             SV* lv;
1685             SV* key2;
1686             if (!defer) {
1687                 STRLEN n_a;
1688                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1689             }
1690             lv = sv_newmortal();
1691             sv_upgrade(lv, SVt_PVLV);
1692             LvTYPE(lv) = 'y';
1693             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1694             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1695             LvTARG(lv) = SvREFCNT_inc(hv);
1696             LvTARGLEN(lv) = 1;
1697             PUSHs(lv);
1698             RETURN;
1699         }
1700         if (PL_op->op_private & OPpLVAL_INTRO) {
1701             if (HvNAME(hv) && isGV(*svp))
1702                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1703             else {
1704                 if (!preeminent) {
1705                     STRLEN keylen;
1706                     char *key = SvPV(keysv, keylen);
1707                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1708                 } else
1709                     save_helem(hv, keysv, svp);
1710             }
1711         }
1712         else if (PL_op->op_private & OPpDEREF)
1713             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1714     }
1715     sv = (svp ? *svp : &PL_sv_undef);
1716     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1717      * Pushing the magical RHS on to the stack is useless, since
1718      * that magic is soon destined to be misled by the local(),
1719      * and thus the later pp_sassign() will fail to mg_get() the
1720      * old value.  This should also cure problems with delayed
1721      * mg_get()s.  GSAR 98-07-03 */
1722     if (!lval && SvGMAGICAL(sv))
1723         sv = sv_mortalcopy(sv);
1724     PUSHs(sv);
1725     RETURN;
1726 }
1727
1728 PP(pp_leave)
1729 {
1730     dSP;
1731     register PERL_CONTEXT *cx;
1732     register SV **mark;
1733     SV **newsp;
1734     PMOP *newpm;
1735     I32 gimme;
1736
1737     if (PL_op->op_flags & OPf_SPECIAL) {
1738         cx = &cxstack[cxstack_ix];
1739         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1740     }
1741
1742     POPBLOCK(cx,newpm);
1743
1744     gimme = OP_GIMME(PL_op, -1);
1745     if (gimme == -1) {
1746         if (cxstack_ix >= 0)
1747             gimme = cxstack[cxstack_ix].blk_gimme;
1748         else
1749             gimme = G_SCALAR;
1750     }
1751
1752     TAINT_NOT;
1753     if (gimme == G_VOID)
1754         SP = newsp;
1755     else if (gimme == G_SCALAR) {
1756         MARK = newsp + 1;
1757         if (MARK <= SP) {
1758             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1759                 *MARK = TOPs;
1760             else
1761                 *MARK = sv_mortalcopy(TOPs);
1762         } else {
1763             MEXTEND(mark,0);
1764             *MARK = &PL_sv_undef;
1765         }
1766         SP = MARK;
1767     }
1768     else if (gimme == G_ARRAY) {
1769         /* in case LEAVE wipes old return values */
1770         for (mark = newsp + 1; mark <= SP; mark++) {
1771             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1772                 *mark = sv_mortalcopy(*mark);
1773                 TAINT_NOT;      /* Each item is independent */
1774             }
1775         }
1776     }
1777     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1778
1779     LEAVE;
1780
1781     RETURN;
1782 }
1783
1784 PP(pp_iter)
1785 {
1786     dSP;
1787     register PERL_CONTEXT *cx;
1788     SV* sv;
1789     AV* av;
1790     SV **itersvp;
1791
1792     EXTEND(SP, 1);
1793     cx = &cxstack[cxstack_ix];
1794     if (CxTYPE(cx) != CXt_LOOP)
1795         DIE(aTHX_ "panic: pp_iter");
1796
1797     itersvp = CxITERVAR(cx);
1798     av = cx->blk_loop.iterary;
1799     if (SvTYPE(av) != SVt_PVAV) {
1800         /* iterate ($min .. $max) */
1801         if (cx->blk_loop.iterlval) {
1802             /* string increment */
1803             register SV* cur = cx->blk_loop.iterlval;
1804             STRLEN maxlen;
1805             char *max = SvPV((SV*)av, maxlen);
1806             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1807                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1808                     /* safe to reuse old SV */
1809                     sv_setsv(*itersvp, cur);
1810                 }
1811                 else
1812                 {
1813                     /* we need a fresh SV every time so that loop body sees a
1814                      * completely new SV for closures/references to work as
1815                      * they used to */
1816                     SvREFCNT_dec(*itersvp);
1817                     *itersvp = newSVsv(cur);
1818                 }
1819                 if (strEQ(SvPVX(cur), max))
1820                     sv_setiv(cur, 0); /* terminate next time */
1821                 else
1822                     sv_inc(cur);
1823                 RETPUSHYES;
1824             }
1825             RETPUSHNO;
1826         }
1827         /* integer increment */
1828         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1829             RETPUSHNO;
1830
1831         /* don't risk potential race */
1832         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1833             /* safe to reuse old SV */
1834             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1835         }
1836         else
1837         {
1838             /* we need a fresh SV every time so that loop body sees a
1839              * completely new SV for closures/references to work as they
1840              * used to */
1841             SvREFCNT_dec(*itersvp);
1842             *itersvp = newSViv(cx->blk_loop.iterix++);
1843         }
1844         RETPUSHYES;
1845     }
1846
1847     /* iterate array */
1848     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1849         RETPUSHNO;
1850
1851     SvREFCNT_dec(*itersvp);
1852
1853     if (SvMAGICAL(av) || AvREIFY(av)) {
1854         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1855         if (svp)
1856             sv = *svp;
1857         else
1858             sv = Nullsv;
1859     }
1860     else {
1861         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1862     }
1863     if (sv && SvREFCNT(sv) == 0) {
1864         *itersvp = Nullsv;
1865         Perl_croak(aTHX_
1866             "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)");
1867     }
1868
1869     if (sv)
1870         SvTEMP_off(sv);
1871     else
1872         sv = &PL_sv_undef;
1873     if (av != PL_curstack && sv == &PL_sv_undef) {
1874         SV *lv = cx->blk_loop.iterlval;
1875         if (lv && SvREFCNT(lv) > 1) {
1876             SvREFCNT_dec(lv);
1877             lv = Nullsv;
1878         }
1879         if (lv)
1880             SvREFCNT_dec(LvTARG(lv));
1881         else {
1882             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1883             sv_upgrade(lv, SVt_PVLV);
1884             LvTYPE(lv) = 'y';
1885             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1886         }
1887         LvTARG(lv) = SvREFCNT_inc(av);
1888         LvTARGOFF(lv) = cx->blk_loop.iterix;
1889         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1890         sv = (SV*)lv;
1891     }
1892
1893     *itersvp = SvREFCNT_inc(sv);
1894     RETPUSHYES;
1895 }
1896
1897 PP(pp_subst)
1898 {
1899     dSP; dTARG;
1900     register PMOP *pm = cPMOP;
1901     PMOP *rpm = pm;
1902     register SV *dstr;
1903     register char *s;
1904     char *strend;
1905     register char *m;
1906     char *c;
1907     register char *d;
1908     STRLEN clen;
1909     I32 iters = 0;
1910     I32 maxiters;
1911     register I32 i;
1912     bool once;
1913     bool rxtainted;
1914     char *orig;
1915     I32 r_flags;
1916     register REGEXP *rx = PM_GETRE(pm);
1917     STRLEN len;
1918     int force_on_match = 0;
1919     I32 oldsave = PL_savestack_ix;
1920     STRLEN slen;
1921     bool doutf8 = FALSE;
1922 #ifdef PERL_COPY_ON_WRITE
1923     bool is_cow;
1924 #endif
1925     SV *nsv = Nullsv;
1926
1927     /* known replacement string? */
1928     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1929     if (PL_op->op_flags & OPf_STACKED)
1930         TARG = POPs;
1931     else {
1932         TARG = DEFSV;
1933         EXTEND(SP,1);
1934     }
1935
1936 #ifdef PERL_COPY_ON_WRITE
1937     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1938        because they make integers such as 256 "false".  */
1939     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1940 #else
1941     if (SvIsCOW(TARG))
1942         sv_force_normal_flags(TARG,0);
1943 #endif
1944     if (
1945 #ifdef PERL_COPY_ON_WRITE
1946         !is_cow &&
1947 #endif
1948         (SvREADONLY(TARG)
1949         || (SvTYPE(TARG) > SVt_PVLV
1950             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1951         DIE(aTHX_ PL_no_modify);
1952     PUTBACK;
1953
1954     s = SvPV(TARG, len);
1955     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1956         force_on_match = 1;
1957     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1958                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1959     if (PL_tainted)
1960         rxtainted |= 2;
1961     TAINT_NOT;
1962
1963     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1964
1965   force_it:
1966     if (!pm || !s)
1967         DIE(aTHX_ "panic: pp_subst");
1968
1969     strend = s + len;
1970     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1971     maxiters = 2 * slen + 10;   /* We can match twice at each
1972                                    position, once with zero-length,
1973                                    second time with non-zero. */
1974
1975     if (!rx->prelen && PL_curpm) {
1976         pm = PL_curpm;
1977         rx = PM_GETRE(pm);
1978     }
1979     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1980                ? REXEC_COPY_STR : 0;
1981     if (SvSCREAM(TARG))
1982         r_flags |= REXEC_SCREAM;
1983     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1984         SAVEINT(PL_multiline);
1985         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1986     }
1987     orig = m = s;
1988     if (rx->reganch & RE_USE_INTUIT) {
1989         PL_bostr = orig;
1990         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1991
1992         if (!s)
1993             goto nope;
1994         /* How to do it in subst? */
1995 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1996              && !PL_sawampersand
1997              && ((rx->reganch & ROPT_NOSCAN)
1998                  || !((rx->reganch & RE_INTUIT_TAIL)
1999                       && (r_flags & REXEC_SCREAM))))
2000             goto yup;
2001 */
2002     }
2003
2004     /* only replace once? */
2005     once = !(rpm->op_pmflags & PMf_GLOBAL);
2006
2007     /* known replacement string? */
2008     if (dstr) {
2009         /* replacement needing upgrading? */
2010         if (DO_UTF8(TARG) && !doutf8) {
2011              nsv = sv_newmortal();
2012              SvSetSV(nsv, dstr);
2013              if (PL_encoding)
2014                   sv_recode_to_utf8(nsv, PL_encoding);
2015              else
2016                   sv_utf8_upgrade(nsv);
2017              c = SvPV(nsv, clen);
2018              doutf8 = TRUE;
2019         }
2020         else {
2021             c = SvPV(dstr, clen);
2022             doutf8 = DO_UTF8(dstr);
2023         }
2024     }
2025     else {
2026         c = Nullch;
2027         doutf8 = FALSE;
2028     }
2029
2030     /* can do inplace substitution? */
2031     if (c
2032 #ifdef PERL_COPY_ON_WRITE
2033         && !is_cow
2034 #endif
2035         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2036         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2037         && (!doutf8 || SvUTF8(TARG))) {
2038         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2039                          r_flags | REXEC_CHECKED))
2040         {
2041             SPAGAIN;
2042             PUSHs(&PL_sv_no);
2043             LEAVE_SCOPE(oldsave);
2044             RETURN;
2045         }
2046 #ifdef PERL_COPY_ON_WRITE
2047         if (SvIsCOW(TARG)) {
2048             assert (!force_on_match);
2049             goto have_a_cow;
2050         }
2051 #endif
2052         if (force_on_match) {
2053             force_on_match = 0;
2054             s = SvPV_force(TARG, len);
2055             goto force_it;
2056         }
2057         d = s;
2058         PL_curpm = pm;
2059         SvSCREAM_off(TARG);     /* disable possible screamer */
2060         if (once) {
2061             rxtainted |= RX_MATCH_TAINTED(rx);
2062             m = orig + rx->startp[0];
2063             d = orig + rx->endp[0];
2064             s = orig;
2065             if (m - s > strend - d) {  /* faster to shorten from end */
2066                 if (clen) {
2067                     Copy(c, m, clen, char);
2068                     m += clen;
2069                 }
2070                 i = strend - d;
2071                 if (i > 0) {
2072                     Move(d, m, i, char);
2073                     m += i;
2074                 }
2075                 *m = '\0';
2076                 SvCUR_set(TARG, m - s);
2077             }
2078             /*SUPPRESS 560*/
2079             else if ((i = m - s)) {     /* faster from front */
2080                 d -= clen;
2081                 m = d;
2082                 sv_chop(TARG, d-i);
2083                 s += i;
2084                 while (i--)
2085                     *--d = *--s;
2086                 if (clen)
2087                     Copy(c, m, clen, char);
2088             }
2089             else if (clen) {
2090                 d -= clen;
2091                 sv_chop(TARG, d);
2092                 Copy(c, d, clen, char);
2093             }
2094             else {
2095                 sv_chop(TARG, d);
2096             }
2097             TAINT_IF(rxtainted & 1);
2098             SPAGAIN;
2099             PUSHs(&PL_sv_yes);
2100         }
2101         else {
2102             do {
2103                 if (iters++ > maxiters)
2104                     DIE(aTHX_ "Substitution loop");
2105                 rxtainted |= RX_MATCH_TAINTED(rx);
2106                 m = rx->startp[0] + orig;
2107                 /*SUPPRESS 560*/
2108                 if ((i = m - s)) {
2109                     if (s != d)
2110                         Move(s, d, i, char);
2111                     d += i;
2112                 }
2113                 if (clen) {
2114                     Copy(c, d, clen, char);
2115                     d += clen;
2116                 }
2117                 s = rx->endp[0] + orig;
2118             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2119                                  TARG, NULL,
2120                                  /* don't match same null twice */
2121                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2122             if (s != d) {
2123                 i = strend - s;
2124                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2125                 Move(s, d, i+1, char);          /* include the NUL */
2126             }
2127             TAINT_IF(rxtainted & 1);
2128             SPAGAIN;
2129             PUSHs(sv_2mortal(newSViv((I32)iters)));
2130         }
2131         (void)SvPOK_only_UTF8(TARG);
2132         TAINT_IF(rxtainted);
2133         if (SvSMAGICAL(TARG)) {
2134             PUTBACK;
2135             mg_set(TARG);
2136             SPAGAIN;
2137         }
2138         SvTAINT(TARG);
2139         if (doutf8)
2140             SvUTF8_on(TARG);
2141         LEAVE_SCOPE(oldsave);
2142         RETURN;
2143     }
2144
2145     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2146                     r_flags | REXEC_CHECKED))
2147     {
2148         if (force_on_match) {
2149             force_on_match = 0;
2150             s = SvPV_force(TARG, len);
2151             goto force_it;
2152         }
2153 #ifdef PERL_COPY_ON_WRITE
2154       have_a_cow:
2155 #endif
2156         rxtainted |= RX_MATCH_TAINTED(rx);
2157         dstr = NEWSV(25, len);
2158         sv_setpvn(dstr, m, s-m);
2159         if (DO_UTF8(TARG))
2160             SvUTF8_on(dstr);
2161         PL_curpm = pm;
2162         if (!c) {
2163             register PERL_CONTEXT *cx;
2164             SPAGAIN;
2165             ReREFCNT_inc(rx);
2166             PUSHSUBST(cx);
2167             RETURNOP(cPMOP->op_pmreplroot);
2168         }
2169         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2170         do {
2171             if (iters++ > maxiters)
2172                 DIE(aTHX_ "Substitution loop");
2173             rxtainted |= RX_MATCH_TAINTED(rx);
2174             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2175                 m = s;
2176                 s = orig;
2177                 orig = rx->subbeg;
2178                 s = orig + (m - s);
2179                 strend = s + (strend - m);
2180             }
2181             m = rx->startp[0] + orig;
2182             if (doutf8 && !SvUTF8(dstr))
2183                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2184             else
2185                 sv_catpvn(dstr, s, m-s);
2186             s = rx->endp[0] + orig;
2187             if (clen)
2188                 sv_catpvn(dstr, c, clen);
2189             if (once)
2190                 break;
2191         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2192                              TARG, NULL, r_flags));
2193         if (doutf8 && !DO_UTF8(TARG))
2194             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2195         else
2196             sv_catpvn(dstr, s, strend - s);
2197
2198 #ifdef PERL_COPY_ON_WRITE
2199         /* The match may make the string COW. If so, brilliant, because that's
2200            just saved us one malloc, copy and free - the regexp has donated
2201            the old buffer, and we malloc an entirely new one, rather than the
2202            regexp malloc()ing a buffer and copying our original, only for
2203            us to throw it away here during the substitution.  */
2204         if (SvIsCOW(TARG)) {
2205             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2206         } else
2207 #endif
2208         {
2209             (void)SvOOK_off(TARG);
2210             if (SvLEN(TARG))
2211                 Safefree(SvPVX(TARG));
2212         }
2213         SvPVX(TARG) = SvPVX(dstr);
2214         SvCUR_set(TARG, SvCUR(dstr));
2215         SvLEN_set(TARG, SvLEN(dstr));
2216         doutf8 |= DO_UTF8(dstr);
2217         SvPVX(dstr) = 0;
2218         sv_free(dstr);
2219
2220         TAINT_IF(rxtainted & 1);
2221         SPAGAIN;
2222         PUSHs(sv_2mortal(newSViv((I32)iters)));
2223
2224         (void)SvPOK_only(TARG);
2225         if (doutf8)
2226             SvUTF8_on(TARG);
2227         TAINT_IF(rxtainted);
2228         SvSETMAGIC(TARG);
2229         SvTAINT(TARG);
2230         LEAVE_SCOPE(oldsave);
2231         RETURN;
2232     }
2233     goto ret_no;
2234
2235 nope:
2236 ret_no:
2237     SPAGAIN;
2238     PUSHs(&PL_sv_no);
2239     LEAVE_SCOPE(oldsave);
2240     RETURN;
2241 }
2242
2243 PP(pp_grepwhile)
2244 {
2245     dSP;
2246
2247     if (SvTRUEx(POPs))
2248         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2249     ++*PL_markstack_ptr;
2250     LEAVE;                                      /* exit inner scope */
2251
2252     /* All done yet? */
2253     if (PL_stack_base + *PL_markstack_ptr > SP) {
2254         I32 items;
2255         I32 gimme = GIMME_V;
2256
2257         LEAVE;                                  /* exit outer scope */
2258         (void)POPMARK;                          /* pop src */
2259         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2260         (void)POPMARK;                          /* pop dst */
2261         SP = PL_stack_base + POPMARK;           /* pop original mark */
2262         if (gimme == G_SCALAR) {
2263             dTARGET;
2264             XPUSHi(items);
2265         }
2266         else if (gimme == G_ARRAY)
2267             SP += items;
2268         RETURN;
2269     }
2270     else {
2271         SV *src;
2272
2273         ENTER;                                  /* enter inner scope */
2274         SAVEVPTR(PL_curpm);
2275
2276         src = PL_stack_base[*PL_markstack_ptr];
2277         SvTEMP_off(src);
2278         DEFSV = src;
2279
2280         RETURNOP(cLOGOP->op_other);
2281     }
2282 }
2283
2284 PP(pp_leavesub)
2285 {
2286     dSP;
2287     SV **mark;
2288     SV **newsp;
2289     PMOP *newpm;
2290     I32 gimme;
2291     register PERL_CONTEXT *cx;
2292     SV *sv;
2293
2294     POPBLOCK(cx,newpm);
2295
2296     TAINT_NOT;
2297     if (gimme == G_SCALAR) {
2298         MARK = newsp + 1;
2299         if (MARK <= SP) {
2300             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2301                 if (SvTEMP(TOPs)) {
2302                     *MARK = SvREFCNT_inc(TOPs);
2303                     FREETMPS;
2304                     sv_2mortal(*MARK);
2305                 }
2306                 else {
2307                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2308                     FREETMPS;
2309                     *MARK = sv_mortalcopy(sv);
2310                     SvREFCNT_dec(sv);
2311                 }
2312             }
2313             else
2314                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2315         }
2316         else {
2317             MEXTEND(MARK, 0);
2318             *MARK = &PL_sv_undef;
2319         }
2320         SP = MARK;
2321     }
2322     else if (gimme == G_ARRAY) {
2323         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2324             if (!SvTEMP(*MARK)) {
2325                 *MARK = sv_mortalcopy(*MARK);
2326                 TAINT_NOT;      /* Each item is independent */
2327             }
2328         }
2329     }
2330     PUTBACK;
2331
2332     LEAVE;
2333     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2334     PL_curpm = newpm;   /* ... and pop $1 et al */
2335
2336     LEAVESUB(sv);
2337     return pop_return();
2338 }
2339
2340 /* This duplicates the above code because the above code must not
2341  * get any slower by more conditions */
2342 PP(pp_leavesublv)
2343 {
2344     dSP;
2345     SV **mark;
2346     SV **newsp;
2347     PMOP *newpm;
2348     I32 gimme;
2349     register PERL_CONTEXT *cx;
2350     SV *sv;
2351
2352     POPBLOCK(cx,newpm);
2353
2354     TAINT_NOT;
2355
2356     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2357         /* We are an argument to a function or grep().
2358          * This kind of lvalueness was legal before lvalue
2359          * subroutines too, so be backward compatible:
2360          * cannot report errors.  */
2361
2362         /* Scalar context *is* possible, on the LHS of -> only,
2363          * as in f()->meth().  But this is not an lvalue. */
2364         if (gimme == G_SCALAR)
2365             goto temporise;
2366         if (gimme == G_ARRAY) {
2367             if (!CvLVALUE(cx->blk_sub.cv))
2368                 goto temporise_array;
2369             EXTEND_MORTAL(SP - newsp);
2370             for (mark = newsp + 1; mark <= SP; mark++) {
2371                 if (SvTEMP(*mark))
2372                     /* empty */ ;
2373                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2374                     *mark = sv_mortalcopy(*mark);
2375                 else {
2376                     /* Can be a localized value subject to deletion. */
2377                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2378                     (void)SvREFCNT_inc(*mark);
2379                 }
2380             }
2381         }
2382     }
2383     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2384         /* Here we go for robustness, not for speed, so we change all
2385          * the refcounts so the caller gets a live guy. Cannot set
2386          * TEMP, so sv_2mortal is out of question. */
2387         if (!CvLVALUE(cx->blk_sub.cv)) {
2388             LEAVE;
2389             POPSUB(cx,sv);
2390             PL_curpm = newpm;
2391             LEAVESUB(sv);
2392             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2393         }
2394         if (gimme == G_SCALAR) {
2395             MARK = newsp + 1;
2396             EXTEND_MORTAL(1);
2397             if (MARK == SP) {
2398                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2399                     LEAVE;
2400                     POPSUB(cx,sv);
2401                     PL_curpm = newpm;
2402                     LEAVESUB(sv);
2403                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2404                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2405                         : "a readonly value" : "a temporary");
2406                 }
2407                 else {                  /* Can be a localized value
2408                                          * subject to deletion. */
2409                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2410                     (void)SvREFCNT_inc(*mark);
2411                 }
2412             }
2413             else {                      /* Should not happen? */
2414                 LEAVE;
2415                 POPSUB(cx,sv);
2416                 PL_curpm = newpm;
2417                 LEAVESUB(sv);
2418                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2419                     (MARK > SP ? "Empty array" : "Array"));
2420             }
2421             SP = MARK;
2422         }
2423         else if (gimme == G_ARRAY) {
2424             EXTEND_MORTAL(SP - newsp);
2425             for (mark = newsp + 1; mark <= SP; mark++) {
2426                 if (*mark != &PL_sv_undef
2427                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2428                     /* Might be flattened array after $#array =  */
2429                     PUTBACK;
2430                     LEAVE;
2431                     POPSUB(cx,sv);
2432                     PL_curpm = newpm;
2433                     LEAVESUB(sv);
2434                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2435                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2436                 }
2437                 else {
2438                     /* Can be a localized value subject to deletion. */
2439                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2440                     (void)SvREFCNT_inc(*mark);
2441                 }
2442             }
2443         }
2444     }
2445     else {
2446         if (gimme == G_SCALAR) {
2447           temporise:
2448             MARK = newsp + 1;
2449             if (MARK <= SP) {
2450                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2451                     if (SvTEMP(TOPs)) {
2452                         *MARK = SvREFCNT_inc(TOPs);
2453                         FREETMPS;
2454                         sv_2mortal(*MARK);
2455                     }
2456                     else {
2457                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2458                         FREETMPS;
2459                         *MARK = sv_mortalcopy(sv);
2460                         SvREFCNT_dec(sv);
2461                     }
2462                 }
2463                 else
2464                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2465             }
2466             else {
2467                 MEXTEND(MARK, 0);
2468                 *MARK = &PL_sv_undef;
2469             }
2470             SP = MARK;
2471         }
2472         else if (gimme == G_ARRAY) {
2473           temporise_array:
2474             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2475                 if (!SvTEMP(*MARK)) {
2476                     *MARK = sv_mortalcopy(*MARK);
2477                     TAINT_NOT;  /* Each item is independent */
2478                 }
2479             }
2480         }
2481     }
2482     PUTBACK;
2483
2484     LEAVE;
2485     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2486     PL_curpm = newpm;   /* ... and pop $1 et al */
2487
2488     LEAVESUB(sv);
2489     return pop_return();
2490 }
2491
2492
2493 STATIC CV *
2494 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2495 {
2496     SV *dbsv = GvSV(PL_DBsub);
2497
2498     if (!PERLDB_SUB_NN) {
2499         GV *gv = CvGV(cv);
2500
2501         save_item(dbsv);
2502         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2503              || strEQ(GvNAME(gv), "END")
2504              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2505                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2506                     && (gv = (GV*)*svp) ))) {
2507             /* Use GV from the stack as a fallback. */
2508             /* GV is potentially non-unique, or contain different CV. */
2509             SV *tmp = newRV((SV*)cv);
2510             sv_setsv(dbsv, tmp);
2511             SvREFCNT_dec(tmp);
2512         }
2513         else {
2514             gv_efullname3(dbsv, gv, Nullch);
2515         }
2516     }
2517     else {
2518         (void)SvUPGRADE(dbsv, SVt_PVIV);
2519         (void)SvIOK_on(dbsv);
2520         SAVEIV(SvIVX(dbsv));
2521         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2522     }
2523
2524     if (CvXSUB(cv))
2525         PL_curcopdb = PL_curcop;
2526     cv = GvCV(PL_DBsub);
2527     return cv;
2528 }
2529
2530 PP(pp_entersub)
2531 {
2532     dSP; dPOPss;
2533     GV *gv;
2534     HV *stash;
2535     register CV *cv;
2536     register PERL_CONTEXT *cx;
2537     I32 gimme;
2538     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2539
2540     if (!sv)
2541         DIE(aTHX_ "Not a CODE reference");
2542     switch (SvTYPE(sv)) {
2543         /* This is overwhelming the most common case:  */
2544     case SVt_PVGV:
2545         if (!(cv = GvCVu((GV*)sv)))
2546             cv = sv_2cv(sv, &stash, &gv, FALSE);
2547         if (!cv) {
2548             ENTER;
2549             SAVETMPS;
2550             goto try_autoload;
2551         }
2552         break;
2553     default:
2554         if (!SvROK(sv)) {
2555             char *sym;
2556             STRLEN n_a;
2557
2558             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2559                 if (hasargs)
2560                     SP = PL_stack_base + POPMARK;
2561                 RETURN;
2562             }
2563             if (SvGMAGICAL(sv)) {
2564                 mg_get(sv);
2565                 if (SvROK(sv))
2566                     goto got_rv;
2567                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2568             }
2569             else
2570                 sym = SvPV(sv, n_a);
2571             if (!sym)
2572                 DIE(aTHX_ PL_no_usym, "a subroutine");
2573             if (PL_op->op_private & HINT_STRICT_REFS)
2574                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2575             cv = get_cv(sym, TRUE);
2576             break;
2577         }
2578   got_rv:
2579         {
2580             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2581             tryAMAGICunDEREF(to_cv);
2582         }
2583         cv = (CV*)SvRV(sv);
2584         if (SvTYPE(cv) == SVt_PVCV)
2585             break;
2586         /* FALL THROUGH */
2587     case SVt_PVHV:
2588     case SVt_PVAV:
2589         DIE(aTHX_ "Not a CODE reference");
2590         /* This is the second most common case:  */
2591     case SVt_PVCV:
2592         cv = (CV*)sv;
2593         break;
2594     }
2595
2596     ENTER;
2597     SAVETMPS;
2598
2599   retry:
2600     if (!CvROOT(cv) && !CvXSUB(cv)) {
2601         goto fooey;
2602     }
2603
2604     gimme = GIMME_V;
2605     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2606         if (CvASSERTION(cv) && PL_DBassertion)
2607             sv_setiv(PL_DBassertion, 1);
2608
2609         cv = get_db_sub(&sv, cv);
2610         if (!cv)
2611             DIE(aTHX_ "No DBsub routine");
2612     }
2613
2614     if (!(CvXSUB(cv))) {
2615         /* This path taken at least 75% of the time   */
2616         dMARK;
2617         register I32 items = SP - MARK;
2618         AV* padlist = CvPADLIST(cv);
2619         push_return(PL_op->op_next);
2620         PUSHBLOCK(cx, CXt_SUB, MARK);
2621         PUSHSUB(cx);
2622         CvDEPTH(cv)++;
2623         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2624          * that eval'' ops within this sub know the correct lexical space.
2625          * Owing the speed considerations, we choose instead to search for
2626          * the cv using find_runcv() when calling doeval().
2627          */
2628         if (CvDEPTH(cv) < 2)
2629             (void)SvREFCNT_inc(cv);
2630         else {
2631             PERL_STACK_OVERFLOW_CHECK();
2632             pad_push(padlist, CvDEPTH(cv), 1);
2633         }
2634         PAD_SET_CUR(padlist, CvDEPTH(cv));
2635         if (hasargs)
2636         {
2637             AV* av;
2638             SV** ary;
2639
2640 #if 0
2641             DEBUG_S(PerlIO_printf(Perl_debug_log,
2642                                   "%p entersub preparing @_\n", thr));
2643 #endif
2644             av = (AV*)PAD_SVl(0);
2645             if (AvREAL(av)) {
2646                 /* @_ is normally not REAL--this should only ever
2647                  * happen when DB::sub() calls things that modify @_ */
2648                 av_clear(av);
2649                 AvREAL_off(av);
2650                 AvREIFY_on(av);
2651             }
2652             cx->blk_sub.savearray = GvAV(PL_defgv);
2653             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2654             CX_CURPAD_SAVE(cx->blk_sub);
2655             cx->blk_sub.argarray = av;
2656             ++MARK;
2657
2658             if (items > AvMAX(av) + 1) {
2659                 ary = AvALLOC(av);
2660                 if (AvARRAY(av) != ary) {
2661                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2662                     SvPVX(av) = (char*)ary;
2663                 }
2664                 if (items > AvMAX(av) + 1) {
2665                     AvMAX(av) = items - 1;
2666                     Renew(ary,items,SV*);
2667                     AvALLOC(av) = ary;
2668                     SvPVX(av) = (char*)ary;
2669                 }
2670             }
2671             Copy(MARK,AvARRAY(av),items,SV*);
2672             AvFILLp(av) = items - 1;
2673
2674             while (items--) {
2675                 if (*MARK)
2676                     SvTEMP_off(*MARK);
2677                 MARK++;
2678             }
2679         }
2680         /* warning must come *after* we fully set up the context
2681          * stuff so that __WARN__ handlers can safely dounwind()
2682          * if they want to
2683          */
2684         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2685             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2686             sub_crush_depth(cv);
2687 #if 0
2688         DEBUG_S(PerlIO_printf(Perl_debug_log,
2689                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2690 #endif
2691         RETURNOP(CvSTART(cv));
2692     }
2693     else {
2694 #ifdef PERL_XSUB_OLDSTYLE
2695         if (CvOLDSTYLE(cv)) {
2696             I32 (*fp3)(int,int,int);
2697             dMARK;
2698             register I32 items = SP - MARK;
2699                                         /* We dont worry to copy from @_. */
2700             while (SP > mark) {
2701                 SP[1] = SP[0];
2702                 SP--;
2703             }
2704             PL_stack_sp = mark + 1;
2705             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2706             items = (*fp3)(CvXSUBANY(cv).any_i32,
2707                            MARK - PL_stack_base + 1,
2708                            items);
2709             PL_stack_sp = PL_stack_base + items;
2710         }
2711         else
2712 #endif /* PERL_XSUB_OLDSTYLE */
2713         {
2714             I32 markix = TOPMARK;
2715
2716             PUTBACK;
2717
2718             if (!hasargs) {
2719                 /* Need to copy @_ to stack. Alternative may be to
2720                  * switch stack to @_, and copy return values
2721                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2722                 AV* av;
2723                 I32 items;
2724                 av = GvAV(PL_defgv);
2725                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2726
2727                 if (items) {
2728                     /* Mark is at the end of the stack. */
2729                     EXTEND(SP, items);
2730                     Copy(AvARRAY(av), SP + 1, items, SV*);
2731                     SP += items;
2732                     PUTBACK ;
2733                 }
2734             }
2735             /* We assume first XSUB in &DB::sub is the called one. */
2736             if (PL_curcopdb) {
2737                 SAVEVPTR(PL_curcop);
2738                 PL_curcop = PL_curcopdb;
2739                 PL_curcopdb = NULL;
2740             }
2741             /* Do we need to open block here? XXXX */
2742             (void)(*CvXSUB(cv))(aTHX_ cv);
2743
2744             /* Enforce some sanity in scalar context. */
2745             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2746                 if (markix > PL_stack_sp - PL_stack_base)
2747                     *(PL_stack_base + markix) = &PL_sv_undef;
2748                 else
2749                     *(PL_stack_base + markix) = *PL_stack_sp;
2750                 PL_stack_sp = PL_stack_base + markix;
2751             }
2752         }
2753         LEAVE;
2754         return NORMAL;
2755     }
2756
2757     assert (0); /* Cannot get here.  */
2758     /* This is deliberately moved here as spaghetti code to keep it out of the
2759        hot path.  */
2760     {
2761         GV* autogv;
2762         SV* sub_name;
2763
2764       fooey:
2765         /* anonymous or undef'd function leaves us no recourse */
2766         if (CvANON(cv) || !(gv = CvGV(cv)))
2767             DIE(aTHX_ "Undefined subroutine called");
2768
2769         /* autoloaded stub? */
2770         if (cv != GvCV(gv)) {
2771             cv = GvCV(gv);
2772         }
2773         /* should call AUTOLOAD now? */
2774         else {
2775 try_autoload:
2776             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2777                                    FALSE)))
2778             {
2779                 cv = GvCV(autogv);
2780             }
2781             /* sorry */
2782             else {
2783                 sub_name = sv_newmortal();
2784                 gv_efullname3(sub_name, gv, Nullch);
2785                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2786             }
2787         }
2788         if (!cv)
2789             DIE(aTHX_ "Not a CODE reference");
2790         goto retry;
2791     }
2792 }
2793
2794 void
2795 Perl_sub_crush_depth(pTHX_ CV *cv)
2796 {
2797     if (CvANON(cv))
2798         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2799     else {
2800         SV* tmpstr = sv_newmortal();
2801         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2802         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2803                 tmpstr);
2804     }
2805 }
2806
2807 PP(pp_aelem)
2808 {
2809     dSP;
2810     SV** svp;
2811     SV* elemsv = POPs;
2812     IV elem = SvIV(elemsv);
2813     AV* av = (AV*)POPs;
2814     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2815     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2816     SV *sv;
2817
2818     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2819         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2820     if (elem > 0)
2821         elem -= PL_curcop->cop_arybase;
2822     if (SvTYPE(av) != SVt_PVAV)
2823         RETPUSHUNDEF;
2824     svp = av_fetch(av, elem, lval && !defer);
2825     if (lval) {
2826         if (!svp || *svp == &PL_sv_undef) {
2827             SV* lv;
2828             if (!defer)
2829                 DIE(aTHX_ PL_no_aelem, elem);
2830             lv = sv_newmortal();
2831             sv_upgrade(lv, SVt_PVLV);
2832             LvTYPE(lv) = 'y';
2833             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2834             LvTARG(lv) = SvREFCNT_inc(av);
2835             LvTARGOFF(lv) = elem;
2836             LvTARGLEN(lv) = 1;
2837             PUSHs(lv);
2838             RETURN;
2839         }
2840         if (PL_op->op_private & OPpLVAL_INTRO)
2841             save_aelem(av, elem, svp);
2842         else if (PL_op->op_private & OPpDEREF)
2843             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2844     }
2845     sv = (svp ? *svp : &PL_sv_undef);
2846     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2847         sv = sv_mortalcopy(sv);
2848     PUSHs(sv);
2849     RETURN;
2850 }
2851
2852 void
2853 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2854 {
2855     if (SvGMAGICAL(sv))
2856         mg_get(sv);
2857     if (!SvOK(sv)) {
2858         if (SvREADONLY(sv))
2859             Perl_croak(aTHX_ PL_no_modify);
2860         if (SvTYPE(sv) < SVt_RV)
2861             sv_upgrade(sv, SVt_RV);
2862         else if (SvTYPE(sv) >= SVt_PV) {
2863             (void)SvOOK_off(sv);
2864             Safefree(SvPVX(sv));
2865             SvLEN(sv) = SvCUR(sv) = 0;
2866         }
2867         switch (to_what) {
2868         case OPpDEREF_SV:
2869             SvRV(sv) = NEWSV(355,0);
2870             break;
2871         case OPpDEREF_AV:
2872             SvRV(sv) = (SV*)newAV();
2873             break;
2874         case OPpDEREF_HV:
2875             SvRV(sv) = (SV*)newHV();
2876             break;
2877         }
2878         SvROK_on(sv);
2879         SvSETMAGIC(sv);
2880     }
2881 }
2882
2883 PP(pp_method)
2884 {
2885     dSP;
2886     SV* sv = TOPs;
2887
2888     if (SvROK(sv)) {
2889         SV* rsv = SvRV(sv);
2890         if (SvTYPE(rsv) == SVt_PVCV) {
2891             SETs(rsv);
2892             RETURN;
2893         }
2894     }
2895
2896     SETs(method_common(sv, Null(U32*)));
2897     RETURN;
2898 }
2899
2900 PP(pp_method_named)
2901 {
2902     dSP;
2903     SV* sv = cSVOP_sv;
2904     U32 hash = SvUVX(sv);
2905
2906     XPUSHs(method_common(sv, &hash));
2907     RETURN;
2908 }
2909
2910 STATIC SV *
2911 S_method_common(pTHX_ SV* meth, U32* hashp)
2912 {
2913     SV* sv;
2914     SV* ob;
2915     GV* gv;
2916     HV* stash;
2917     char* name;
2918     STRLEN namelen;
2919     char* packname = 0;
2920     SV *packsv = Nullsv;
2921     STRLEN packlen;
2922
2923     name = SvPV(meth, namelen);
2924     sv = *(PL_stack_base + TOPMARK + 1);
2925
2926     if (!sv)
2927         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2928
2929     if (SvGMAGICAL(sv))
2930         mg_get(sv);
2931     if (SvROK(sv))
2932         ob = (SV*)SvRV(sv);
2933     else {
2934         GV* iogv;
2935
2936         /* this isn't a reference */
2937         packname = Nullch;
2938
2939         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2940           HE* he;
2941           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2942           if (he) {
2943             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2944             goto fetch;
2945           }
2946         }
2947
2948         if (!SvOK(sv) ||
2949             !(packname) ||
2950             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2951             !(ob=(SV*)GvIO(iogv)))
2952         {
2953             /* this isn't the name of a filehandle either */
2954             if (!packname ||
2955                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2956                     ? !isIDFIRST_utf8((U8*)packname)
2957                     : !isIDFIRST(*packname)
2958                 ))
2959             {
2960                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2961                            SvOK(sv) ? "without a package or object reference"
2962                                     : "on an undefined value");
2963             }
2964             /* assume it's a package name */
2965             stash = gv_stashpvn(packname, packlen, FALSE);
2966             if (!stash)
2967                 packsv = sv;
2968             else {
2969                 SV* ref = newSViv(PTR2IV(stash));
2970                 hv_store(PL_stashcache, packname, packlen, ref, 0);
2971             }
2972             goto fetch;
2973         }
2974         /* it _is_ a filehandle name -- replace with a reference */
2975         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2976     }
2977
2978     /* if we got here, ob should be a reference or a glob */
2979     if (!ob || !(SvOBJECT(ob)
2980                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2981                      && SvOBJECT(ob))))
2982     {
2983         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2984                    name);
2985     }
2986
2987     stash = SvSTASH(ob);
2988
2989   fetch:
2990     /* NOTE: stash may be null, hope hv_fetch_ent and
2991        gv_fetchmethod can cope (it seems they can) */
2992
2993     /* shortcut for simple names */
2994     if (hashp) {
2995         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2996         if (he) {
2997             gv = (GV*)HeVAL(he);
2998             if (isGV(gv) && GvCV(gv) &&
2999                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3000                 return (SV*)GvCV(gv);
3001         }
3002     }
3003
3004     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3005
3006     if (!gv) {
3007         /* This code tries to figure out just what went wrong with
3008            gv_fetchmethod.  It therefore needs to duplicate a lot of
3009            the internals of that function.  We can't move it inside
3010            Perl_gv_fetchmethod_autoload(), however, since that would
3011            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3012            don't want that.
3013         */
3014         char* leaf = name;
3015         char* sep = Nullch;
3016         char* p;
3017
3018         for (p = name; *p; p++) {
3019             if (*p == '\'')
3020                 sep = p, leaf = p + 1;
3021             else if (*p == ':' && *(p + 1) == ':')
3022                 sep = p, leaf = p + 2;
3023         }
3024         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3025             /* the method name is unqualified or starts with SUPER:: */
3026             packname = sep ? CopSTASHPV(PL_curcop) :
3027                 stash ? HvNAME(stash) : packname;
3028             packlen = strlen(packname);
3029         }
3030         else {
3031             /* the method name is qualified */
3032             packname = name;
3033             packlen = sep - name;
3034         }
3035
3036         /* we're relying on gv_fetchmethod not autovivifying the stash */
3037         if (gv_stashpvn(packname, packlen, FALSE)) {
3038             Perl_croak(aTHX_
3039                        "Can't locate object method \"%s\" via package \"%.*s\"",
3040                        leaf, (int)packlen, packname);
3041         }
3042         else {
3043             Perl_croak(aTHX_
3044                        "Can't locate object method \"%s\" via package \"%.*s\""
3045                        " (perhaps you forgot to load \"%.*s\"?)",
3046                        leaf, (int)packlen, packname, (int)packlen, packname);
3047         }
3048     }
3049     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3050 }