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