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