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