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 ** const 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 * const 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 ** const svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1892             sv = svp ? *svp : Nullsv;
1893         }
1894         else {
1895             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1896         }
1897     }
1898     else {
1899         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1900                                     AvFILL(av)))
1901             RETPUSHNO;
1902
1903         if (SvMAGICAL(av) || AvREIFY(av)) {
1904             SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1905             sv = svp ? *svp : Nullsv;
1906         }
1907         else {
1908             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1909         }
1910     }
1911
1912     if (sv && SvIS_FREED(sv)) {
1913         *itersvp = Nullsv;
1914         Perl_croak(aTHX_ "Use of freed value in iteration");
1915     }
1916
1917     if (sv)
1918         SvTEMP_off(sv);
1919     else
1920         sv = &PL_sv_undef;
1921     if (av != PL_curstack && sv == &PL_sv_undef) {
1922         SV *lv = cx->blk_loop.iterlval;
1923         if (lv && SvREFCNT(lv) > 1) {
1924             SvREFCNT_dec(lv);
1925             lv = Nullsv;
1926         }
1927         if (lv)
1928             SvREFCNT_dec(LvTARG(lv));
1929         else {
1930             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1931             sv_upgrade(lv, SVt_PVLV);
1932             LvTYPE(lv) = 'y';
1933             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1934         }
1935         LvTARG(lv) = SvREFCNT_inc(av);
1936         LvTARGOFF(lv) = cx->blk_loop.iterix;
1937         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1938         sv = (SV*)lv;
1939     }
1940
1941     oldsv = *itersvp;
1942     *itersvp = SvREFCNT_inc(sv);
1943     SvREFCNT_dec(oldsv);
1944
1945     RETPUSHYES;
1946 }
1947
1948 PP(pp_subst)
1949 {
1950     dSP; dTARG;
1951     register PMOP *pm = cPMOP;
1952     PMOP *rpm = pm;
1953     register SV *dstr;
1954     register char *s;
1955     char *strend;
1956     register char *m;
1957     const char *c;
1958     register char *d;
1959     STRLEN clen;
1960     I32 iters = 0;
1961     I32 maxiters;
1962     register I32 i;
1963     bool once;
1964     bool rxtainted;
1965     char *orig;
1966     I32 r_flags;
1967     register REGEXP *rx = PM_GETRE(pm);
1968     STRLEN len;
1969     int force_on_match = 0;
1970     const I32 oldsave = PL_savestack_ix;
1971     STRLEN slen;
1972     bool doutf8 = FALSE;
1973 #ifdef PERL_OLD_COPY_ON_WRITE
1974     bool is_cow;
1975 #endif
1976     SV *nsv = Nullsv;
1977
1978     /* known replacement string? */
1979     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1980     if (PL_op->op_flags & OPf_STACKED)
1981         TARG = POPs;
1982     else if (PL_op->op_private & OPpTARGET_MY)
1983         GETTARGET;
1984     else {
1985         TARG = DEFSV;
1986         EXTEND(SP,1);
1987     }
1988
1989 #ifdef PERL_OLD_COPY_ON_WRITE
1990     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1991        because they make integers such as 256 "false".  */
1992     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1993 #else
1994     if (SvIsCOW(TARG))
1995         sv_force_normal_flags(TARG,0);
1996 #endif
1997     if (
1998 #ifdef PERL_OLD_COPY_ON_WRITE
1999         !is_cow &&
2000 #endif
2001         (SvREADONLY(TARG)
2002         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2003              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2004         DIE(aTHX_ PL_no_modify);
2005     PUTBACK;
2006
2007     s = SvPV_mutable(TARG, len);
2008     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2009         force_on_match = 1;
2010     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2011                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2012     if (PL_tainted)
2013         rxtainted |= 2;
2014     TAINT_NOT;
2015
2016     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2017
2018   force_it:
2019     if (!pm || !s)
2020         DIE(aTHX_ "panic: pp_subst");
2021
2022     strend = s + len;
2023     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2024     maxiters = 2 * slen + 10;   /* We can match twice at each
2025                                    position, once with zero-length,
2026                                    second time with non-zero. */
2027
2028     if (!rx->prelen && PL_curpm) {
2029         pm = PL_curpm;
2030         rx = PM_GETRE(pm);
2031     }
2032     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2033                ? REXEC_COPY_STR : 0;
2034     if (SvSCREAM(TARG))
2035         r_flags |= REXEC_SCREAM;
2036
2037     orig = m = s;
2038     if (rx->reganch & RE_USE_INTUIT) {
2039         PL_bostr = orig;
2040         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2041
2042         if (!s)
2043             goto nope;
2044         /* How to do it in subst? */
2045 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2046              && !PL_sawampersand
2047              && ((rx->reganch & ROPT_NOSCAN)
2048                  || !((rx->reganch & RE_INTUIT_TAIL)
2049                       && (r_flags & REXEC_SCREAM))))
2050             goto yup;
2051 */
2052     }
2053
2054     /* only replace once? */
2055     once = !(rpm->op_pmflags & PMf_GLOBAL);
2056
2057     /* known replacement string? */
2058     if (dstr) {
2059         /* replacement needing upgrading? */
2060         if (DO_UTF8(TARG) && !doutf8) {
2061              nsv = sv_newmortal();
2062              SvSetSV(nsv, dstr);
2063              if (PL_encoding)
2064                   sv_recode_to_utf8(nsv, PL_encoding);
2065              else
2066                   sv_utf8_upgrade(nsv);
2067              c = SvPV_const(nsv, clen);
2068              doutf8 = TRUE;
2069         }
2070         else {
2071             c = SvPV_const(dstr, clen);
2072             doutf8 = DO_UTF8(dstr);
2073         }
2074     }
2075     else {
2076         c = Nullch;
2077         doutf8 = FALSE;
2078     }
2079
2080     /* can do inplace substitution? */
2081     if (c
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2083         && !is_cow
2084 #endif
2085         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2086         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2087         && (!doutf8 || SvUTF8(TARG))) {
2088         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2089                          r_flags | REXEC_CHECKED))
2090         {
2091             SPAGAIN;
2092             PUSHs(&PL_sv_no);
2093             LEAVE_SCOPE(oldsave);
2094             RETURN;
2095         }
2096 #ifdef PERL_OLD_COPY_ON_WRITE
2097         if (SvIsCOW(TARG)) {
2098             assert (!force_on_match);
2099             goto have_a_cow;
2100         }
2101 #endif
2102         if (force_on_match) {
2103             force_on_match = 0;
2104             s = SvPV_force(TARG, len);
2105             goto force_it;
2106         }
2107         d = s;
2108         PL_curpm = pm;
2109         SvSCREAM_off(TARG);     /* disable possible screamer */
2110         if (once) {
2111             rxtainted |= RX_MATCH_TAINTED(rx);
2112             m = orig + rx->startp[0];
2113             d = orig + rx->endp[0];
2114             s = orig;
2115             if (m - s > strend - d) {  /* faster to shorten from end */
2116                 if (clen) {
2117                     Copy(c, m, clen, char);
2118                     m += clen;
2119                 }
2120                 i = strend - d;
2121                 if (i > 0) {
2122                     Move(d, m, i, char);
2123                     m += i;
2124                 }
2125                 *m = '\0';
2126                 SvCUR_set(TARG, m - s);
2127             }
2128             else if ((i = m - s)) {     /* faster from front */
2129                 d -= clen;
2130                 m = d;
2131                 sv_chop(TARG, d-i);
2132                 s += i;
2133                 while (i--)
2134                     *--d = *--s;
2135                 if (clen)
2136                     Copy(c, m, clen, char);
2137             }
2138             else if (clen) {
2139                 d -= clen;
2140                 sv_chop(TARG, d);
2141                 Copy(c, d, clen, char);
2142             }
2143             else {
2144                 sv_chop(TARG, d);
2145             }
2146             TAINT_IF(rxtainted & 1);
2147             SPAGAIN;
2148             PUSHs(&PL_sv_yes);
2149         }
2150         else {
2151             do {
2152                 if (iters++ > maxiters)
2153                     DIE(aTHX_ "Substitution loop");
2154                 rxtainted |= RX_MATCH_TAINTED(rx);
2155                 m = rx->startp[0] + orig;
2156                 if ((i = m - s)) {
2157                     if (s != d)
2158                         Move(s, d, i, char);
2159                     d += i;
2160                 }
2161                 if (clen) {
2162                     Copy(c, d, clen, char);
2163                     d += clen;
2164                 }
2165                 s = rx->endp[0] + orig;
2166             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2167                                  TARG, NULL,
2168                                  /* don't match same null twice */
2169                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2170             if (s != d) {
2171                 i = strend - s;
2172                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2173                 Move(s, d, i+1, char);          /* include the NUL */
2174             }
2175             TAINT_IF(rxtainted & 1);
2176             SPAGAIN;
2177             PUSHs(sv_2mortal(newSViv((I32)iters)));
2178         }
2179         (void)SvPOK_only_UTF8(TARG);
2180         TAINT_IF(rxtainted);
2181         if (SvSMAGICAL(TARG)) {
2182             PUTBACK;
2183             mg_set(TARG);
2184             SPAGAIN;
2185         }
2186         SvTAINT(TARG);
2187         if (doutf8)
2188             SvUTF8_on(TARG);
2189         LEAVE_SCOPE(oldsave);
2190         RETURN;
2191     }
2192
2193     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2194                     r_flags | REXEC_CHECKED))
2195     {
2196         if (force_on_match) {
2197             force_on_match = 0;
2198             s = SvPV_force(TARG, len);
2199             goto force_it;
2200         }
2201 #ifdef PERL_OLD_COPY_ON_WRITE
2202       have_a_cow:
2203 #endif
2204         rxtainted |= RX_MATCH_TAINTED(rx);
2205         dstr = newSVpvn(m, s-m);
2206         if (DO_UTF8(TARG))
2207             SvUTF8_on(dstr);
2208         PL_curpm = pm;
2209         if (!c) {
2210             register PERL_CONTEXT *cx;
2211             SPAGAIN;
2212             (void)ReREFCNT_inc(rx);
2213             PUSHSUBST(cx);
2214             RETURNOP(cPMOP->op_pmreplroot);
2215         }
2216         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2217         do {
2218             if (iters++ > maxiters)
2219                 DIE(aTHX_ "Substitution loop");
2220             rxtainted |= RX_MATCH_TAINTED(rx);
2221             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2222                 m = s;
2223                 s = orig;
2224                 orig = rx->subbeg;
2225                 s = orig + (m - s);
2226                 strend = s + (strend - m);
2227             }
2228             m = rx->startp[0] + orig;
2229             if (doutf8 && !SvUTF8(dstr))
2230                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2231             else
2232                 sv_catpvn(dstr, s, m-s);
2233             s = rx->endp[0] + orig;
2234             if (clen)
2235                 sv_catpvn(dstr, c, clen);
2236             if (once)
2237                 break;
2238         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2239                              TARG, NULL, r_flags));
2240         if (doutf8 && !DO_UTF8(TARG))
2241             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2242         else
2243             sv_catpvn(dstr, s, strend - s);
2244
2245 #ifdef PERL_OLD_COPY_ON_WRITE
2246         /* The match may make the string COW. If so, brilliant, because that's
2247            just saved us one malloc, copy and free - the regexp has donated
2248            the old buffer, and we malloc an entirely new one, rather than the
2249            regexp malloc()ing a buffer and copying our original, only for
2250            us to throw it away here during the substitution.  */
2251         if (SvIsCOW(TARG)) {
2252             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2253         } else
2254 #endif
2255         {
2256             SvPV_free(TARG);
2257         }
2258         SvPV_set(TARG, SvPVX(dstr));
2259         SvCUR_set(TARG, SvCUR(dstr));
2260         SvLEN_set(TARG, SvLEN(dstr));
2261         doutf8 |= DO_UTF8(dstr);
2262         SvPV_set(dstr, (char*)0);
2263         sv_free(dstr);
2264
2265         TAINT_IF(rxtainted & 1);
2266         SPAGAIN;
2267         PUSHs(sv_2mortal(newSViv((I32)iters)));
2268
2269         (void)SvPOK_only(TARG);
2270         if (doutf8)
2271             SvUTF8_on(TARG);
2272         TAINT_IF(rxtainted);
2273         SvSETMAGIC(TARG);
2274         SvTAINT(TARG);
2275         LEAVE_SCOPE(oldsave);
2276         RETURN;
2277     }
2278     goto ret_no;
2279
2280 nope:
2281 ret_no:
2282     SPAGAIN;
2283     PUSHs(&PL_sv_no);
2284     LEAVE_SCOPE(oldsave);
2285     RETURN;
2286 }
2287
2288 PP(pp_grepwhile)
2289 {
2290     dVAR; dSP;
2291
2292     if (SvTRUEx(POPs))
2293         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2294     ++*PL_markstack_ptr;
2295     LEAVE;                                      /* exit inner scope */
2296
2297     /* All done yet? */
2298     if (PL_stack_base + *PL_markstack_ptr > SP) {
2299         I32 items;
2300         const I32 gimme = GIMME_V;
2301
2302         LEAVE;                                  /* exit outer scope */
2303         (void)POPMARK;                          /* pop src */
2304         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2305         (void)POPMARK;                          /* pop dst */
2306         SP = PL_stack_base + POPMARK;           /* pop original mark */
2307         if (gimme == G_SCALAR) {
2308             if (PL_op->op_private & OPpGREP_LEX) {
2309                 SV* const sv = sv_newmortal();
2310                 sv_setiv(sv, items);
2311                 PUSHs(sv);
2312             }
2313             else {
2314                 dTARGET;
2315                 XPUSHi(items);
2316             }
2317         }
2318         else if (gimme == G_ARRAY)
2319             SP += items;
2320         RETURN;
2321     }
2322     else {
2323         SV *src;
2324
2325         ENTER;                                  /* enter inner scope */
2326         SAVEVPTR(PL_curpm);
2327
2328         src = PL_stack_base[*PL_markstack_ptr];
2329         SvTEMP_off(src);
2330         if (PL_op->op_private & OPpGREP_LEX)
2331             PAD_SVl(PL_op->op_targ) = src;
2332         else
2333             DEFSV = src;
2334
2335         RETURNOP(cLOGOP->op_other);
2336     }
2337 }
2338
2339 PP(pp_leavesub)
2340 {
2341     dVAR; dSP;
2342     SV **mark;
2343     SV **newsp;
2344     PMOP *newpm;
2345     I32 gimme;
2346     register PERL_CONTEXT *cx;
2347     SV *sv;
2348
2349     if (CxMULTICALL(&cxstack[cxstack_ix]))
2350         return 0;
2351
2352     POPBLOCK(cx,newpm);
2353     cxstack_ix++; /* temporarily protect top context */
2354
2355     TAINT_NOT;
2356     if (gimme == G_SCALAR) {
2357         MARK = newsp + 1;
2358         if (MARK <= SP) {
2359             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2360                 if (SvTEMP(TOPs)) {
2361                     *MARK = SvREFCNT_inc(TOPs);
2362                     FREETMPS;
2363                     sv_2mortal(*MARK);
2364                 }
2365                 else {
2366                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2367                     FREETMPS;
2368                     *MARK = sv_mortalcopy(sv);
2369                     SvREFCNT_dec(sv);
2370                 }
2371             }
2372             else
2373                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2374         }
2375         else {
2376             MEXTEND(MARK, 0);
2377             *MARK = &PL_sv_undef;
2378         }
2379         SP = MARK;
2380     }
2381     else if (gimme == G_ARRAY) {
2382         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2383             if (!SvTEMP(*MARK)) {
2384                 *MARK = sv_mortalcopy(*MARK);
2385                 TAINT_NOT;      /* Each item is independent */
2386             }
2387         }
2388     }
2389     PUTBACK;
2390
2391     LEAVE;
2392     cxstack_ix--;
2393     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2394     PL_curpm = newpm;   /* ... and pop $1 et al */
2395
2396     LEAVESUB(sv);
2397     return cx->blk_sub.retop;
2398 }
2399
2400 /* This duplicates the above code because the above code must not
2401  * get any slower by more conditions */
2402 PP(pp_leavesublv)
2403 {
2404     dVAR; dSP;
2405     SV **mark;
2406     SV **newsp;
2407     PMOP *newpm;
2408     I32 gimme;
2409     register PERL_CONTEXT *cx;
2410     SV *sv;
2411
2412     if (CxMULTICALL(&cxstack[cxstack_ix]))
2413         return 0;
2414
2415     POPBLOCK(cx,newpm);
2416     cxstack_ix++; /* temporarily protect top context */
2417
2418     TAINT_NOT;
2419
2420     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2421         /* We are an argument to a function or grep().
2422          * This kind of lvalueness was legal before lvalue
2423          * subroutines too, so be backward compatible:
2424          * cannot report errors.  */
2425
2426         /* Scalar context *is* possible, on the LHS of -> only,
2427          * as in f()->meth().  But this is not an lvalue. */
2428         if (gimme == G_SCALAR)
2429             goto temporise;
2430         if (gimme == G_ARRAY) {
2431             if (!CvLVALUE(cx->blk_sub.cv))
2432                 goto temporise_array;
2433             EXTEND_MORTAL(SP - newsp);
2434             for (mark = newsp + 1; mark <= SP; mark++) {
2435                 if (SvTEMP(*mark))
2436                     /* empty */ ;
2437                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2438                     *mark = sv_mortalcopy(*mark);
2439                 else {
2440                     /* Can be a localized value subject to deletion. */
2441                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2442                     (void)SvREFCNT_inc(*mark);
2443                 }
2444             }
2445         }
2446     }
2447     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2448         /* Here we go for robustness, not for speed, so we change all
2449          * the refcounts so the caller gets a live guy. Cannot set
2450          * TEMP, so sv_2mortal is out of question. */
2451         if (!CvLVALUE(cx->blk_sub.cv)) {
2452             LEAVE;
2453             cxstack_ix--;
2454             POPSUB(cx,sv);
2455             PL_curpm = newpm;
2456             LEAVESUB(sv);
2457             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2458         }
2459         if (gimme == G_SCALAR) {
2460             MARK = newsp + 1;
2461             EXTEND_MORTAL(1);
2462             if (MARK == SP) {
2463                 /* Temporaries are bad unless they happen to be elements
2464                  * of a tied hash or array */
2465                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2466                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2467                     LEAVE;
2468                     cxstack_ix--;
2469                     POPSUB(cx,sv);
2470                     PL_curpm = newpm;
2471                     LEAVESUB(sv);
2472                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2473                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2474                         : "a readonly value" : "a temporary");
2475                 }
2476                 else {                  /* Can be a localized value
2477                                          * subject to deletion. */
2478                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2479                     (void)SvREFCNT_inc(*mark);
2480                 }
2481             }
2482             else {                      /* Should not happen? */
2483                 LEAVE;
2484                 cxstack_ix--;
2485                 POPSUB(cx,sv);
2486                 PL_curpm = newpm;
2487                 LEAVESUB(sv);
2488                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2489                     (MARK > SP ? "Empty array" : "Array"));
2490             }
2491             SP = MARK;
2492         }
2493         else if (gimme == G_ARRAY) {
2494             EXTEND_MORTAL(SP - newsp);
2495             for (mark = newsp + 1; mark <= SP; mark++) {
2496                 if (*mark != &PL_sv_undef
2497                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2498                     /* Might be flattened array after $#array =  */
2499                     PUTBACK;
2500                     LEAVE;
2501                     cxstack_ix--;
2502                     POPSUB(cx,sv);
2503                     PL_curpm = newpm;
2504                     LEAVESUB(sv);
2505                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2506                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2507                 }
2508                 else {
2509                     /* Can be a localized value subject to deletion. */
2510                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2511                     (void)SvREFCNT_inc(*mark);
2512                 }
2513             }
2514         }
2515     }
2516     else {
2517         if (gimme == G_SCALAR) {
2518           temporise:
2519             MARK = newsp + 1;
2520             if (MARK <= SP) {
2521                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2522                     if (SvTEMP(TOPs)) {
2523                         *MARK = SvREFCNT_inc(TOPs);
2524                         FREETMPS;
2525                         sv_2mortal(*MARK);
2526                     }
2527                     else {
2528                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2529                         FREETMPS;
2530                         *MARK = sv_mortalcopy(sv);
2531                         SvREFCNT_dec(sv);
2532                     }
2533                 }
2534                 else
2535                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2536             }
2537             else {
2538                 MEXTEND(MARK, 0);
2539                 *MARK = &PL_sv_undef;
2540             }
2541             SP = MARK;
2542         }
2543         else if (gimme == G_ARRAY) {
2544           temporise_array:
2545             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2546                 if (!SvTEMP(*MARK)) {
2547                     *MARK = sv_mortalcopy(*MARK);
2548                     TAINT_NOT;  /* Each item is independent */
2549                 }
2550             }
2551         }
2552     }
2553     PUTBACK;
2554
2555     LEAVE;
2556     cxstack_ix--;
2557     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2558     PL_curpm = newpm;   /* ... and pop $1 et al */
2559
2560     LEAVESUB(sv);
2561     return cx->blk_sub.retop;
2562 }
2563
2564
2565 STATIC CV *
2566 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2567 {
2568     SV * const dbsv = GvSVn(PL_DBsub);
2569
2570     save_item(dbsv);
2571     if (!PERLDB_SUB_NN) {
2572         GV *gv = CvGV(cv);
2573
2574         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2575              || strEQ(GvNAME(gv), "END")
2576              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2577                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2578                     && (gv = (GV*)*svp) ))) {
2579             /* Use GV from the stack as a fallback. */
2580             /* GV is potentially non-unique, or contain different CV. */
2581             SV * const tmp = newRV((SV*)cv);
2582             sv_setsv(dbsv, tmp);
2583             SvREFCNT_dec(tmp);
2584         }
2585         else {
2586             gv_efullname3(dbsv, gv, Nullch);
2587         }
2588     }
2589     else {
2590         const int type = SvTYPE(dbsv);
2591         if (type < SVt_PVIV && type != SVt_IV)
2592             sv_upgrade(dbsv, SVt_PVIV);
2593         (void)SvIOK_on(dbsv);
2594         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2595     }
2596
2597     if (CvXSUB(cv))
2598         PL_curcopdb = PL_curcop;
2599     cv = GvCV(PL_DBsub);
2600     return cv;
2601 }
2602
2603 PP(pp_entersub)
2604 {
2605     dVAR; dSP; dPOPss;
2606     GV *gv;
2607     HV *stash;
2608     register CV *cv;
2609     register PERL_CONTEXT *cx;
2610     I32 gimme;
2611     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2612
2613     if (!sv)
2614         DIE(aTHX_ "Not a CODE reference");
2615     switch (SvTYPE(sv)) {
2616         /* This is overwhelming the most common case:  */
2617     case SVt_PVGV:
2618         if (!(cv = GvCVu((GV*)sv)))
2619             cv = sv_2cv(sv, &stash, &gv, FALSE);
2620         if (!cv) {
2621             ENTER;
2622             SAVETMPS;
2623             goto try_autoload;
2624         }
2625         break;
2626     default:
2627         if (!SvROK(sv)) {
2628             const char *sym;
2629             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2630                 if (hasargs)
2631                     SP = PL_stack_base + POPMARK;
2632                 RETURN;
2633             }
2634             if (SvGMAGICAL(sv)) {
2635                 mg_get(sv);
2636                 if (SvROK(sv))
2637                     goto got_rv;
2638                 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2639             }
2640             else {
2641                 sym = SvPV_nolen_const(sv);
2642             }
2643             if (!sym)
2644                 DIE(aTHX_ PL_no_usym, "a subroutine");
2645             if (PL_op->op_private & HINT_STRICT_REFS)
2646                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2647             cv = get_cv(sym, TRUE);
2648             break;
2649         }
2650   got_rv:
2651         {
2652             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2653             tryAMAGICunDEREF(to_cv);
2654         }
2655         cv = (CV*)SvRV(sv);
2656         if (SvTYPE(cv) == SVt_PVCV)
2657             break;
2658         /* FALL THROUGH */
2659     case SVt_PVHV:
2660     case SVt_PVAV:
2661         DIE(aTHX_ "Not a CODE reference");
2662         /* This is the second most common case:  */
2663     case SVt_PVCV:
2664         cv = (CV*)sv;
2665         break;
2666     }
2667
2668     ENTER;
2669     SAVETMPS;
2670
2671   retry:
2672     if (!CvROOT(cv) && !CvXSUB(cv)) {
2673         goto fooey;
2674     }
2675
2676     gimme = GIMME_V;
2677     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2678         if (CvASSERTION(cv) && PL_DBassertion)
2679             sv_setiv(PL_DBassertion, 1);
2680
2681         cv = get_db_sub(&sv, cv);
2682         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2683             DIE(aTHX_ "No DB::sub routine defined");
2684     }
2685
2686     if (!(CvXSUB(cv))) {
2687         /* This path taken at least 75% of the time   */
2688         dMARK;
2689         register I32 items = SP - MARK;
2690         AV* const padlist = CvPADLIST(cv);
2691         PUSHBLOCK(cx, CXt_SUB, MARK);
2692         PUSHSUB(cx);
2693         cx->blk_sub.retop = PL_op->op_next;
2694         CvDEPTH(cv)++;
2695         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2696          * that eval'' ops within this sub know the correct lexical space.
2697          * Owing the speed considerations, we choose instead to search for
2698          * the cv using find_runcv() when calling doeval().
2699          */
2700         if (CvDEPTH(cv) >= 2) {
2701             PERL_STACK_OVERFLOW_CHECK();
2702             pad_push(padlist, CvDEPTH(cv));
2703         }
2704         SAVECOMPPAD();
2705         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2706         if (hasargs)
2707         {
2708             AV* const av = (AV*)PAD_SVl(0);
2709             if (AvREAL(av)) {
2710                 /* @_ is normally not REAL--this should only ever
2711                  * happen when DB::sub() calls things that modify @_ */
2712                 av_clear(av);
2713                 AvREAL_off(av);
2714                 AvREIFY_on(av);
2715             }
2716             cx->blk_sub.savearray = GvAV(PL_defgv);
2717             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2718             CX_CURPAD_SAVE(cx->blk_sub);
2719             cx->blk_sub.argarray = av;
2720             ++MARK;
2721
2722             if (items > AvMAX(av) + 1) {
2723                 SV **ary = AvALLOC(av);
2724                 if (AvARRAY(av) != ary) {
2725                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2726                     SvPV_set(av, (char*)ary);
2727                 }
2728                 if (items > AvMAX(av) + 1) {
2729                     AvMAX(av) = items - 1;
2730                     Renew(ary,items,SV*);
2731                     AvALLOC(av) = ary;
2732                     SvPV_set(av, (char*)ary);
2733                 }
2734             }
2735             Copy(MARK,AvARRAY(av),items,SV*);
2736             AvFILLp(av) = items - 1;
2737
2738             while (items--) {
2739                 if (*MARK)
2740                     SvTEMP_off(*MARK);
2741                 MARK++;
2742             }
2743         }
2744         /* warning must come *after* we fully set up the context
2745          * stuff so that __WARN__ handlers can safely dounwind()
2746          * if they want to
2747          */
2748         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2749             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2750             sub_crush_depth(cv);
2751 #if 0
2752         DEBUG_S(PerlIO_printf(Perl_debug_log,
2753                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2754 #endif
2755         RETURNOP(CvSTART(cv));
2756     }
2757     else {
2758 #ifdef PERL_XSUB_OLDSTYLE
2759         if (CvOLDSTYLE(cv)) {
2760             I32 (*fp3)(int,int,int);
2761             dMARK;
2762             register I32 items = SP - MARK;
2763                                         /* We dont worry to copy from @_. */
2764             while (SP > mark) {
2765                 SP[1] = SP[0];
2766                 SP--;
2767             }
2768             PL_stack_sp = mark + 1;
2769             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2770             items = (*fp3)(CvXSUBANY(cv).any_i32,
2771                            MARK - PL_stack_base + 1,
2772                            items);
2773             PL_stack_sp = PL_stack_base + items;
2774         }
2775         else
2776 #endif /* PERL_XSUB_OLDSTYLE */
2777         {
2778             I32 markix = TOPMARK;
2779
2780             PUTBACK;
2781
2782             if (!hasargs) {
2783                 /* Need to copy @_ to stack. Alternative may be to
2784                  * switch stack to @_, and copy return values
2785                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2786                 AV * const av = GvAV(PL_defgv);
2787                 const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2788
2789                 if (items) {
2790                     /* Mark is at the end of the stack. */
2791                     EXTEND(SP, items);
2792                     Copy(AvARRAY(av), SP + 1, items, SV*);
2793                     SP += items;
2794                     PUTBACK ;
2795                 }
2796             }
2797             /* We assume first XSUB in &DB::sub is the called one. */
2798             if (PL_curcopdb) {
2799                 SAVEVPTR(PL_curcop);
2800                 PL_curcop = PL_curcopdb;
2801                 PL_curcopdb = NULL;
2802             }
2803             /* Do we need to open block here? XXXX */
2804             (void)(*CvXSUB(cv))(aTHX_ cv);
2805
2806             /* Enforce some sanity in scalar context. */
2807             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2808                 if (markix > PL_stack_sp - PL_stack_base)
2809                     *(PL_stack_base + markix) = &PL_sv_undef;
2810                 else
2811                     *(PL_stack_base + markix) = *PL_stack_sp;
2812                 PL_stack_sp = PL_stack_base + markix;
2813             }
2814         }
2815         LEAVE;
2816         return NORMAL;
2817     }
2818
2819     /*NOTREACHED*/
2820     assert (0); /* Cannot get here.  */
2821     /* This is deliberately moved here as spaghetti code to keep it out of the
2822        hot path.  */
2823     {
2824         GV* autogv;
2825         SV* sub_name;
2826
2827       fooey:
2828         /* anonymous or undef'd function leaves us no recourse */
2829         if (CvANON(cv) || !(gv = CvGV(cv)))
2830             DIE(aTHX_ "Undefined subroutine called");
2831
2832         /* autoloaded stub? */
2833         if (cv != GvCV(gv)) {
2834             cv = GvCV(gv);
2835         }
2836         /* should call AUTOLOAD now? */
2837         else {
2838 try_autoload:
2839             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2840                                    FALSE)))
2841             {
2842                 cv = GvCV(autogv);
2843             }
2844             /* sorry */
2845             else {
2846                 sub_name = sv_newmortal();
2847                 gv_efullname3(sub_name, gv, Nullch);
2848                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2849             }
2850         }
2851         if (!cv)
2852             DIE(aTHX_ "Not a CODE reference");
2853         goto retry;
2854     }
2855 }
2856
2857 void
2858 Perl_sub_crush_depth(pTHX_ CV *cv)
2859 {
2860     if (CvANON(cv))
2861         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2862     else {
2863         SV* const tmpstr = sv_newmortal();
2864         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2865         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2866                 tmpstr);
2867     }
2868 }
2869
2870 PP(pp_aelem)
2871 {
2872     dSP;
2873     SV** svp;
2874     SV* const elemsv = POPs;
2875     IV elem = SvIV(elemsv);
2876     AV* const av = (AV*)POPs;
2877     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2878     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2879     SV *sv;
2880
2881     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2882         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2883     if (elem > 0)
2884         elem -= PL_curcop->cop_arybase;
2885     if (SvTYPE(av) != SVt_PVAV)
2886         RETPUSHUNDEF;
2887     svp = av_fetch(av, elem, lval && !defer);
2888     if (lval) {
2889 #ifdef PERL_MALLOC_WRAP
2890          if (SvUOK(elemsv)) {
2891               const UV uv = SvUV(elemsv);
2892               elem = uv > IV_MAX ? IV_MAX : uv;
2893          }
2894          else if (SvNOK(elemsv))
2895               elem = (IV)SvNV(elemsv);
2896          if (elem > 0) {
2897               static const char oom_array_extend[] =
2898                 "Out of memory during array extend"; /* Duplicated in av.c */
2899               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2900          }
2901 #endif
2902         if (!svp || *svp == &PL_sv_undef) {
2903             SV* lv;
2904             if (!defer)
2905                 DIE(aTHX_ PL_no_aelem, elem);
2906             lv = sv_newmortal();
2907             sv_upgrade(lv, SVt_PVLV);
2908             LvTYPE(lv) = 'y';
2909             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2910             LvTARG(lv) = SvREFCNT_inc(av);
2911             LvTARGOFF(lv) = elem;
2912             LvTARGLEN(lv) = 1;
2913             PUSHs(lv);
2914             RETURN;
2915         }
2916         if (PL_op->op_private & OPpLVAL_INTRO)
2917             save_aelem(av, elem, svp);
2918         else if (PL_op->op_private & OPpDEREF)
2919             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2920     }
2921     sv = (svp ? *svp : &PL_sv_undef);
2922     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2923         sv = sv_mortalcopy(sv);
2924     PUSHs(sv);
2925     RETURN;
2926 }
2927
2928 void
2929 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2930 {
2931     SvGETMAGIC(sv);
2932     if (!SvOK(sv)) {
2933         if (SvREADONLY(sv))
2934             Perl_croak(aTHX_ PL_no_modify);
2935         if (SvTYPE(sv) < SVt_RV)
2936             sv_upgrade(sv, SVt_RV);
2937         else if (SvTYPE(sv) >= SVt_PV) {
2938             SvPV_free(sv);
2939             SvLEN_set(sv, 0);
2940             SvCUR_set(sv, 0);
2941         }
2942         switch (to_what) {
2943         case OPpDEREF_SV:
2944             SvRV_set(sv, NEWSV(355,0));
2945             break;
2946         case OPpDEREF_AV:
2947             SvRV_set(sv, (SV*)newAV());
2948             break;
2949         case OPpDEREF_HV:
2950             SvRV_set(sv, (SV*)newHV());
2951             break;
2952         }
2953         SvROK_on(sv);
2954         SvSETMAGIC(sv);
2955     }
2956 }
2957
2958 PP(pp_method)
2959 {
2960     dSP;
2961     SV* const sv = TOPs;
2962
2963     if (SvROK(sv)) {
2964         SV* const rsv = SvRV(sv);
2965         if (SvTYPE(rsv) == SVt_PVCV) {
2966             SETs(rsv);
2967             RETURN;
2968         }
2969     }
2970
2971     SETs(method_common(sv, Null(U32*)));
2972     RETURN;
2973 }
2974
2975 PP(pp_method_named)
2976 {
2977     dSP;
2978     SV* const sv = cSVOP_sv;
2979     U32 hash = SvSHARED_HASH(sv);
2980
2981     XPUSHs(method_common(sv, &hash));
2982     RETURN;
2983 }
2984
2985 STATIC SV *
2986 S_method_common(pTHX_ SV* meth, U32* hashp)
2987 {
2988     SV* ob;
2989     GV* gv;
2990     HV* stash;
2991     STRLEN namelen;
2992     const char* packname = Nullch;
2993     SV *packsv = Nullsv;
2994     STRLEN packlen;
2995     const char * const name = SvPV_const(meth, namelen);
2996     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2997
2998     if (!sv)
2999         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3000
3001     SvGETMAGIC(sv);
3002     if (SvROK(sv))
3003         ob = (SV*)SvRV(sv);
3004     else {
3005         GV* iogv;
3006
3007         /* this isn't a reference */
3008         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3009           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3010           if (he) {
3011             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3012             goto fetch;
3013           }
3014         }
3015
3016         if (!SvOK(sv) ||
3017             !(packname) ||
3018             !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3019             !(ob=(SV*)GvIO(iogv)))
3020         {
3021             /* this isn't the name of a filehandle either */
3022             if (!packname ||
3023                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3024                     ? !isIDFIRST_utf8((U8*)packname)
3025                     : !isIDFIRST(*packname)
3026                 ))
3027             {
3028                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3029                            SvOK(sv) ? "without a package or object reference"
3030                                     : "on an undefined value");
3031             }
3032             /* assume it's a package name */
3033             stash = gv_stashpvn(packname, packlen, FALSE);
3034             if (!stash)
3035                 packsv = sv;
3036             else {
3037                 SV* ref = newSViv(PTR2IV(stash));
3038                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3039             }
3040             goto fetch;
3041         }
3042         /* it _is_ a filehandle name -- replace with a reference */
3043         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3044     }
3045
3046     /* if we got here, ob should be a reference or a glob */
3047     if (!ob || !(SvOBJECT(ob)
3048                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3049                      && SvOBJECT(ob))))
3050     {
3051         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3052                    name);
3053     }
3054
3055     stash = SvSTASH(ob);
3056
3057   fetch:
3058     /* NOTE: stash may be null, hope hv_fetch_ent and
3059        gv_fetchmethod can cope (it seems they can) */
3060
3061     /* shortcut for simple names */
3062     if (hashp) {
3063         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3064         if (he) {
3065             gv = (GV*)HeVAL(he);
3066             if (isGV(gv) && GvCV(gv) &&
3067                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3068                 return (SV*)GvCV(gv);
3069         }
3070     }
3071
3072     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3073
3074     if (!gv) {
3075         /* This code tries to figure out just what went wrong with
3076            gv_fetchmethod.  It therefore needs to duplicate a lot of
3077            the internals of that function.  We can't move it inside
3078            Perl_gv_fetchmethod_autoload(), however, since that would
3079            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3080            don't want that.
3081         */
3082         const char* leaf = name;
3083         const char* sep = Nullch;
3084         const char* p;
3085
3086         for (p = name; *p; p++) {
3087             if (*p == '\'')
3088                 sep = p, leaf = p + 1;
3089             else if (*p == ':' && *(p + 1) == ':')
3090                 sep = p, leaf = p + 2;
3091         }
3092         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3093             /* the method name is unqualified or starts with SUPER:: */
3094             bool need_strlen = 1;
3095             if (sep) {
3096                 packname = CopSTASHPV(PL_curcop);
3097             }
3098             else if (stash) {
3099                 HEK * const packhek = HvNAME_HEK(stash);
3100                 if (packhek) {
3101                     packname = HEK_KEY(packhek);
3102                     packlen = HEK_LEN(packhek);
3103                     need_strlen = 0;
3104                 } else {
3105                     goto croak;
3106                 }
3107             }
3108
3109             if (!packname) {
3110             croak:
3111                 Perl_croak(aTHX_
3112                            "Can't use anonymous symbol table for method lookup");
3113             }
3114             else if (need_strlen)
3115                 packlen = strlen(packname);
3116
3117         }
3118         else {
3119             /* the method name is qualified */
3120             packname = name;
3121             packlen = sep - name;
3122         }
3123
3124         /* we're relying on gv_fetchmethod not autovivifying the stash */
3125         if (gv_stashpvn(packname, packlen, FALSE)) {
3126             Perl_croak(aTHX_
3127                        "Can't locate object method \"%s\" via package \"%.*s\"",
3128                        leaf, (int)packlen, packname);
3129         }
3130         else {
3131             Perl_croak(aTHX_
3132                        "Can't locate object method \"%s\" via package \"%.*s\""
3133                        " (perhaps you forgot to load \"%.*s\"?)",
3134                        leaf, (int)packlen, packname, (int)packlen, packname);
3135         }
3136     }
3137     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3138 }
3139
3140 /*
3141  * Local variables:
3142  * c-indentation-style: bsd
3143  * c-basic-offset: 4
3144  * indent-tabs-mode: t
3145  * End:
3146  *
3147  * ex: set ts=8 sts=4 sw=4 noet:
3148  */