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