pp_hot.c

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