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