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