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