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