pp_hot.c

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