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