pp_hot.c

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