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