pp_hot.c

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