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