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