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