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_const(right, rlen);  /* mg_get(right) happens here */
 151     const bool rbyte = !DO_UTF8(right);
 152     bool rcopied = FALSE;
 153
 154     if (TARG == right && right != left) {
 155         right = sv_2mortal(newSVpvn(rpv, rlen));
 156         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 157         rcopied = TRUE;
 158     }
 159
 160     if (TARG != left) {
 161         STRLEN llen;
 162         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 163         lbyte = !DO_UTF8(left);
 164         sv_setpvn(TARG, lpv, llen);
 165         if (!lbyte)
 166             SvUTF8_on(TARG);
 167         else
 168             SvUTF8_off(TARG);
 169     }
 170     else { /* TARG == left */
 171         STRLEN llen;
 172         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_const(left, llen);    /* Needed to set UTF8 flag */
 177         lbyte = !DO_UTF8(left);
 178         if (IN_BYTES)
 179             SvUTF8_off(TARG);
 180     }
 181
 182     if (lbyte != rbyte) {
 183         if (lbyte)
 184             sv_utf8_upgrade_nomg(TARG);
 185         else {
 186             if (!rcopied)
 187                 right = sv_2mortal(newSVpvn(rpv, rlen));
 188             sv_utf8_upgrade_nomg(right);
 189             rpv = SvPV_const(right, rlen);
 190         }
 191     }
 192     sv_catpvn_nomg(TARG, rpv, rlen);
 193
 194     SETTARG;
 195     RETURN;
 196   }
 197 }
 198
 199 PP(pp_padsv)
 200 {
 201     dSP; dTARGET;
 202     XPUSHs(TARG);
 203     if (PL_op->op_flags & OPf_MOD) {
 204         if (PL_op->op_private & OPpLVAL_INTRO)
 205             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 206         if (PL_op->op_private & OPpDEREF) {
 207             PUTBACK;
 208             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 209             SPAGAIN;
 210         }
 211     }
 212     RETURN;
 213 }
 214
 215 PP(pp_readline)
 216 {
 217     tryAMAGICunTARGET(iter, 0);
 218     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 219     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 220         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 221             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 222         else {
 223             dSP;
 224             XPUSHs((SV*)PL_last_in_gv);
 225             PUTBACK;
 226             pp_rv2gv();
 227             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 228         }
 229     }
 230     return do_readline();
 231 }
 232
 233 PP(pp_eq)
 234 {
 235     dSP; tryAMAGICbinSET(eq,0);
 236 #ifndef NV_PRESERVES_UV
 237     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 238         SP--;
 239         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 240         RETURN;
 241     }
 242 #endif
 243 #ifdef PERL_PRESERVE_IVUV
 244     SvIV_please(TOPs);
 245     if (SvIOK(TOPs)) {
 246         /* Unless the left argument is integer in range we are going
 247            to have to use NV maths. Hence only attempt to coerce the
 248            right argument if we know the left is integer.  */
 249       SvIV_please(TOPm1s);
 250         if (SvIOK(TOPm1s)) {
 251             bool auvok = SvUOK(TOPm1s);
 252             bool buvok = SvUOK(TOPs);
 253
 254             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 255                 /* Casting IV to UV before comparison isn't going to matter
 256                    on 2s complement. On 1s complement or sign&magnitude
 257                    (if we have any of them) it could to make negative zero
 258                    differ from normal zero. As I understand it. (Need to
 259                    check - is negative zero implementation defined behaviour
 260                    anyway?). NWC  */
 261                 UV buv = SvUVX(POPs);
 262                 UV auv = SvUVX(TOPs);
 263
 264                 SETs(boolSV(auv == buv));
 265                 RETURN;
 266             }
 267             {                   /* ## Mixed IV,UV ## */
 268                 SV *ivp, *uvp;
 269                 IV iv;
 270
 271                 /* == is commutative so doesn't matter which is left or right */
 272                 if (auvok) {
 273                     /* top of stack (b) is the iv */
 274                     ivp = *SP;
 275                     uvp = *--SP;
 276                 } else {
 277                     uvp = *SP;
 278                     ivp = *--SP;
 279                 }
 280                 iv = SvIVX(ivp);
 281                 if (iv < 0) {
 282                     /* As uv is a UV, it's >0, so it cannot be == */
 283                     SETs(&PL_sv_no);
 284                     RETURN;
 285                 }
 286                 /* we know iv is >= 0 */
 287                 SETs(boolSV((UV)iv == SvUVX(uvp)));
 288                 RETURN;
 289             }
 290         }
 291     }
 292 #endif
 293     {
 294       dPOPnv;
 295       SETs(boolSV(TOPn == value));
 296       RETURN;
 297     }
 298 }
 299
 300 PP(pp_preinc)
 301 {
 302     dSP;
 303     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 304         DIE(aTHX_ PL_no_modify);
 305     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 306         && SvIVX(TOPs) != IV_MAX)
 307     {
 308         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 309         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 310     }
 311     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 312         sv_inc(TOPs);
 313     SvSETMAGIC(TOPs);
 314     return NORMAL;
 315 }
 316
 317 PP(pp_or)
 318 {
 319     dSP;
 320     if (SvTRUE(TOPs))
 321         RETURN;
 322     else {
 323         --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     const register char *t;
1180     const register char *s;
1181     const char *strend;
1182     I32 global;
1183     I32 r_flags = REXEC_CHECKED;
1184     const 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_const(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         /* FIXME - can PL_bostr be made const char *?  */
1267         PL_bostr = (char *)truebase;
1268         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1269
1270         if (!s)
1271             goto nope;
1272         if ( (rx->reganch & ROPT_CHECK_ALL)
1273              && !PL_sawampersand
1274              && ((rx->reganch & ROPT_NOSCAN)
1275                  || !((rx->reganch & RE_INTUIT_TAIL)
1276                       && (r_flags & REXEC_SCREAM)))
1277              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1278             goto yup;
1279     }
1280     if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1281     {
1282         PL_curpm = pm;
1283         if (dynpm->op_pmflags & PMf_ONCE)
1284             dynpm->op_pmdynflags |= PMdf_USED;
1285         goto gotcha;
1286     }
1287     else
1288         goto ret_no;
1289     /*NOTREACHED*/
1290
1291   gotcha:
1292     if (rxtainted)
1293         RX_MATCH_TAINTED_on(rx);
1294     TAINT_IF(RX_MATCH_TAINTED(rx));
1295     if (gimme == G_ARRAY) {
1296         const I32 nparens = rx->nparens;
1297         I32 i = (global && !nparens) ? 1 : 0;
1298
1299         SPAGAIN;                        /* EVAL blocks could move the stack. */
1300         EXTEND(SP, nparens + i);
1301         EXTEND_MORTAL(nparens + i);
1302         for (i = !i; i <= nparens; i++) {
1303             PUSHs(sv_newmortal());
1304             /*SUPPRESS 560*/
1305             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1306                 const I32 len = rx->endp[i] - rx->startp[i];
1307                 s = rx->startp[i] + truebase;
1308                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1309                     len < 0 || len > strend - s)
1310                     DIE(aTHX_ "panic: pp_match start/end pointers");
1311                 sv_setpvn(*SP, s, len);
1312                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1313                     SvUTF8_on(*SP);
1314             }
1315         }
1316         if (global) {
1317             if (dynpm->op_pmflags & PMf_CONTINUE) {
1318                 MAGIC* mg = 0;
1319                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1320                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1321                 if (!mg) {
1322                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1323                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1324                 }
1325                 if (rx->startp[0] != -1) {
1326                     mg->mg_len = rx->endp[0];
1327                     if (rx->startp[0] == rx->endp[0])
1328                         mg->mg_flags |= MGf_MINMATCH;
1329                     else
1330                         mg->mg_flags &= ~MGf_MINMATCH;
1331                 }
1332             }
1333             had_zerolen = (rx->startp[0] != -1
1334                            && rx->startp[0] == rx->endp[0]);
1335             PUTBACK;                    /* EVAL blocks may use stack */
1336             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1337             goto play_it_again;
1338         }
1339         else if (!nparens)
1340             XPUSHs(&PL_sv_yes);
1341         LEAVE_SCOPE(oldsave);
1342         RETURN;
1343     }
1344     else {
1345         if (global) {
1346             MAGIC* mg = 0;
1347             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1348                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349             if (!mg) {
1350                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1351                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1352             }
1353             if (rx->startp[0] != -1) {
1354                 mg->mg_len = rx->endp[0];
1355                 if (rx->startp[0] == rx->endp[0])
1356                     mg->mg_flags |= MGf_MINMATCH;
1357                 else
1358                     mg->mg_flags &= ~MGf_MINMATCH;
1359             }
1360         }
1361         LEAVE_SCOPE(oldsave);
1362         RETPUSHYES;
1363     }
1364
1365 yup:                                    /* Confirmed by INTUIT */
1366     if (rxtainted)
1367         RX_MATCH_TAINTED_on(rx);
1368     TAINT_IF(RX_MATCH_TAINTED(rx));
1369     PL_curpm = pm;
1370     if (dynpm->op_pmflags & PMf_ONCE)
1371         dynpm->op_pmdynflags |= PMdf_USED;
1372     if (RX_MATCH_COPIED(rx))
1373         Safefree(rx->subbeg);
1374     RX_MATCH_COPIED_off(rx);
1375     rx->subbeg = Nullch;
1376     if (global) {
1377         /* FIXME - should rx->subbeg be const char *?  */
1378         rx->subbeg = (char *) truebase;
1379         rx->startp[0] = s - truebase;
1380         if (RX_MATCH_UTF8(rx)) {
1381             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1382             rx->endp[0] = t - truebase;
1383         }
1384         else {
1385             rx->endp[0] = s - truebase + rx->minlen;
1386         }
1387         rx->sublen = strend - truebase;
1388         goto gotcha;
1389     }
1390     if (PL_sawampersand) {
1391         I32 off;
1392 #ifdef PERL_OLD_COPY_ON_WRITE
1393         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1394             if (DEBUG_C_TEST) {
1395                 PerlIO_printf(Perl_debug_log,
1396                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1397                               (int) SvTYPE(TARG), truebase, t,
1398                               (int)(t-truebase));
1399             }
1400             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1401             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1402             assert (SvPOKp(rx->saved_copy));
1403         } else
1404 #endif
1405         {
1406
1407             rx->subbeg = savepvn(t, strend - t);
1408 #ifdef PERL_OLD_COPY_ON_WRITE
1409             rx->saved_copy = Nullsv;
1410 #endif
1411         }
1412         rx->sublen = strend - t;
1413         RX_MATCH_COPIED_on(rx);
1414         off = rx->startp[0] = s - t;
1415         rx->endp[0] = off + rx->minlen;
1416     }
1417     else {                      /* startp/endp are used by @- @+. */
1418         rx->startp[0] = s - truebase;
1419         rx->endp[0] = s - truebase + rx->minlen;
1420     }
1421     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1422     LEAVE_SCOPE(oldsave);
1423     RETPUSHYES;
1424
1425 nope:
1426 ret_no:
1427     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1428         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1429             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1430             if (mg)
1431                 mg->mg_len = -1;
1432         }
1433     }
1434     LEAVE_SCOPE(oldsave);
1435     if (gimme == G_ARRAY)
1436         RETURN;
1437     RETPUSHNO;
1438 }
1439
1440 OP *
1441 Perl_do_readline(pTHX)
1442 {
1443     dVAR; dSP; dTARGETSTACKED;
1444     register SV *sv;
1445     STRLEN tmplen = 0;
1446     STRLEN offset;
1447     PerlIO *fp;
1448     register IO * const io = GvIO(PL_last_in_gv);
1449     register const I32 type = PL_op->op_type;
1450     const I32 gimme = GIMME_V;
1451     MAGIC *mg;
1452
1453     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1454         PUSHMARK(SP);
1455         XPUSHs(SvTIED_obj((SV*)io, mg));
1456         PUTBACK;
1457         ENTER;
1458         call_method("READLINE", gimme);
1459         LEAVE;
1460         SPAGAIN;
1461         if (gimme == G_SCALAR) {
1462             SV* result = POPs;
1463             SvSetSV_nosteal(TARG, result);
1464             PUSHTARG;
1465         }
1466         RETURN;
1467     }
1468     fp = Nullfp;
1469     if (io) {
1470         fp = IoIFP(io);
1471         if (!fp) {
1472             if (IoFLAGS(io) & IOf_ARGV) {
1473                 if (IoFLAGS(io) & IOf_START) {
1474                     IoLINES(io) = 0;
1475                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1476                         IoFLAGS(io) &= ~IOf_START;
1477                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1478                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1479                         SvSETMAGIC(GvSV(PL_last_in_gv));
1480                         fp = IoIFP(io);
1481                         goto have_fp;
1482                     }
1483                 }
1484                 fp = nextargv(PL_last_in_gv);
1485                 if (!fp) { /* Note: fp != IoIFP(io) */
1486                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1487                 }
1488             }
1489             else if (type == OP_GLOB)
1490                 fp = Perl_start_glob(aTHX_ POPs, io);
1491         }
1492         else if (type == OP_GLOB)
1493             SP--;
1494         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1495             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1496         }
1497     }
1498     if (!fp) {
1499         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1500                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1501             if (type == OP_GLOB)
1502                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1503                             "glob failed (can't start child: %s)",
1504                             Strerror(errno));
1505             else
1506                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1507         }
1508         if (gimme == G_SCALAR) {
1509             /* undef TARG, and push that undefined value */
1510             if (type != OP_RCATLINE) {
1511                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1512                 SvOK_off(TARG);
1513             }
1514             PUSHTARG;
1515         }
1516         RETURN;
1517     }
1518   have_fp:
1519     if (gimme == G_SCALAR) {
1520         sv = TARG;
1521         if (SvROK(sv))
1522             sv_unref(sv);
1523         SvUPGRADE(sv, SVt_PV);
1524         tmplen = SvLEN(sv);     /* remember if already alloced */
1525         if (!tmplen && !SvREADONLY(sv))
1526             Sv_Grow(sv, 80);    /* try short-buffering it */
1527         offset = 0;
1528         if (type == OP_RCATLINE && SvOK(sv)) {
1529             if (!SvPOK(sv)) {
1530                 SvPV_force_nolen(sv);
1531             }
1532             offset = SvCUR(sv);
1533         }
1534     }
1535     else {
1536         sv = sv_2mortal(NEWSV(57, 80));
1537         offset = 0;
1538     }
1539
1540     /* This should not be marked tainted if the fp is marked clean */
1541 #define MAYBE_TAINT_LINE(io, sv) \
1542     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1543         TAINT;                          \
1544         SvTAINTED_on(sv);               \
1545     }
1546
1547 /* delay EOF state for a snarfed empty file */
1548 #define SNARF_EOF(gimme,rs,io,sv) \
1549     (gimme != G_SCALAR || SvCUR(sv)                                     \
1550      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1551
1552     for (;;) {
1553         PUTBACK;
1554         if (!sv_gets(sv, fp, offset)
1555             && (type == OP_GLOB
1556                 || SNARF_EOF(gimme, PL_rs, io, sv)
1557                 || PerlIO_error(fp)))
1558         {
1559             PerlIO_clearerr(fp);
1560             if (IoFLAGS(io) & IOf_ARGV) {
1561                 fp = nextargv(PL_last_in_gv);
1562                 if (fp)
1563                     continue;
1564                 (void)do_close(PL_last_in_gv, FALSE);
1565             }
1566             else if (type == OP_GLOB) {
1567                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1568                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1569                            "glob failed (child exited with status %d%s)",
1570                            (int)(STATUS_CURRENT >> 8),
1571                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1572                 }
1573             }
1574             if (gimme == G_SCALAR) {
1575                 if (type != OP_RCATLINE) {
1576                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1577                     SvOK_off(TARG);
1578                 }
1579                 SPAGAIN;
1580                 PUSHTARG;
1581             }
1582             MAYBE_TAINT_LINE(io, sv);
1583             RETURN;
1584         }
1585         MAYBE_TAINT_LINE(io, sv);
1586         IoLINES(io)++;
1587         IoFLAGS(io) |= IOf_NOLINE;
1588         SvSETMAGIC(sv);
1589         SPAGAIN;
1590         XPUSHs(sv);
1591         if (type == OP_GLOB) {
1592             char *tmps;
1593             const char *t1;
1594
1595             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1596                 tmps = SvEND(sv) - 1;
1597                 if (*tmps == *SvPVX_const(PL_rs)) {
1598                     *tmps = '\0';
1599                     SvCUR_set(sv, SvCUR(sv) - 1);
1600                 }
1601             }
1602             for (t1 = SvPVX_const(sv); *t1; t1++)
1603                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1604                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1605                         break;
1606             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1607                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1608                 continue;
1609             }
1610         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1611              const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1612              const STRLEN len = SvCUR(sv) - offset;
1613              const U8 *f;
1614
1615              if (ckWARN(WARN_UTF8) &&
1616                  !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1617                   /* Emulate :encoding(utf8) warning in the same case. */
1618                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
1619                               "utf8 \"\\x%02X\" does not map to Unicode",
1620                               f < (U8*)SvEND(sv) ? *f : 0);
1621         }
1622         if (gimme == G_ARRAY) {
1623             if (SvLEN(sv) - SvCUR(sv) > 20) {
1624                 SvPV_shrink_to_cur(sv);
1625             }
1626             sv = sv_2mortal(NEWSV(58, 80));
1627             continue;
1628         }
1629         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1630             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1631             const STRLEN new_len
1632                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1633             SvPV_renew(sv, new_len);
1634         }
1635         RETURN;
1636     }
1637 }
1638
1639 PP(pp_enter)
1640 {
1641     dVAR; dSP;
1642     register PERL_CONTEXT *cx;
1643     I32 gimme = OP_GIMME(PL_op, -1);
1644
1645     if (gimme == -1) {
1646         if (cxstack_ix >= 0)
1647             gimme = cxstack[cxstack_ix].blk_gimme;
1648         else
1649             gimme = G_SCALAR;
1650     }
1651
1652     ENTER;
1653
1654     SAVETMPS;
1655     PUSHBLOCK(cx, CXt_BLOCK, SP);
1656
1657     RETURN;
1658 }
1659
1660 PP(pp_helem)
1661 {
1662     dSP;
1663     HE* he;
1664     SV **svp;
1665     SV *keysv = POPs;
1666     HV *hv = (HV*)POPs;
1667     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1668     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1669     SV *sv;
1670     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1671     I32 preeminent = 0;
1672
1673     if (SvTYPE(hv) == SVt_PVHV) {
1674         if (PL_op->op_private & OPpLVAL_INTRO) {
1675             MAGIC *mg;
1676             HV *stash;
1677             /* does the element we're localizing already exist? */
1678             preeminent =
1679                 /* can we determine whether it exists? */
1680                 (    !SvRMAGICAL(hv)
1681                   || mg_find((SV*)hv, PERL_MAGIC_env)
1682                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1683                         /* Try to preserve the existenceness of a tied hash
1684                          * element by using EXISTS and DELETE if possible.
1685                          * Fallback to FETCH and STORE otherwise */
1686                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1687                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1688                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1689                     )
1690                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1691
1692         }
1693         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1694         svp = he ? &HeVAL(he) : 0;
1695     }
1696     else {
1697         RETPUSHUNDEF;
1698     }
1699     if (lval) {
1700         if (!svp || *svp == &PL_sv_undef) {
1701             SV* lv;
1702             SV* key2;
1703             if (!defer) {
1704                 DIE(aTHX_ PL_no_helem_sv, keysv);
1705             }
1706             lv = sv_newmortal();
1707             sv_upgrade(lv, SVt_PVLV);
1708             LvTYPE(lv) = 'y';
1709             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1710             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1711             LvTARG(lv) = SvREFCNT_inc(hv);
1712             LvTARGLEN(lv) = 1;
1713             PUSHs(lv);
1714             RETURN;
1715         }
1716         if (PL_op->op_private & OPpLVAL_INTRO) {
1717             if (HvNAME_get(hv) && isGV(*svp))
1718                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1719             else {
1720                 if (!preeminent) {
1721                     STRLEN keylen;
1722                     const char * const key = SvPV_const(keysv, keylen);
1723                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1724                 } else
1725                     save_helem(hv, keysv, svp);
1726             }
1727         }
1728         else if (PL_op->op_private & OPpDEREF)
1729             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1730     }
1731     sv = (svp ? *svp : &PL_sv_undef);
1732     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1733      * Pushing the magical RHS on to the stack is useless, since
1734      * that magic is soon destined to be misled by the local(),
1735      * and thus the later pp_sassign() will fail to mg_get() the
1736      * old value.  This should also cure problems with delayed
1737      * mg_get()s.  GSAR 98-07-03 */
1738     if (!lval && SvGMAGICAL(sv))
1739         sv = sv_mortalcopy(sv);
1740     PUSHs(sv);
1741     RETURN;
1742 }
1743
1744 PP(pp_leave)
1745 {
1746     dVAR; dSP;
1747     register PERL_CONTEXT *cx;
1748     SV **newsp;
1749     PMOP *newpm;
1750     I32 gimme;
1751
1752     if (PL_op->op_flags & OPf_SPECIAL) {
1753         cx = &cxstack[cxstack_ix];
1754         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1755     }
1756
1757     POPBLOCK(cx,newpm);
1758
1759     gimme = OP_GIMME(PL_op, -1);
1760     if (gimme == -1) {
1761         if (cxstack_ix >= 0)
1762             gimme = cxstack[cxstack_ix].blk_gimme;
1763         else
1764             gimme = G_SCALAR;
1765     }
1766
1767     TAINT_NOT;
1768     if (gimme == G_VOID)
1769         SP = newsp;
1770     else if (gimme == G_SCALAR) {
1771         register SV **mark;
1772         MARK = newsp + 1;
1773         if (MARK <= SP) {
1774             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1775                 *MARK = TOPs;
1776             else
1777                 *MARK = sv_mortalcopy(TOPs);
1778         } else {
1779             MEXTEND(mark,0);
1780             *MARK = &PL_sv_undef;
1781         }
1782         SP = MARK;
1783     }
1784     else if (gimme == G_ARRAY) {
1785         /* in case LEAVE wipes old return values */
1786         register SV **mark;
1787         for (mark = newsp + 1; mark <= SP; mark++) {
1788             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1789                 *mark = sv_mortalcopy(*mark);
1790                 TAINT_NOT;      /* Each item is independent */
1791             }
1792         }
1793     }
1794     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1795
1796     LEAVE;
1797
1798     RETURN;
1799 }
1800
1801 PP(pp_iter)
1802 {
1803     dSP;
1804     register PERL_CONTEXT *cx;
1805     SV *sv, *oldsv;
1806     AV* av;
1807     SV **itersvp;
1808
1809     EXTEND(SP, 1);
1810     cx = &cxstack[cxstack_ix];
1811     if (CxTYPE(cx) != CXt_LOOP)
1812         DIE(aTHX_ "panic: pp_iter");
1813
1814     itersvp = CxITERVAR(cx);
1815     av = cx->blk_loop.iterary;
1816     if (SvTYPE(av) != SVt_PVAV) {
1817         /* iterate ($min .. $max) */
1818         if (cx->blk_loop.iterlval) {
1819             /* string increment */
1820             register SV* cur = cx->blk_loop.iterlval;
1821             STRLEN maxlen = 0;
1822             const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1823             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1824                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1825                     /* safe to reuse old SV */
1826                     sv_setsv(*itersvp, cur);
1827                 }
1828                 else
1829                 {
1830                     /* we need a fresh SV every time so that loop body sees a
1831                      * completely new SV for closures/references to work as
1832                      * they used to */
1833                     oldsv = *itersvp;
1834                     *itersvp = newSVsv(cur);
1835                     SvREFCNT_dec(oldsv);
1836                 }
1837                 if (strEQ(SvPVX_const(cur), max))
1838                     sv_setiv(cur, 0); /* terminate next time */
1839                 else
1840                     sv_inc(cur);
1841                 RETPUSHYES;
1842             }
1843             RETPUSHNO;
1844         }
1845         /* integer increment */
1846         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1847             RETPUSHNO;
1848
1849         /* don't risk potential race */
1850         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1851             /* safe to reuse old SV */
1852             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1853         }
1854         else
1855         {
1856             /* we need a fresh SV every time so that loop body sees a
1857              * completely new SV for closures/references to work as they
1858              * used to */
1859             oldsv = *itersvp;
1860             *itersvp = newSViv(cx->blk_loop.iterix++);
1861             SvREFCNT_dec(oldsv);
1862         }
1863         RETPUSHYES;
1864     }
1865
1866     /* iterate array */
1867     if (PL_op->op_private & OPpITER_REVERSED) {
1868         /* In reverse, use itermax as the min :-)  */
1869         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1870             RETPUSHNO;
1871
1872         if (SvMAGICAL(av) || AvREIFY(av)) {
1873             SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1874             if (svp)
1875                 sv = *svp;
1876             else
1877                 sv = Nullsv;
1878         }
1879         else {
1880             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1881         }
1882     }
1883     else {
1884         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1885                                     AvFILL(av)))
1886             RETPUSHNO;
1887
1888         if (SvMAGICAL(av) || AvREIFY(av)) {
1889             SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1890             if (svp)
1891                 sv = *svp;
1892             else
1893                 sv = Nullsv;
1894         }
1895         else {
1896             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1897         }
1898     }
1899
1900     if (sv && SvREFCNT(sv) == 0) {
1901         *itersvp = Nullsv;
1902         Perl_croak(aTHX_ "Use of freed value in iteration");
1903     }
1904
1905     if (sv)
1906         SvTEMP_off(sv);
1907     else
1908         sv = &PL_sv_undef;
1909     if (av != PL_curstack && sv == &PL_sv_undef) {
1910         SV *lv = cx->blk_loop.iterlval;
1911         if (lv && SvREFCNT(lv) > 1) {
1912             SvREFCNT_dec(lv);
1913             lv = Nullsv;
1914         }
1915         if (lv)
1916             SvREFCNT_dec(LvTARG(lv));
1917         else {
1918             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1919             sv_upgrade(lv, SVt_PVLV);
1920             LvTYPE(lv) = 'y';
1921             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1922         }
1923         LvTARG(lv) = SvREFCNT_inc(av);
1924         LvTARGOFF(lv) = cx->blk_loop.iterix;
1925         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1926         sv = (SV*)lv;
1927     }
1928
1929     oldsv = *itersvp;
1930     *itersvp = SvREFCNT_inc(sv);
1931     SvREFCNT_dec(oldsv);
1932
1933     RETPUSHYES;
1934 }
1935
1936 PP(pp_subst)
1937 {
1938     dSP; dTARG;
1939     register PMOP *pm = cPMOP;
1940     PMOP *rpm = pm;
1941     register SV *dstr;
1942     register char *s;
1943     char *strend;
1944     register char *m;
1945     const char *c;
1946     register char *d;
1947     STRLEN clen;
1948     I32 iters = 0;
1949     I32 maxiters;
1950     register I32 i;
1951     bool once;
1952     bool rxtainted;
1953     char *orig;
1954     I32 r_flags;
1955     register REGEXP *rx = PM_GETRE(pm);
1956     STRLEN len;
1957     int force_on_match = 0;
1958     I32 oldsave = PL_savestack_ix;
1959     STRLEN slen;
1960     bool doutf8 = FALSE;
1961 #ifdef PERL_OLD_COPY_ON_WRITE
1962     bool is_cow;
1963 #endif
1964     SV *nsv = Nullsv;
1965
1966     /* known replacement string? */
1967     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1968     if (PL_op->op_flags & OPf_STACKED)
1969         TARG = POPs;
1970     else if (PL_op->op_private & OPpTARGET_MY)
1971         GETTARGET;
1972     else {
1973         TARG = DEFSV;
1974         EXTEND(SP,1);
1975     }
1976
1977 #ifdef PERL_OLD_COPY_ON_WRITE
1978     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1979        because they make integers such as 256 "false".  */
1980     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1981 #else
1982     if (SvIsCOW(TARG))
1983         sv_force_normal_flags(TARG,0);
1984 #endif
1985     if (
1986 #ifdef PERL_OLD_COPY_ON_WRITE
1987         !is_cow &&
1988 #endif
1989         (SvREADONLY(TARG)
1990         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1991              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1992         DIE(aTHX_ PL_no_modify);
1993     PUTBACK;
1994
1995     s = SvPV_mutable(TARG, len);
1996     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1997         force_on_match = 1;
1998     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1999                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2000     if (PL_tainted)
2001         rxtainted |= 2;
2002     TAINT_NOT;
2003
2004     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2005
2006   force_it:
2007     if (!pm || !s)
2008         DIE(aTHX_ "panic: pp_subst");
2009
2010     strend = s + len;
2011     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2012     maxiters = 2 * slen + 10;   /* We can match twice at each
2013                                    position, once with zero-length,
2014                                    second time with non-zero. */
2015
2016     if (!rx->prelen && PL_curpm) {
2017         pm = PL_curpm;
2018         rx = PM_GETRE(pm);
2019     }
2020     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2021                ? REXEC_COPY_STR : 0;
2022     if (SvSCREAM(TARG))
2023         r_flags |= REXEC_SCREAM;
2024
2025     orig = m = s;
2026     if (rx->reganch & RE_USE_INTUIT) {
2027         PL_bostr = orig;
2028         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2029
2030         if (!s)
2031             goto nope;
2032         /* How to do it in subst? */
2033 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2034              && !PL_sawampersand
2035              && ((rx->reganch & ROPT_NOSCAN)
2036                  || !((rx->reganch & RE_INTUIT_TAIL)
2037                       && (r_flags & REXEC_SCREAM))))
2038             goto yup;
2039 */
2040     }
2041
2042     /* only replace once? */
2043     once = !(rpm->op_pmflags & PMf_GLOBAL);
2044
2045     /* known replacement string? */
2046     if (dstr) {
2047         /* replacement needing upgrading? */
2048         if (DO_UTF8(TARG) && !doutf8) {
2049              nsv = sv_newmortal();
2050              SvSetSV(nsv, dstr);
2051              if (PL_encoding)
2052                   sv_recode_to_utf8(nsv, PL_encoding);
2053              else
2054                   sv_utf8_upgrade(nsv);
2055              c = SvPV_const(nsv, clen);
2056              doutf8 = TRUE;
2057         }
2058         else {
2059             c = SvPV_const(dstr, clen);
2060             doutf8 = DO_UTF8(dstr);
2061         }
2062     }
2063     else {
2064         c = Nullch;
2065         doutf8 = FALSE;
2066     }
2067
2068     /* can do inplace substitution? */
2069     if (c
2070 #ifdef PERL_OLD_COPY_ON_WRITE
2071         && !is_cow
2072 #endif
2073         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2074         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2075         && (!doutf8 || SvUTF8(TARG))) {
2076         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2077                          r_flags | REXEC_CHECKED))
2078         {
2079             SPAGAIN;
2080             PUSHs(&PL_sv_no);
2081             LEAVE_SCOPE(oldsave);
2082             RETURN;
2083         }
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2085         if (SvIsCOW(TARG)) {
2086             assert (!force_on_match);
2087             goto have_a_cow;
2088         }
2089 #endif
2090         if (force_on_match) {
2091             force_on_match = 0;
2092             s = SvPV_force(TARG, len);
2093             goto force_it;
2094         }
2095         d = s;
2096         PL_curpm = pm;
2097         SvSCREAM_off(TARG);     /* disable possible screamer */
2098         if (once) {
2099             rxtainted |= RX_MATCH_TAINTED(rx);
2100             m = orig + rx->startp[0];
2101             d = orig + rx->endp[0];
2102             s = orig;
2103             if (m - s > strend - d) {  /* faster to shorten from end */
2104                 if (clen) {
2105                     Copy(c, m, clen, char);
2106                     m += clen;
2107                 }
2108                 i = strend - d;
2109                 if (i > 0) {
2110                     Move(d, m, i, char);
2111                     m += i;
2112                 }
2113                 *m = '\0';
2114                 SvCUR_set(TARG, m - s);
2115             }
2116             /*SUPPRESS 560*/
2117             else if ((i = m - s)) {     /* faster from front */
2118                 d -= clen;
2119                 m = d;
2120                 sv_chop(TARG, d-i);
2121                 s += i;
2122                 while (i--)
2123                     *--d = *--s;
2124                 if (clen)
2125                     Copy(c, m, clen, char);
2126             }
2127             else if (clen) {
2128                 d -= clen;
2129                 sv_chop(TARG, d);
2130                 Copy(c, d, clen, char);
2131             }
2132             else {
2133                 sv_chop(TARG, d);
2134             }
2135             TAINT_IF(rxtainted & 1);
2136             SPAGAIN;
2137             PUSHs(&PL_sv_yes);
2138         }
2139         else {
2140             do {
2141                 if (iters++ > maxiters)
2142                     DIE(aTHX_ "Substitution loop");
2143                 rxtainted |= RX_MATCH_TAINTED(rx);
2144                 m = rx->startp[0] + orig;
2145                 /*SUPPRESS 560*/
2146                 if ((i = m - s)) {
2147                     if (s != d)
2148                         Move(s, d, i, char);
2149                     d += i;
2150                 }
2151                 if (clen) {
2152                     Copy(c, d, clen, char);
2153                     d += clen;
2154                 }
2155                 s = rx->endp[0] + orig;
2156             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2157                                  TARG, NULL,
2158                                  /* don't match same null twice */
2159                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2160             if (s != d) {
2161                 i = strend - s;
2162                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2163                 Move(s, d, i+1, char);          /* include the NUL */
2164             }
2165             TAINT_IF(rxtainted & 1);
2166             SPAGAIN;
2167             PUSHs(sv_2mortal(newSViv((I32)iters)));
2168         }
2169         (void)SvPOK_only_UTF8(TARG);
2170         TAINT_IF(rxtainted);
2171         if (SvSMAGICAL(TARG)) {
2172             PUTBACK;
2173             mg_set(TARG);
2174             SPAGAIN;
2175         }
2176         SvTAINT(TARG);
2177         if (doutf8)
2178             SvUTF8_on(TARG);
2179         LEAVE_SCOPE(oldsave);
2180         RETURN;
2181     }
2182
2183     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2184                     r_flags | REXEC_CHECKED))
2185     {
2186         if (force_on_match) {
2187             force_on_match = 0;
2188             s = SvPV_force(TARG, len);
2189             goto force_it;
2190         }
2191 #ifdef PERL_OLD_COPY_ON_WRITE
2192       have_a_cow:
2193 #endif
2194         rxtainted |= RX_MATCH_TAINTED(rx);
2195         dstr = newSVpvn(m, s-m);
2196         if (DO_UTF8(TARG))
2197             SvUTF8_on(dstr);
2198         PL_curpm = pm;
2199         if (!c) {
2200             register PERL_CONTEXT *cx;
2201             SPAGAIN;
2202             ReREFCNT_inc(rx);
2203             PUSHSUBST(cx);
2204             RETURNOP(cPMOP->op_pmreplroot);
2205         }
2206         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2207         do {
2208             if (iters++ > maxiters)
2209                 DIE(aTHX_ "Substitution loop");
2210             rxtainted |= RX_MATCH_TAINTED(rx);
2211             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2212                 m = s;
2213                 s = orig;
2214                 orig = rx->subbeg;
2215                 s = orig + (m - s);
2216                 strend = s + (strend - m);
2217             }
2218             m = rx->startp[0] + orig;
2219             if (doutf8 && !SvUTF8(dstr))
2220                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2221             else
2222                 sv_catpvn(dstr, s, m-s);
2223             s = rx->endp[0] + orig;
2224             if (clen)
2225                 sv_catpvn(dstr, c, clen);
2226             if (once)
2227                 break;
2228         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2229                              TARG, NULL, r_flags));
2230         if (doutf8 && !DO_UTF8(TARG))
2231             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2232         else
2233             sv_catpvn(dstr, s, strend - s);
2234
2235 #ifdef PERL_OLD_COPY_ON_WRITE
2236         /* The match may make the string COW. If so, brilliant, because that's
2237            just saved us one malloc, copy and free - the regexp has donated
2238            the old buffer, and we malloc an entirely new one, rather than the
2239            regexp malloc()ing a buffer and copying our original, only for
2240            us to throw it away here during the substitution.  */
2241         if (SvIsCOW(TARG)) {
2242             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2243         } else
2244 #endif
2245         {
2246             SvPV_free(TARG);
2247         }
2248         SvPV_set(TARG, SvPVX(dstr));
2249         SvCUR_set(TARG, SvCUR(dstr));
2250         SvLEN_set(TARG, SvLEN(dstr));
2251         doutf8 |= DO_UTF8(dstr);
2252         SvPV_set(dstr, (char*)0);
2253         sv_free(dstr);
2254
2255         TAINT_IF(rxtainted & 1);
2256         SPAGAIN;
2257         PUSHs(sv_2mortal(newSViv((I32)iters)));
2258
2259         (void)SvPOK_only(TARG);
2260         if (doutf8)
2261             SvUTF8_on(TARG);
2262         TAINT_IF(rxtainted);
2263         SvSETMAGIC(TARG);
2264         SvTAINT(TARG);
2265         LEAVE_SCOPE(oldsave);
2266         RETURN;
2267     }
2268     goto ret_no;
2269
2270 nope:
2271 ret_no:
2272     SPAGAIN;
2273     PUSHs(&PL_sv_no);
2274     LEAVE_SCOPE(oldsave);
2275     RETURN;
2276 }
2277
2278 PP(pp_grepwhile)
2279 {
2280     dVAR; dSP;
2281
2282     if (SvTRUEx(POPs))
2283         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2284     ++*PL_markstack_ptr;
2285     LEAVE;                                      /* exit inner scope */
2286
2287     /* All done yet? */
2288     if (PL_stack_base + *PL_markstack_ptr > SP) {
2289         I32 items;
2290         I32 gimme = GIMME_V;
2291
2292         LEAVE;                                  /* exit outer scope */
2293         (void)POPMARK;                          /* pop src */
2294         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2295         (void)POPMARK;                          /* pop dst */
2296         SP = PL_stack_base + POPMARK;           /* pop original mark */
2297         if (gimme == G_SCALAR) {
2298             if (PL_op->op_private & OPpGREP_LEX) {
2299                 SV* sv = sv_newmortal();
2300                 sv_setiv(sv, items);
2301                 PUSHs(sv);
2302             }
2303             else {
2304                 dTARGET;
2305                 XPUSHi(items);
2306             }
2307         }
2308         else if (gimme == G_ARRAY)
2309             SP += items;
2310         RETURN;
2311     }
2312     else {
2313         SV *src;
2314
2315         ENTER;                                  /* enter inner scope */
2316         SAVEVPTR(PL_curpm);
2317
2318         src = PL_stack_base[*PL_markstack_ptr];
2319         SvTEMP_off(src);
2320         if (PL_op->op_private & OPpGREP_LEX)
2321             PAD_SVl(PL_op->op_targ) = src;
2322         else
2323             DEFSV = src;
2324
2325         RETURNOP(cLOGOP->op_other);
2326     }
2327 }
2328
2329 PP(pp_leavesub)
2330 {
2331     dVAR; dSP;
2332     SV **mark;
2333     SV **newsp;
2334     PMOP *newpm;
2335     I32 gimme;
2336     register PERL_CONTEXT *cx;
2337     SV *sv;
2338
2339     POPBLOCK(cx,newpm);
2340     cxstack_ix++; /* temporarily protect top context */
2341
2342     TAINT_NOT;
2343     if (gimme == G_SCALAR) {
2344         MARK = newsp + 1;
2345         if (MARK <= SP) {
2346             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2347                 if (SvTEMP(TOPs)) {
2348                     *MARK = SvREFCNT_inc(TOPs);
2349                     FREETMPS;
2350                     sv_2mortal(*MARK);
2351                 }
2352                 else {
2353                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2354                     FREETMPS;
2355                     *MARK = sv_mortalcopy(sv);
2356                     SvREFCNT_dec(sv);
2357                 }
2358             }
2359             else
2360                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2361         }
2362         else {
2363             MEXTEND(MARK, 0);
2364             *MARK = &PL_sv_undef;
2365         }
2366         SP = MARK;
2367     }
2368     else if (gimme == G_ARRAY) {
2369         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2370             if (!SvTEMP(*MARK)) {
2371                 *MARK = sv_mortalcopy(*MARK);
2372                 TAINT_NOT;      /* Each item is independent */
2373             }
2374         }
2375     }
2376     PUTBACK;
2377
2378     LEAVE;
2379     cxstack_ix--;
2380     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2381     PL_curpm = newpm;   /* ... and pop $1 et al */
2382
2383     LEAVESUB(sv);
2384     return cx->blk_sub.retop;
2385 }
2386
2387 /* This duplicates the above code because the above code must not
2388  * get any slower by more conditions */
2389 PP(pp_leavesublv)
2390 {
2391     dVAR; dSP;
2392     SV **mark;
2393     SV **newsp;
2394     PMOP *newpm;
2395     I32 gimme;
2396     register PERL_CONTEXT *cx;
2397     SV *sv;
2398
2399     POPBLOCK(cx,newpm);
2400     cxstack_ix++; /* temporarily protect top context */
2401
2402     TAINT_NOT;
2403
2404     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2405         /* We are an argument to a function or grep().
2406          * This kind of lvalueness was legal before lvalue
2407          * subroutines too, so be backward compatible:
2408          * cannot report errors.  */
2409
2410         /* Scalar context *is* possible, on the LHS of -> only,
2411          * as in f()->meth().  But this is not an lvalue. */
2412         if (gimme == G_SCALAR)
2413             goto temporise;
2414         if (gimme == G_ARRAY) {
2415             if (!CvLVALUE(cx->blk_sub.cv))
2416                 goto temporise_array;
2417             EXTEND_MORTAL(SP - newsp);
2418             for (mark = newsp + 1; mark <= SP; mark++) {
2419                 if (SvTEMP(*mark))
2420                     /* empty */ ;
2421                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2422                     *mark = sv_mortalcopy(*mark);
2423                 else {
2424                     /* Can be a localized value subject to deletion. */
2425                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2426                     (void)SvREFCNT_inc(*mark);
2427                 }
2428             }
2429         }
2430     }
2431     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2432         /* Here we go for robustness, not for speed, so we change all
2433          * the refcounts so the caller gets a live guy. Cannot set
2434          * TEMP, so sv_2mortal is out of question. */
2435         if (!CvLVALUE(cx->blk_sub.cv)) {
2436             LEAVE;
2437             cxstack_ix--;
2438             POPSUB(cx,sv);
2439             PL_curpm = newpm;
2440             LEAVESUB(sv);
2441             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2442         }
2443         if (gimme == G_SCALAR) {
2444             MARK = newsp + 1;
2445             EXTEND_MORTAL(1);
2446             if (MARK == SP) {
2447                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2448                     LEAVE;
2449                     cxstack_ix--;
2450                     POPSUB(cx,sv);
2451                     PL_curpm = newpm;
2452                     LEAVESUB(sv);
2453                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2454                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2455                         : "a readonly value" : "a temporary");
2456                 }
2457                 else {                  /* Can be a localized value
2458                                          * subject to deletion. */
2459                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2460                     (void)SvREFCNT_inc(*mark);
2461                 }
2462             }
2463             else {                      /* Should not happen? */
2464                 LEAVE;
2465                 cxstack_ix--;
2466                 POPSUB(cx,sv);
2467                 PL_curpm = newpm;
2468                 LEAVESUB(sv);
2469                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2470                     (MARK > SP ? "Empty array" : "Array"));
2471             }
2472             SP = MARK;
2473         }
2474         else if (gimme == G_ARRAY) {
2475             EXTEND_MORTAL(SP - newsp);
2476             for (mark = newsp + 1; mark <= SP; mark++) {
2477                 if (*mark != &PL_sv_undef
2478                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2479                     /* Might be flattened array after $#array =  */
2480                     PUTBACK;
2481                     LEAVE;
2482                     cxstack_ix--;
2483                     POPSUB(cx,sv);
2484                     PL_curpm = newpm;
2485                     LEAVESUB(sv);
2486                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2487                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2488                 }
2489                 else {
2490                     /* Can be a localized value subject to deletion. */
2491                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2492                     (void)SvREFCNT_inc(*mark);
2493                 }
2494             }
2495         }
2496     }
2497     else {
2498         if (gimme == G_SCALAR) {
2499           temporise:
2500             MARK = newsp + 1;
2501             if (MARK <= SP) {
2502                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2503                     if (SvTEMP(TOPs)) {
2504                         *MARK = SvREFCNT_inc(TOPs);
2505                         FREETMPS;
2506                         sv_2mortal(*MARK);
2507                     }
2508                     else {
2509                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2510                         FREETMPS;
2511                         *MARK = sv_mortalcopy(sv);
2512                         SvREFCNT_dec(sv);
2513                     }
2514                 }
2515                 else
2516                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2517             }
2518             else {
2519                 MEXTEND(MARK, 0);
2520                 *MARK = &PL_sv_undef;
2521             }
2522             SP = MARK;
2523         }
2524         else if (gimme == G_ARRAY) {
2525           temporise_array:
2526             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527                 if (!SvTEMP(*MARK)) {
2528                     *MARK = sv_mortalcopy(*MARK);
2529                     TAINT_NOT;  /* Each item is independent */
2530                 }
2531             }
2532         }
2533     }
2534     PUTBACK;
2535
2536     LEAVE;
2537     cxstack_ix--;
2538     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     return cx->blk_sub.retop;
2543 }
2544
2545
2546 STATIC CV *
2547 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2548 {
2549     SV *dbsv = GvSV(PL_DBsub);
2550
2551     save_item(dbsv);
2552     if (!PERLDB_SUB_NN) {
2553         GV *gv = CvGV(cv);
2554
2555         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2556              || strEQ(GvNAME(gv), "END")
2557              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2558                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2559                     && (gv = (GV*)*svp) ))) {
2560             /* Use GV from the stack as a fallback. */
2561             /* GV is potentially non-unique, or contain different CV. */
2562             SV *tmp = newRV((SV*)cv);
2563             sv_setsv(dbsv, tmp);
2564             SvREFCNT_dec(tmp);
2565         }
2566         else {
2567             gv_efullname3(dbsv, gv, Nullch);
2568         }
2569     }
2570     else {
2571         const int type = SvTYPE(dbsv);
2572         if (type < SVt_PVIV && type != SVt_IV)
2573             sv_upgrade(dbsv, SVt_PVIV);
2574         (void)SvIOK_on(dbsv);
2575         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2576     }
2577
2578     if (CvXSUB(cv))
2579         PL_curcopdb = PL_curcop;
2580     cv = GvCV(PL_DBsub);
2581     return cv;
2582 }
2583
2584 PP(pp_entersub)
2585 {
2586     dVAR; dSP; dPOPss;
2587     GV *gv;
2588     HV *stash;
2589     register CV *cv;
2590     register PERL_CONTEXT *cx;
2591     I32 gimme;
2592     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2593
2594     if (!sv)
2595         DIE(aTHX_ "Not a CODE reference");
2596     switch (SvTYPE(sv)) {
2597         /* This is overwhelming the most common case:  */
2598     case SVt_PVGV:
2599         if (!(cv = GvCVu((GV*)sv)))
2600             cv = sv_2cv(sv, &stash, &gv, FALSE);
2601         if (!cv) {
2602             ENTER;
2603             SAVETMPS;
2604             goto try_autoload;
2605         }
2606         break;
2607     default:
2608         if (!SvROK(sv)) {
2609             const char *sym;
2610             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2611                 if (hasargs)
2612                     SP = PL_stack_base + POPMARK;
2613                 RETURN;
2614             }
2615             if (SvGMAGICAL(sv)) {
2616                 mg_get(sv);
2617                 if (SvROK(sv))
2618                     goto got_rv;
2619                 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2620             }
2621             else {
2622                 sym = SvPV_nolen_const(sv);
2623             }
2624             if (!sym)
2625                 DIE(aTHX_ PL_no_usym, "a subroutine");
2626             if (PL_op->op_private & HINT_STRICT_REFS)
2627                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2628             cv = get_cv(sym, TRUE);
2629             break;
2630         }
2631   got_rv:
2632         {
2633             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2634             tryAMAGICunDEREF(to_cv);
2635         }
2636         cv = (CV*)SvRV(sv);
2637         if (SvTYPE(cv) == SVt_PVCV)
2638             break;
2639         /* FALL THROUGH */
2640     case SVt_PVHV:
2641     case SVt_PVAV:
2642         DIE(aTHX_ "Not a CODE reference");
2643         /* This is the second most common case:  */
2644     case SVt_PVCV:
2645         cv = (CV*)sv;
2646         break;
2647     }
2648
2649     ENTER;
2650     SAVETMPS;
2651
2652   retry:
2653     if (!CvROOT(cv) && !CvXSUB(cv)) {
2654         goto fooey;
2655     }
2656
2657     gimme = GIMME_V;
2658     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2659         if (CvASSERTION(cv) && PL_DBassertion)
2660             sv_setiv(PL_DBassertion, 1);
2661
2662         cv = get_db_sub(&sv, cv);
2663         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2664             DIE(aTHX_ "No DB::sub routine defined");
2665     }
2666
2667     if (!(CvXSUB(cv))) {
2668         /* This path taken at least 75% of the time   */
2669         dMARK;
2670         register I32 items = SP - MARK;
2671         AV* padlist = CvPADLIST(cv);
2672         PUSHBLOCK(cx, CXt_SUB, MARK);
2673         PUSHSUB(cx);
2674         cx->blk_sub.retop = PL_op->op_next;
2675         CvDEPTH(cv)++;
2676         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2677          * that eval'' ops within this sub know the correct lexical space.
2678          * Owing the speed considerations, we choose instead to search for
2679          * the cv using find_runcv() when calling doeval().
2680          */
2681         if (CvDEPTH(cv) >= 2) {
2682             PERL_STACK_OVERFLOW_CHECK();
2683             pad_push(padlist, CvDEPTH(cv));
2684         }
2685         PAD_SET_CUR(padlist, CvDEPTH(cv));
2686         if (hasargs)
2687         {
2688             AV* av;
2689 #if 0
2690             DEBUG_S(PerlIO_printf(Perl_debug_log,
2691                                   "%p entersub preparing @_\n", thr));
2692 #endif
2693             av = (AV*)PAD_SVl(0);
2694             if (AvREAL(av)) {
2695                 /* @_ is normally not REAL--this should only ever
2696                  * happen when DB::sub() calls things that modify @_ */
2697                 av_clear(av);
2698                 AvREAL_off(av);
2699                 AvREIFY_on(av);
2700             }
2701             cx->blk_sub.savearray = GvAV(PL_defgv);
2702             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2703             CX_CURPAD_SAVE(cx->blk_sub);
2704             cx->blk_sub.argarray = av;
2705             ++MARK;
2706
2707             if (items > AvMAX(av) + 1) {
2708                 SV **ary = AvALLOC(av);
2709                 if (AvARRAY(av) != ary) {
2710                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2711                     SvPV_set(av, (char*)ary);
2712                 }
2713                 if (items > AvMAX(av) + 1) {
2714                     AvMAX(av) = items - 1;
2715                     Renew(ary,items,SV*);
2716                     AvALLOC(av) = ary;
2717                     SvPV_set(av, (char*)ary);
2718                 }
2719             }
2720             Copy(MARK,AvARRAY(av),items,SV*);
2721             AvFILLp(av) = items - 1;
2722
2723             while (items--) {
2724                 if (*MARK)
2725                     SvTEMP_off(*MARK);
2726                 MARK++;
2727             }
2728         }
2729         /* warning must come *after* we fully set up the context
2730          * stuff so that __WARN__ handlers can safely dounwind()
2731          * if they want to
2732          */
2733         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2734             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2735             sub_crush_depth(cv);
2736 #if 0
2737         DEBUG_S(PerlIO_printf(Perl_debug_log,
2738                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2739 #endif
2740         RETURNOP(CvSTART(cv));
2741     }
2742     else {
2743 #ifdef PERL_XSUB_OLDSTYLE
2744         if (CvOLDSTYLE(cv)) {
2745             I32 (*fp3)(int,int,int);
2746             dMARK;
2747             register I32 items = SP - MARK;
2748                                         /* We dont worry to copy from @_. */
2749             while (SP > mark) {
2750                 SP[1] = SP[0];
2751                 SP--;
2752             }
2753             PL_stack_sp = mark + 1;
2754             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2755             items = (*fp3)(CvXSUBANY(cv).any_i32,
2756                            MARK - PL_stack_base + 1,
2757                            items);
2758             PL_stack_sp = PL_stack_base + items;
2759         }
2760         else
2761 #endif /* PERL_XSUB_OLDSTYLE */
2762         {
2763             I32 markix = TOPMARK;
2764
2765             PUTBACK;
2766
2767             if (!hasargs) {
2768                 /* Need to copy @_ to stack. Alternative may be to
2769                  * switch stack to @_, and copy return values
2770                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2771                 AV * const av = GvAV(PL_defgv);
2772                 const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2773
2774                 if (items) {
2775                     /* Mark is at the end of the stack. */
2776                     EXTEND(SP, items);
2777                     Copy(AvARRAY(av), SP + 1, items, SV*);
2778                     SP += items;
2779                     PUTBACK ;
2780                 }
2781             }
2782             /* We assume first XSUB in &DB::sub is the called one. */
2783             if (PL_curcopdb) {
2784                 SAVEVPTR(PL_curcop);
2785                 PL_curcop = PL_curcopdb;
2786                 PL_curcopdb = NULL;
2787             }
2788             /* Do we need to open block here? XXXX */
2789             (void)(*CvXSUB(cv))(aTHX_ cv);
2790
2791             /* Enforce some sanity in scalar context. */
2792             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2793                 if (markix > PL_stack_sp - PL_stack_base)
2794                     *(PL_stack_base + markix) = &PL_sv_undef;
2795                 else
2796                     *(PL_stack_base + markix) = *PL_stack_sp;
2797                 PL_stack_sp = PL_stack_base + markix;
2798             }
2799         }
2800         LEAVE;
2801         return NORMAL;
2802     }
2803
2804     assert (0); /* Cannot get here.  */
2805     /* This is deliberately moved here as spaghetti code to keep it out of the
2806        hot path.  */
2807     {
2808         GV* autogv;
2809         SV* sub_name;
2810
2811       fooey:
2812         /* anonymous or undef'd function leaves us no recourse */
2813         if (CvANON(cv) || !(gv = CvGV(cv)))
2814             DIE(aTHX_ "Undefined subroutine called");
2815
2816         /* autoloaded stub? */
2817         if (cv != GvCV(gv)) {
2818             cv = GvCV(gv);
2819         }
2820         /* should call AUTOLOAD now? */
2821         else {
2822 try_autoload:
2823             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2824                                    FALSE)))
2825             {
2826                 cv = GvCV(autogv);
2827             }
2828             /* sorry */
2829             else {
2830                 sub_name = sv_newmortal();
2831                 gv_efullname3(sub_name, gv, Nullch);
2832                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2833             }
2834         }
2835         if (!cv)
2836             DIE(aTHX_ "Not a CODE reference");
2837         goto retry;
2838     }
2839 }
2840
2841 void
2842 Perl_sub_crush_depth(pTHX_ CV *cv)
2843 {
2844     if (CvANON(cv))
2845         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2846     else {
2847         SV* tmpstr = sv_newmortal();
2848         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2849         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2850                 tmpstr);
2851     }
2852 }
2853
2854 PP(pp_aelem)
2855 {
2856     dSP;
2857     SV** svp;
2858     SV* const elemsv = POPs;
2859     IV elem = SvIV(elemsv);
2860     AV* av = (AV*)POPs;
2861     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2862     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2863     SV *sv;
2864
2865     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2866         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2867     if (elem > 0)
2868         elem -= PL_curcop->cop_arybase;
2869     if (SvTYPE(av) != SVt_PVAV)
2870         RETPUSHUNDEF;
2871     svp = av_fetch(av, elem, lval && !defer);
2872     if (lval) {
2873 #ifdef PERL_MALLOC_WRAP
2874          if (SvUOK(elemsv)) {
2875               const UV uv = SvUV(elemsv);
2876               elem = uv > IV_MAX ? IV_MAX : uv;
2877          }
2878          else if (SvNOK(elemsv))
2879               elem = (IV)SvNV(elemsv);
2880          if (elem > 0) {
2881               static const char oom_array_extend[] =
2882                 "Out of memory during array extend"; /* Duplicated in av.c */
2883               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2884          }
2885 #endif
2886         if (!svp || *svp == &PL_sv_undef) {
2887             SV* lv;
2888             if (!defer)
2889                 DIE(aTHX_ PL_no_aelem, elem);
2890             lv = sv_newmortal();
2891             sv_upgrade(lv, SVt_PVLV);
2892             LvTYPE(lv) = 'y';
2893             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2894             LvTARG(lv) = SvREFCNT_inc(av);
2895             LvTARGOFF(lv) = elem;
2896             LvTARGLEN(lv) = 1;
2897             PUSHs(lv);
2898             RETURN;
2899         }
2900         if (PL_op->op_private & OPpLVAL_INTRO)
2901             save_aelem(av, elem, svp);
2902         else if (PL_op->op_private & OPpDEREF)
2903             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2904     }
2905     sv = (svp ? *svp : &PL_sv_undef);
2906     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2907         sv = sv_mortalcopy(sv);
2908     PUSHs(sv);
2909     RETURN;
2910 }
2911
2912 void
2913 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2914 {
2915     if (SvGMAGICAL(sv))
2916         mg_get(sv);
2917     if (!SvOK(sv)) {
2918         if (SvREADONLY(sv))
2919             Perl_croak(aTHX_ PL_no_modify);
2920         if (SvTYPE(sv) < SVt_RV)
2921             sv_upgrade(sv, SVt_RV);
2922         else if (SvTYPE(sv) >= SVt_PV) {
2923             SvPV_free(sv);
2924             SvLEN_set(sv, 0);
2925             SvCUR_set(sv, 0);
2926         }
2927         switch (to_what) {
2928         case OPpDEREF_SV:
2929             SvRV_set(sv, NEWSV(355,0));
2930             break;
2931         case OPpDEREF_AV:
2932             SvRV_set(sv, (SV*)newAV());
2933             break;
2934         case OPpDEREF_HV:
2935             SvRV_set(sv, (SV*)newHV());
2936             break;
2937         }
2938         SvROK_on(sv);
2939         SvSETMAGIC(sv);
2940     }
2941 }
2942
2943 PP(pp_method)
2944 {
2945     dSP;
2946     SV* sv = TOPs;
2947
2948     if (SvROK(sv)) {
2949         SV* rsv = SvRV(sv);
2950         if (SvTYPE(rsv) == SVt_PVCV) {
2951             SETs(rsv);
2952             RETURN;
2953         }
2954     }
2955
2956     SETs(method_common(sv, Null(U32*)));
2957     RETURN;
2958 }
2959
2960 PP(pp_method_named)
2961 {
2962     dSP;
2963     SV* sv = cSVOP_sv;
2964     U32 hash = SvSHARED_HASH(sv);
2965
2966     XPUSHs(method_common(sv, &hash));
2967     RETURN;
2968 }
2969
2970 STATIC SV *
2971 S_method_common(pTHX_ SV* meth, U32* hashp)
2972 {
2973     SV* sv;
2974     SV* ob;
2975     GV* gv;
2976     HV* stash;
2977     STRLEN namelen;
2978     const char* packname = 0;
2979     SV *packsv = Nullsv;
2980     STRLEN packlen;
2981     const char *name = SvPV_const(meth, namelen);
2982
2983     sv = *(PL_stack_base + TOPMARK + 1);
2984
2985     if (!sv)
2986         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2987
2988     if (SvGMAGICAL(sv))
2989         mg_get(sv);
2990     if (SvROK(sv))
2991         ob = (SV*)SvRV(sv);
2992     else {
2993         GV* iogv;
2994
2995         /* this isn't a reference */
2996         packname = Nullch;
2997
2998         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2999           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3000           if (he) {
3001             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3002             goto fetch;
3003           }
3004         }
3005
3006         if (!SvOK(sv) ||
3007             !(packname) ||
3008             !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3009             !(ob=(SV*)GvIO(iogv)))
3010         {
3011             /* this isn't the name of a filehandle either */
3012             if (!packname ||
3013                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3014                     ? !isIDFIRST_utf8((U8*)packname)
3015                     : !isIDFIRST(*packname)
3016                 ))
3017             {
3018                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3019                            SvOK(sv) ? "without a package or object reference"
3020                                     : "on an undefined value");
3021             }
3022             /* assume it's a package name */
3023             stash = gv_stashpvn(packname, packlen, FALSE);
3024             if (!stash)
3025                 packsv = sv;
3026             else {
3027                 SV* ref = newSViv(PTR2IV(stash));
3028                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3029             }
3030             goto fetch;
3031         }
3032         /* it _is_ a filehandle name -- replace with a reference */
3033         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3034     }
3035
3036     /* if we got here, ob should be a reference or a glob */
3037     if (!ob || !(SvOBJECT(ob)
3038                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3039                      && SvOBJECT(ob))))
3040     {
3041         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3042                    name);
3043     }
3044
3045     stash = SvSTASH(ob);
3046
3047   fetch:
3048     /* NOTE: stash may be null, hope hv_fetch_ent and
3049        gv_fetchmethod can cope (it seems they can) */
3050
3051     /* shortcut for simple names */
3052     if (hashp) {
3053         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3054         if (he) {
3055             gv = (GV*)HeVAL(he);
3056             if (isGV(gv) && GvCV(gv) &&
3057                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3058                 return (SV*)GvCV(gv);
3059         }
3060     }
3061
3062     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3063
3064     if (!gv) {
3065         /* This code tries to figure out just what went wrong with
3066            gv_fetchmethod.  It therefore needs to duplicate a lot of
3067            the internals of that function.  We can't move it inside
3068            Perl_gv_fetchmethod_autoload(), however, since that would
3069            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3070            don't want that.
3071         */
3072         const char* leaf = name;
3073         const char* sep = Nullch;
3074         const char* p;
3075
3076         for (p = name; *p; p++) {
3077             if (*p == '\'')
3078                 sep = p, leaf = p + 1;
3079             else if (*p == ':' && *(p + 1) == ':')
3080                 sep = p, leaf = p + 2;
3081         }
3082         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3083             /* the method name is unqualified or starts with SUPER:: */
3084             bool need_strlen = 1;
3085             if (sep) {
3086                 packname = CopSTASHPV(PL_curcop);
3087             }
3088             else if (stash) {
3089                 HEK *packhek = HvNAME_HEK(stash);
3090                 if (packhek) {
3091                     packname = HEK_KEY(packhek);
3092                     packlen = HEK_LEN(packhek);
3093                     need_strlen = 0;
3094                 } else {
3095                     goto croak;
3096                 }
3097             }
3098
3099             if (!packname) {
3100             croak:
3101                 Perl_croak(aTHX_
3102                            "Can't use anonymous symbol table for method lookup");
3103             }
3104             else if (need_strlen)
3105                 packlen = strlen(packname);
3106
3107         }
3108         else {
3109             /* the method name is qualified */
3110             packname = name;
3111             packlen = sep - name;
3112         }
3113
3114         /* we're relying on gv_fetchmethod not autovivifying the stash */
3115         if (gv_stashpvn(packname, packlen, FALSE)) {
3116             Perl_croak(aTHX_
3117                        "Can't locate object method \"%s\" via package \"%.*s\"",
3118                        leaf, (int)packlen, packname);
3119         }
3120         else {
3121             Perl_croak(aTHX_
3122                        "Can't locate object method \"%s\" via package \"%.*s\""
3123                        " (perhaps you forgot to load \"%.*s\"?)",
3124                        leaf, (int)packlen, packname, (int)packlen, packname);
3125         }
3126     }
3127     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3128 }
3129
3130 /*
3131  * Local variables:
3132  * c-indentation-style: bsd
3133  * c-basic-offset: 4
3134  * indent-tabs-mode: t
3135  * End:
3136  *
3137  * ex: set ts=8 sts=4 sw=4 noet:
3138  */