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             (void)SvOK_off(TARG);
1470             PUSHTARG;
1471         }
1472         RETURN;
1473     }
1474   have_fp:
1475     if (gimme == G_SCALAR) {
1476         sv = TARG;
1477         if (SvROK(sv))
1478             sv_unref(sv);
1479         (void)SvUPGRADE(sv, SVt_PV);
1480         tmplen = SvLEN(sv);     /* remember if already alloced */
1481         if (!tmplen)
1482             Sv_Grow(sv, 80);    /* try short-buffering it */
1483         offset = 0;
1484         if (type == OP_RCATLINE && SvOK(sv)) {
1485             if (!SvPOK(sv)) {
1486                 STRLEN n_a;
1487                 (void)SvPV_force(sv, n_a);
1488             }
1489             offset = SvCUR(sv);
1490         }
1491     }
1492     else {
1493         sv = sv_2mortal(NEWSV(57, 80));
1494         offset = 0;
1495     }
1496
1497     /* This should not be marked tainted if the fp is marked clean */
1498 #define MAYBE_TAINT_LINE(io, sv) \
1499     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1500         TAINT;                          \
1501         SvTAINTED_on(sv);               \
1502     }
1503
1504 /* delay EOF state for a snarfed empty file */
1505 #define SNARF_EOF(gimme,rs,io,sv) \
1506     (gimme != G_SCALAR || SvCUR(sv)                                     \
1507      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1508
1509     for (;;) {
1510         PUTBACK;
1511         if (!sv_gets(sv, fp, offset)
1512             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1513         {
1514             PerlIO_clearerr(fp);
1515             if (IoFLAGS(io) & IOf_ARGV) {
1516                 fp = nextargv(PL_last_in_gv);
1517                 if (fp)
1518                     continue;
1519                 (void)do_close(PL_last_in_gv, FALSE);
1520             }
1521             else if (type == OP_GLOB) {
1522                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1523                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1524                            "glob failed (child exited with status %d%s)",
1525                            (int)(STATUS_CURRENT >> 8),
1526                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1527                 }
1528             }
1529             if (gimme == G_SCALAR) {
1530                 (void)SvOK_off(TARG);
1531                 SPAGAIN;
1532                 PUSHTARG;
1533             }
1534             MAYBE_TAINT_LINE(io, sv);
1535             RETURN;
1536         }
1537         MAYBE_TAINT_LINE(io, sv);
1538         IoLINES(io)++;
1539         IoFLAGS(io) |= IOf_NOLINE;
1540         SvSETMAGIC(sv);
1541         SPAGAIN;
1542         XPUSHs(sv);
1543         if (type == OP_GLOB) {
1544             char *tmps;
1545
1546             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1547                 tmps = SvEND(sv) - 1;
1548                 if (*tmps == *SvPVX(PL_rs)) {
1549                     *tmps = '\0';
1550                     SvCUR(sv)--;
1551                 }
1552             }
1553             for (tmps = SvPVX(sv); *tmps; tmps++)
1554                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1555                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1556                         break;
1557             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1558                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1559                 continue;
1560             }
1561         }
1562         if (gimme == G_ARRAY) {
1563             if (SvLEN(sv) - SvCUR(sv) > 20) {
1564                 SvLEN_set(sv, SvCUR(sv)+1);
1565                 Renew(SvPVX(sv), SvLEN(sv), char);
1566             }
1567             sv = sv_2mortal(NEWSV(58, 80));
1568             continue;
1569         }
1570         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1571             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1572             if (SvCUR(sv) < 60)
1573                 SvLEN_set(sv, 80);
1574             else
1575                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1576             Renew(SvPVX(sv), SvLEN(sv), char);
1577         }
1578         RETURN;
1579     }
1580 }
1581
1582 PP(pp_enter)
1583 {
1584     dSP;
1585     register PERL_CONTEXT *cx;
1586     I32 gimme = OP_GIMME(PL_op, -1);
1587
1588     if (gimme == -1) {
1589         if (cxstack_ix >= 0)
1590             gimme = cxstack[cxstack_ix].blk_gimme;
1591         else
1592             gimme = G_SCALAR;
1593     }
1594
1595     ENTER;
1596
1597     SAVETMPS;
1598     PUSHBLOCK(cx, CXt_BLOCK, SP);
1599
1600     RETURN;
1601 }
1602
1603 PP(pp_helem)
1604 {
1605     dSP;
1606     HE* he;
1607     SV **svp;
1608     SV *keysv = POPs;
1609     HV *hv = (HV*)POPs;
1610     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1611     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1612     SV *sv;
1613 #ifdef PERL_COPY_ON_WRITE
1614     U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1615 #else
1616     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1617 #endif
1618     I32 preeminent = 0;
1619
1620     if (SvTYPE(hv) == SVt_PVHV) {
1621         if (PL_op->op_private & OPpLVAL_INTRO) {
1622             MAGIC *mg;
1623             HV *stash;
1624             /* does the element we're localizing already exist? */
1625             preeminent =
1626                 /* can we determine whether it exists? */
1627                 (    !SvRMAGICAL(hv)
1628                   || mg_find((SV*)hv, PERL_MAGIC_env)
1629                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1630                         /* Try to preserve the existenceness of a tied hash
1631                          * element by using EXISTS and DELETE if possible.
1632                          * Fallback to FETCH and STORE otherwise */
1633                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1634                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1635                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1636                     )
1637                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1638
1639         }
1640         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1641         svp = he ? &HeVAL(he) : 0;
1642     }
1643     else {
1644         RETPUSHUNDEF;
1645     }
1646     if (lval) {
1647         if (!svp || *svp == &PL_sv_undef) {
1648             SV* lv;
1649             SV* key2;
1650             if (!defer) {
1651                 STRLEN n_a;
1652                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1653             }
1654             lv = sv_newmortal();
1655             sv_upgrade(lv, SVt_PVLV);
1656             LvTYPE(lv) = 'y';
1657             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1658             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1659             LvTARG(lv) = SvREFCNT_inc(hv);
1660             LvTARGLEN(lv) = 1;
1661             PUSHs(lv);
1662             RETURN;
1663         }
1664         if (PL_op->op_private & OPpLVAL_INTRO) {
1665             if (HvNAME(hv) && isGV(*svp))
1666                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1667             else {
1668                 if (!preeminent) {
1669                     STRLEN keylen;
1670                     char *key = SvPV(keysv, keylen);
1671                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1672                 } else
1673                     save_helem(hv, keysv, svp);
1674             }
1675         }
1676         else if (PL_op->op_private & OPpDEREF)
1677             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1678     }
1679     sv = (svp ? *svp : &PL_sv_undef);
1680     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1681      * Pushing the magical RHS on to the stack is useless, since
1682      * that magic is soon destined to be misled by the local(),
1683      * and thus the later pp_sassign() will fail to mg_get() the
1684      * old value.  This should also cure problems with delayed
1685      * mg_get()s.  GSAR 98-07-03 */
1686     if (!lval && SvGMAGICAL(sv))
1687         sv = sv_mortalcopy(sv);
1688     PUSHs(sv);
1689     RETURN;
1690 }
1691
1692 PP(pp_leave)
1693 {
1694     dSP;
1695     register PERL_CONTEXT *cx;
1696     register SV **mark;
1697     SV **newsp;
1698     PMOP *newpm;
1699     I32 gimme;
1700
1701     if (PL_op->op_flags & OPf_SPECIAL) {
1702         cx = &cxstack[cxstack_ix];
1703         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1704     }
1705
1706     POPBLOCK(cx,newpm);
1707
1708     gimme = OP_GIMME(PL_op, -1);
1709     if (gimme == -1) {
1710         if (cxstack_ix >= 0)
1711             gimme = cxstack[cxstack_ix].blk_gimme;
1712         else
1713             gimme = G_SCALAR;
1714     }
1715
1716     TAINT_NOT;
1717     if (gimme == G_VOID)
1718         SP = newsp;
1719     else if (gimme == G_SCALAR) {
1720         MARK = newsp + 1;
1721         if (MARK <= SP) {
1722             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1723                 *MARK = TOPs;
1724             else
1725                 *MARK = sv_mortalcopy(TOPs);
1726         } else {
1727             MEXTEND(mark,0);
1728             *MARK = &PL_sv_undef;
1729         }
1730         SP = MARK;
1731     }
1732     else if (gimme == G_ARRAY) {
1733         /* in case LEAVE wipes old return values */
1734         for (mark = newsp + 1; mark <= SP; mark++) {
1735             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1736                 *mark = sv_mortalcopy(*mark);
1737                 TAINT_NOT;      /* Each item is independent */
1738             }
1739         }
1740     }
1741     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1742
1743     LEAVE;
1744
1745     RETURN;
1746 }
1747
1748 PP(pp_iter)
1749 {
1750     dSP;
1751     register PERL_CONTEXT *cx;
1752     SV* sv;
1753     AV* av;
1754     SV **itersvp;
1755
1756     EXTEND(SP, 1);
1757     cx = &cxstack[cxstack_ix];
1758     if (CxTYPE(cx) != CXt_LOOP)
1759         DIE(aTHX_ "panic: pp_iter");
1760
1761     itersvp = CxITERVAR(cx);
1762     av = cx->blk_loop.iterary;
1763     if (SvTYPE(av) != SVt_PVAV) {
1764         /* iterate ($min .. $max) */
1765         if (cx->blk_loop.iterlval) {
1766             /* string increment */
1767             register SV* cur = cx->blk_loop.iterlval;
1768             STRLEN maxlen;
1769             char *max = SvPV((SV*)av, maxlen);
1770             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1771                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1772                     /* safe to reuse old SV */
1773                     sv_setsv(*itersvp, cur);
1774                 }
1775                 else
1776                 {
1777                     /* we need a fresh SV every time so that loop body sees a
1778                      * completely new SV for closures/references to work as
1779                      * they used to */
1780                     SvREFCNT_dec(*itersvp);
1781                     *itersvp = newSVsv(cur);
1782                 }
1783                 if (strEQ(SvPVX(cur), max))
1784                     sv_setiv(cur, 0); /* terminate next time */
1785                 else
1786                     sv_inc(cur);
1787                 RETPUSHYES;
1788             }
1789             RETPUSHNO;
1790         }
1791         /* integer increment */
1792         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1793             RETPUSHNO;
1794
1795         /* don't risk potential race */
1796         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1797             /* safe to reuse old SV */
1798             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1799         }
1800         else
1801         {
1802             /* we need a fresh SV every time so that loop body sees a
1803              * completely new SV for closures/references to work as they
1804              * used to */
1805             SvREFCNT_dec(*itersvp);
1806             *itersvp = newSViv(cx->blk_loop.iterix++);
1807         }
1808         RETPUSHYES;
1809     }
1810
1811     /* iterate array */
1812     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1813         RETPUSHNO;
1814
1815     SvREFCNT_dec(*itersvp);
1816
1817     if (SvMAGICAL(av) || AvREIFY(av)) {
1818         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1819         if (svp)
1820             sv = *svp;
1821         else
1822             sv = Nullsv;
1823     }
1824     else {
1825         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1826     }
1827     if (sv)
1828         SvTEMP_off(sv);
1829     else
1830         sv = &PL_sv_undef;
1831     if (av != PL_curstack && sv == &PL_sv_undef) {
1832         SV *lv = cx->blk_loop.iterlval;
1833         if (lv && SvREFCNT(lv) > 1) {
1834             SvREFCNT_dec(lv);
1835             lv = Nullsv;
1836         }
1837         if (lv)
1838             SvREFCNT_dec(LvTARG(lv));
1839         else {
1840             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1841             sv_upgrade(lv, SVt_PVLV);
1842             LvTYPE(lv) = 'y';
1843             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1844         }
1845         LvTARG(lv) = SvREFCNT_inc(av);
1846         LvTARGOFF(lv) = cx->blk_loop.iterix;
1847         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1848         sv = (SV*)lv;
1849     }
1850
1851     *itersvp = SvREFCNT_inc(sv);
1852     RETPUSHYES;
1853 }
1854
1855 PP(pp_subst)
1856 {
1857     dSP; dTARG;
1858     register PMOP *pm = cPMOP;
1859     PMOP *rpm = pm;
1860     register SV *dstr;
1861     register char *s;
1862     char *strend;
1863     register char *m;
1864     char *c;
1865     register char *d;
1866     STRLEN clen;
1867     I32 iters = 0;
1868     I32 maxiters;
1869     register I32 i;
1870     bool once;
1871     bool rxtainted;
1872     char *orig;
1873     I32 r_flags;
1874     register REGEXP *rx = PM_GETRE(pm);
1875     STRLEN len;
1876     int force_on_match = 0;
1877     I32 oldsave = PL_savestack_ix;
1878     STRLEN slen;
1879     bool doutf8 = FALSE;
1880
1881     /* known replacement string? */
1882     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1883     if (PL_op->op_flags & OPf_STACKED)
1884         TARG = POPs;
1885     else {
1886         TARG = DEFSV;
1887         EXTEND(SP,1);
1888     }
1889
1890     if (SvIsCOW(TARG))
1891         sv_force_normal_flags(TARG,0);
1892     if (SvREADONLY(TARG)
1893         || (SvTYPE(TARG) > SVt_PVLV
1894             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1895         DIE(aTHX_ PL_no_modify);
1896     PUTBACK;
1897
1898     s = SvPV(TARG, len);
1899     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1900         force_on_match = 1;
1901     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1902                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1903     if (PL_tainted)
1904         rxtainted |= 2;
1905     TAINT_NOT;
1906
1907     PL_reg_match_utf8 = DO_UTF8(TARG);
1908
1909   force_it:
1910     if (!pm || !s)
1911         DIE(aTHX_ "panic: pp_subst");
1912
1913     strend = s + len;
1914     slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1915     maxiters = 2 * slen + 10;   /* We can match twice at each
1916                                    position, once with zero-length,
1917                                    second time with non-zero. */
1918
1919     if (!rx->prelen && PL_curpm) {
1920         pm = PL_curpm;
1921         rx = PM_GETRE(pm);
1922     }
1923     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1924                 ? REXEC_COPY_STR : 0;
1925     if (SvSCREAM(TARG))
1926         r_flags |= REXEC_SCREAM;
1927     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1928         SAVEINT(PL_multiline);
1929         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1930     }
1931     orig = m = s;
1932     if (rx->reganch & RE_USE_INTUIT) {
1933         PL_bostr = orig;
1934         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1935
1936         if (!s)
1937             goto nope;
1938         /* How to do it in subst? */
1939 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1940              && !PL_sawampersand
1941              && ((rx->reganch & ROPT_NOSCAN)
1942                  || !((rx->reganch & RE_INTUIT_TAIL)
1943                       && (r_flags & REXEC_SCREAM))))
1944             goto yup;
1945 */
1946     }
1947
1948     /* only replace once? */
1949     once = !(rpm->op_pmflags & PMf_GLOBAL);
1950
1951     /* known replacement string? */
1952     if (dstr) {
1953         /* replacement needing upgrading? */
1954         if (DO_UTF8(TARG) && !doutf8) {
1955              SV *nsv = sv_newmortal();
1956              SvSetSV(nsv, dstr);
1957              if (PL_encoding)
1958                   sv_recode_to_utf8(nsv, PL_encoding);
1959              else
1960                   sv_utf8_upgrade(nsv);
1961              c = SvPV(nsv, clen);
1962              doutf8 = TRUE;
1963         }
1964         else {
1965             c = SvPV(dstr, clen);
1966             doutf8 = DO_UTF8(dstr);
1967         }
1968     }
1969     else {
1970         c = Nullch;
1971         doutf8 = FALSE;
1972     }
1973
1974     /* can do inplace substitution? */
1975     if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1976         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1977         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1978                          r_flags | REXEC_CHECKED))
1979         {
1980             SPAGAIN;
1981             PUSHs(&PL_sv_no);
1982             LEAVE_SCOPE(oldsave);
1983             RETURN;
1984         }
1985         if (force_on_match) {
1986             force_on_match = 0;
1987             s = SvPV_force(TARG, len);
1988             goto force_it;
1989         }
1990         d = s;
1991         PL_curpm = pm;
1992         SvSCREAM_off(TARG);     /* disable possible screamer */
1993         if (once) {
1994             rxtainted |= RX_MATCH_TAINTED(rx);
1995             m = orig + rx->startp[0];
1996             d = orig + rx->endp[0];
1997             s = orig;
1998             if (m - s > strend - d) {  /* faster to shorten from end */
1999                 if (clen) {
2000                     Copy(c, m, clen, char);
2001                     m += clen;
2002                 }
2003                 i = strend - d;
2004                 if (i > 0) {
2005                     Move(d, m, i, char);
2006                     m += i;
2007                 }
2008                 *m = '\0';
2009                 SvCUR_set(TARG, m - s);
2010             }
2011             /*SUPPRESS 560*/
2012             else if ((i = m - s)) {     /* faster from front */
2013                 d -= clen;
2014                 m = d;
2015                 sv_chop(TARG, d-i);
2016                 s += i;
2017                 while (i--)
2018                     *--d = *--s;
2019                 if (clen)
2020                     Copy(c, m, clen, char);
2021             }
2022             else if (clen) {
2023                 d -= clen;
2024                 sv_chop(TARG, d);
2025                 Copy(c, d, clen, char);
2026             }
2027             else {
2028                 sv_chop(TARG, d);
2029             }
2030             TAINT_IF(rxtainted & 1);
2031             SPAGAIN;
2032             PUSHs(&PL_sv_yes);
2033         }
2034         else {
2035             do {
2036                 if (iters++ > maxiters)
2037                     DIE(aTHX_ "Substitution loop");
2038                 rxtainted |= RX_MATCH_TAINTED(rx);
2039                 m = rx->startp[0] + orig;
2040                 /*SUPPRESS 560*/
2041                 if ((i = m - s)) {
2042                     if (s != d)
2043                         Move(s, d, i, char);
2044                     d += i;
2045                 }
2046                 if (clen) {
2047                     Copy(c, d, clen, char);
2048                     d += clen;
2049                 }
2050                 s = rx->endp[0] + orig;
2051             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2052                                  TARG, NULL,
2053                                  /* don't match same null twice */
2054                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2055             if (s != d) {
2056                 i = strend - s;
2057                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2058                 Move(s, d, i+1, char);          /* include the NUL */
2059             }
2060             TAINT_IF(rxtainted & 1);
2061             SPAGAIN;
2062             PUSHs(sv_2mortal(newSViv((I32)iters)));
2063         }
2064         (void)SvPOK_only_UTF8(TARG);
2065         TAINT_IF(rxtainted);
2066         if (SvSMAGICAL(TARG)) {
2067             PUTBACK;
2068             mg_set(TARG);
2069             SPAGAIN;
2070         }
2071         SvTAINT(TARG);
2072         if (doutf8)
2073             SvUTF8_on(TARG);
2074         LEAVE_SCOPE(oldsave);
2075         RETURN;
2076     }
2077
2078     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079                     r_flags | REXEC_CHECKED))
2080     {
2081         if (force_on_match) {
2082             force_on_match = 0;
2083             s = SvPV_force(TARG, len);
2084             goto force_it;
2085         }
2086         rxtainted |= RX_MATCH_TAINTED(rx);
2087         dstr = NEWSV(25, len);
2088         sv_setpvn(dstr, m, s-m);
2089         if (DO_UTF8(TARG))
2090             SvUTF8_on(dstr);
2091         PL_curpm = pm;
2092         if (!c) {
2093             register PERL_CONTEXT *cx;
2094             SPAGAIN;
2095             PUSHSUBST(cx);
2096             RETURNOP(cPMOP->op_pmreplroot);
2097         }
2098         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2099         do {
2100             if (iters++ > maxiters)
2101                 DIE(aTHX_ "Substitution loop");
2102             rxtainted |= RX_MATCH_TAINTED(rx);
2103             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2104                 m = s;
2105                 s = orig;
2106                 orig = rx->subbeg;
2107                 s = orig + (m - s);
2108                 strend = s + (strend - m);
2109             }
2110             m = rx->startp[0] + orig;
2111             sv_catpvn(dstr, s, m-s);
2112             s = rx->endp[0] + orig;
2113             if (clen)
2114                 sv_catpvn(dstr, c, clen);
2115             if (once)
2116                 break;
2117         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2118                              TARG, NULL, r_flags));
2119         if (doutf8 && !DO_UTF8(dstr)) {
2120             SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2121
2122             sv_utf8_upgrade(nsv);
2123             sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2124         }
2125         else
2126             sv_catpvn(dstr, s, strend - s);
2127
2128         (void)SvOOK_off(TARG);
2129         Safefree(SvPVX(TARG));
2130         SvPVX(TARG) = SvPVX(dstr);
2131         SvCUR_set(TARG, SvCUR(dstr));
2132         SvLEN_set(TARG, SvLEN(dstr));
2133         doutf8 |= DO_UTF8(dstr);
2134         SvPVX(dstr) = 0;
2135         sv_free(dstr);
2136
2137         TAINT_IF(rxtainted & 1);
2138         SPAGAIN;
2139         PUSHs(sv_2mortal(newSViv((I32)iters)));
2140
2141         (void)SvPOK_only(TARG);
2142         if (doutf8)
2143             SvUTF8_on(TARG);
2144         TAINT_IF(rxtainted);
2145         SvSETMAGIC(TARG);
2146         SvTAINT(TARG);
2147         LEAVE_SCOPE(oldsave);
2148         RETURN;
2149     }
2150     goto ret_no;
2151
2152 nope:
2153 ret_no:
2154     SPAGAIN;
2155     PUSHs(&PL_sv_no);
2156     LEAVE_SCOPE(oldsave);
2157     RETURN;
2158 }
2159
2160 PP(pp_grepwhile)
2161 {
2162     dSP;
2163
2164     if (SvTRUEx(POPs))
2165         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2166     ++*PL_markstack_ptr;
2167     LEAVE;                                      /* exit inner scope */
2168
2169     /* All done yet? */
2170     if (PL_stack_base + *PL_markstack_ptr > SP) {
2171         I32 items;
2172         I32 gimme = GIMME_V;
2173
2174         LEAVE;                                  /* exit outer scope */
2175         (void)POPMARK;                          /* pop src */
2176         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2177         (void)POPMARK;                          /* pop dst */
2178         SP = PL_stack_base + POPMARK;           /* pop original mark */
2179         if (gimme == G_SCALAR) {
2180             dTARGET;
2181             XPUSHi(items);
2182         }
2183         else if (gimme == G_ARRAY)
2184             SP += items;
2185         RETURN;
2186     }
2187     else {
2188         SV *src;
2189
2190         ENTER;                                  /* enter inner scope */
2191         SAVEVPTR(PL_curpm);
2192
2193         src = PL_stack_base[*PL_markstack_ptr];
2194         SvTEMP_off(src);
2195         DEFSV = src;
2196
2197         RETURNOP(cLOGOP->op_other);
2198     }
2199 }
2200
2201 PP(pp_leavesub)
2202 {
2203     dSP;
2204     SV **mark;
2205     SV **newsp;
2206     PMOP *newpm;
2207     I32 gimme;
2208     register PERL_CONTEXT *cx;
2209     SV *sv;
2210
2211     POPBLOCK(cx,newpm);
2212
2213     TAINT_NOT;
2214     if (gimme == G_SCALAR) {
2215         MARK = newsp + 1;
2216         if (MARK <= SP) {
2217             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2218                 if (SvTEMP(TOPs)) {
2219                     *MARK = SvREFCNT_inc(TOPs);
2220                     FREETMPS;
2221                     sv_2mortal(*MARK);
2222                 }
2223                 else {
2224                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2225                     FREETMPS;
2226                     *MARK = sv_mortalcopy(sv);
2227                     SvREFCNT_dec(sv);
2228                 }
2229             }
2230             else
2231                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2232         }
2233         else {
2234             MEXTEND(MARK, 0);
2235             *MARK = &PL_sv_undef;
2236         }
2237         SP = MARK;
2238     }
2239     else if (gimme == G_ARRAY) {
2240         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2241             if (!SvTEMP(*MARK)) {
2242                 *MARK = sv_mortalcopy(*MARK);
2243                 TAINT_NOT;      /* Each item is independent */
2244             }
2245         }
2246     }
2247     PUTBACK;
2248
2249     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2250     PL_curpm = newpm;   /* ... and pop $1 et al */
2251
2252     LEAVE;
2253     LEAVESUB(sv);
2254     return pop_return();
2255 }
2256
2257 /* This duplicates the above code because the above code must not
2258  * get any slower by more conditions */
2259 PP(pp_leavesublv)
2260 {
2261     dSP;
2262     SV **mark;
2263     SV **newsp;
2264     PMOP *newpm;
2265     I32 gimme;
2266     register PERL_CONTEXT *cx;
2267     SV *sv;
2268
2269     POPBLOCK(cx,newpm);
2270
2271     TAINT_NOT;
2272
2273     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2274         /* We are an argument to a function or grep().
2275          * This kind of lvalueness was legal before lvalue
2276          * subroutines too, so be backward compatible:
2277          * cannot report errors.  */
2278
2279         /* Scalar context *is* possible, on the LHS of -> only,
2280          * as in f()->meth().  But this is not an lvalue. */
2281         if (gimme == G_SCALAR)
2282             goto temporise;
2283         if (gimme == G_ARRAY) {
2284             if (!CvLVALUE(cx->blk_sub.cv))
2285                 goto temporise_array;
2286             EXTEND_MORTAL(SP - newsp);
2287             for (mark = newsp + 1; mark <= SP; mark++) {
2288                 if (SvTEMP(*mark))
2289                     /* empty */ ;
2290                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2291                     *mark = sv_mortalcopy(*mark);
2292                 else {
2293                     /* Can be a localized value subject to deletion. */
2294                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2295                     (void)SvREFCNT_inc(*mark);
2296                 }
2297             }
2298         }
2299     }
2300     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2301         /* Here we go for robustness, not for speed, so we change all
2302          * the refcounts so the caller gets a live guy. Cannot set
2303          * TEMP, so sv_2mortal is out of question. */
2304         if (!CvLVALUE(cx->blk_sub.cv)) {
2305             POPSUB(cx,sv);
2306             PL_curpm = newpm;
2307             LEAVE;
2308             LEAVESUB(sv);
2309             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2310         }
2311         if (gimme == G_SCALAR) {
2312             MARK = newsp + 1;
2313             EXTEND_MORTAL(1);
2314             if (MARK == SP) {
2315                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2316                     POPSUB(cx,sv);
2317                     PL_curpm = newpm;
2318                     LEAVE;
2319                     LEAVESUB(sv);
2320                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2321                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2322                         : "a readonly value" : "a temporary");
2323                 }
2324                 else {                  /* Can be a localized value
2325                                          * subject to deletion. */
2326                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2327                     (void)SvREFCNT_inc(*mark);
2328                 }
2329             }
2330             else {                      /* Should not happen? */
2331                 POPSUB(cx,sv);
2332                 PL_curpm = newpm;
2333                 LEAVE;
2334                 LEAVESUB(sv);
2335                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2336                     (MARK > SP ? "Empty array" : "Array"));
2337             }
2338             SP = MARK;
2339         }
2340         else if (gimme == G_ARRAY) {
2341             EXTEND_MORTAL(SP - newsp);
2342             for (mark = newsp + 1; mark <= SP; mark++) {
2343                 if (*mark != &PL_sv_undef
2344                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2345                     /* Might be flattened array after $#array =  */
2346                     PUTBACK;
2347                     POPSUB(cx,sv);
2348                     PL_curpm = newpm;
2349                     LEAVE;
2350                     LEAVESUB(sv);
2351                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2352                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2353                 }
2354                 else {
2355                     /* Can be a localized value subject to deletion. */
2356                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2357                     (void)SvREFCNT_inc(*mark);
2358                 }
2359             }
2360         }
2361     }
2362     else {
2363         if (gimme == G_SCALAR) {
2364           temporise:
2365             MARK = newsp + 1;
2366             if (MARK <= SP) {
2367                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2368                     if (SvTEMP(TOPs)) {
2369                         *MARK = SvREFCNT_inc(TOPs);
2370                         FREETMPS;
2371                         sv_2mortal(*MARK);
2372                     }
2373                     else {
2374                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2375                         FREETMPS;
2376                         *MARK = sv_mortalcopy(sv);
2377                         SvREFCNT_dec(sv);
2378                     }
2379                 }
2380                 else
2381                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2382             }
2383             else {
2384                 MEXTEND(MARK, 0);
2385                 *MARK = &PL_sv_undef;
2386             }
2387             SP = MARK;
2388         }
2389         else if (gimme == G_ARRAY) {
2390           temporise_array:
2391             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2392                 if (!SvTEMP(*MARK)) {
2393                     *MARK = sv_mortalcopy(*MARK);
2394                     TAINT_NOT;  /* Each item is independent */
2395                 }
2396             }
2397         }
2398     }
2399     PUTBACK;
2400
2401     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2402     PL_curpm = newpm;   /* ... and pop $1 et al */
2403
2404     LEAVE;
2405     LEAVESUB(sv);
2406     return pop_return();
2407 }
2408
2409
2410 STATIC CV *
2411 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2412 {
2413     SV *dbsv = GvSV(PL_DBsub);
2414
2415     if (!PERLDB_SUB_NN) {
2416         GV *gv = CvGV(cv);
2417
2418         save_item(dbsv);
2419         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2420              || strEQ(GvNAME(gv), "END")
2421              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2422                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2423                     && (gv = (GV*)*svp) ))) {
2424             /* Use GV from the stack as a fallback. */
2425             /* GV is potentially non-unique, or contain different CV. */
2426             SV *tmp = newRV((SV*)cv);
2427             sv_setsv(dbsv, tmp);
2428             SvREFCNT_dec(tmp);
2429         }
2430         else {
2431             gv_efullname3(dbsv, gv, Nullch);
2432         }
2433     }
2434     else {
2435         (void)SvUPGRADE(dbsv, SVt_PVIV);
2436         (void)SvIOK_on(dbsv);
2437         SAVEIV(SvIVX(dbsv));
2438         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2439     }
2440
2441     if (CvXSUB(cv))
2442         PL_curcopdb = PL_curcop;
2443     cv = GvCV(PL_DBsub);
2444     return cv;
2445 }
2446
2447 PP(pp_entersub)
2448 {
2449     dSP; dPOPss;
2450     GV *gv;
2451     HV *stash;
2452     register CV *cv;
2453     register PERL_CONTEXT *cx;
2454     I32 gimme;
2455     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2456
2457     if (!sv)
2458         DIE(aTHX_ "Not a CODE reference");
2459     switch (SvTYPE(sv)) {
2460         /* This is overwhelming the most common case:  */
2461     case SVt_PVGV:
2462         if (!(cv = GvCVu((GV*)sv)))
2463             cv = sv_2cv(sv, &stash, &gv, FALSE);
2464         if (!cv) {
2465             ENTER;
2466             SAVETMPS;
2467             goto try_autoload;
2468         }
2469         break;
2470     default:
2471         if (!SvROK(sv)) {
2472             char *sym;
2473             STRLEN n_a;
2474
2475             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2476                 if (hasargs)
2477                     SP = PL_stack_base + POPMARK;
2478                 RETURN;
2479             }
2480             if (SvGMAGICAL(sv)) {
2481                 mg_get(sv);
2482                 if (SvROK(sv))
2483                     goto got_rv;
2484                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2485             }
2486             else
2487                 sym = SvPV(sv, n_a);
2488             if (!sym)
2489                 DIE(aTHX_ PL_no_usym, "a subroutine");
2490             if (PL_op->op_private & HINT_STRICT_REFS)
2491                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2492             cv = get_cv(sym, TRUE);
2493             break;
2494         }
2495   got_rv:
2496         {
2497             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2498             tryAMAGICunDEREF(to_cv);
2499         }
2500         cv = (CV*)SvRV(sv);
2501         if (SvTYPE(cv) == SVt_PVCV)
2502             break;
2503         /* FALL THROUGH */
2504     case SVt_PVHV:
2505     case SVt_PVAV:
2506         DIE(aTHX_ "Not a CODE reference");
2507         /* This is the second most common case:  */
2508     case SVt_PVCV:
2509         cv = (CV*)sv;
2510         break;
2511     }
2512
2513     ENTER;
2514     SAVETMPS;
2515
2516   retry:
2517     if (!CvROOT(cv) && !CvXSUB(cv)) {
2518         goto fooey;
2519     }
2520
2521     gimme = GIMME_V;
2522     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2523         cv = get_db_sub(&sv, cv);
2524         if (!cv)
2525             DIE(aTHX_ "No DBsub routine");
2526     }
2527
2528     if (!(CvXSUB(cv))) {
2529         /* This path taken at least 75% of the time   */
2530         dMARK;
2531         register I32 items = SP - MARK;
2532         AV* padlist = CvPADLIST(cv);
2533         push_return(PL_op->op_next);
2534         PUSHBLOCK(cx, CXt_SUB, MARK);
2535         PUSHSUB(cx);
2536         CvDEPTH(cv)++;
2537         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2538          * that eval'' ops within this sub know the correct lexical space.
2539          * Owing the speed considerations, we choose instead to search for
2540          * the cv using find_runcv() when calling doeval().
2541          */
2542         if (CvDEPTH(cv) < 2)
2543             (void)SvREFCNT_inc(cv);
2544         else {
2545             PERL_STACK_OVERFLOW_CHECK();
2546             pad_push(padlist, CvDEPTH(cv), 1);
2547         }
2548         PAD_SET_CUR(padlist, CvDEPTH(cv));
2549         if (hasargs)
2550         {
2551             AV* av;
2552             SV** ary;
2553
2554 #if 0
2555             DEBUG_S(PerlIO_printf(Perl_debug_log,
2556                                   "%p entersub preparing @_\n", thr));
2557 #endif
2558             av = (AV*)PAD_SVl(0);
2559             if (AvREAL(av)) {
2560                 /* @_ is normally not REAL--this should only ever
2561                  * happen when DB::sub() calls things that modify @_ */
2562                 av_clear(av);
2563                 AvREAL_off(av);
2564                 AvREIFY_on(av);
2565             }
2566             cx->blk_sub.savearray = GvAV(PL_defgv);
2567             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2568             CX_CURPAD_SAVE(cx->blk_sub);
2569             cx->blk_sub.argarray = av;
2570             ++MARK;
2571
2572             if (items > AvMAX(av) + 1) {
2573                 ary = AvALLOC(av);
2574                 if (AvARRAY(av) != ary) {
2575                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2576                     SvPVX(av) = (char*)ary;
2577                 }
2578                 if (items > AvMAX(av) + 1) {
2579                     AvMAX(av) = items - 1;
2580                     Renew(ary,items,SV*);
2581                     AvALLOC(av) = ary;
2582                     SvPVX(av) = (char*)ary;
2583                 }
2584             }
2585             Copy(MARK,AvARRAY(av),items,SV*);
2586             AvFILLp(av) = items - 1;
2587
2588             while (items--) {
2589                 if (*MARK)
2590                     SvTEMP_off(*MARK);
2591                 MARK++;
2592             }
2593         }
2594         /* warning must come *after* we fully set up the context
2595          * stuff so that __WARN__ handlers can safely dounwind()
2596          * if they want to
2597          */
2598         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2599             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2600             sub_crush_depth(cv);
2601 #if 0
2602         DEBUG_S(PerlIO_printf(Perl_debug_log,
2603                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2604 #endif
2605         RETURNOP(CvSTART(cv));
2606     }
2607     else {
2608 #ifdef PERL_XSUB_OLDSTYLE
2609         if (CvOLDSTYLE(cv)) {
2610             I32 (*fp3)(int,int,int);
2611             dMARK;
2612             register I32 items = SP - MARK;
2613                                         /* We dont worry to copy from @_. */
2614             while (SP > mark) {
2615                 SP[1] = SP[0];
2616                 SP--;
2617             }
2618             PL_stack_sp = mark + 1;
2619             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2620             items = (*fp3)(CvXSUBANY(cv).any_i32,
2621                            MARK - PL_stack_base + 1,
2622                            items);
2623             PL_stack_sp = PL_stack_base + items;
2624         }
2625         else
2626 #endif /* PERL_XSUB_OLDSTYLE */
2627         {
2628             I32 markix = TOPMARK;
2629
2630             PUTBACK;
2631
2632             if (!hasargs) {
2633                 /* Need to copy @_ to stack. Alternative may be to
2634                  * switch stack to @_, and copy return values
2635                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2636                 AV* av;
2637                 I32 items;
2638                 av = GvAV(PL_defgv);
2639                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2640
2641                 if (items) {
2642                     /* Mark is at the end of the stack. */
2643                     EXTEND(SP, items);
2644                     Copy(AvARRAY(av), SP + 1, items, SV*);
2645                     SP += items;
2646                     PUTBACK ;
2647                 }
2648             }
2649             /* We assume first XSUB in &DB::sub is the called one. */
2650             if (PL_curcopdb) {
2651                 SAVEVPTR(PL_curcop);
2652                 PL_curcop = PL_curcopdb;
2653                 PL_curcopdb = NULL;
2654             }
2655             /* Do we need to open block here? XXXX */
2656             (void)(*CvXSUB(cv))(aTHX_ cv);
2657
2658             /* Enforce some sanity in scalar context. */
2659             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2660                 if (markix > PL_stack_sp - PL_stack_base)
2661                     *(PL_stack_base + markix) = &PL_sv_undef;
2662                 else
2663                     *(PL_stack_base + markix) = *PL_stack_sp;
2664                 PL_stack_sp = PL_stack_base + markix;
2665             }
2666         }
2667         LEAVE;
2668         return NORMAL;
2669     }
2670
2671     assert (0); /* Cannot get here.  */
2672     /* This is deliberately moved here as spaghetti code to keep it out of the
2673        hot path.  */
2674     {
2675         GV* autogv;
2676         SV* sub_name;
2677
2678       fooey:
2679         /* anonymous or undef'd function leaves us no recourse */
2680         if (CvANON(cv) || !(gv = CvGV(cv)))
2681             DIE(aTHX_ "Undefined subroutine called");
2682
2683         /* autoloaded stub? */
2684         if (cv != GvCV(gv)) {
2685             cv = GvCV(gv);
2686         }
2687         /* should call AUTOLOAD now? */
2688         else {
2689 try_autoload:
2690             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2691                                    FALSE)))
2692             {
2693                 cv = GvCV(autogv);
2694             }
2695             /* sorry */
2696             else {
2697                 sub_name = sv_newmortal();
2698                 gv_efullname3(sub_name, gv, Nullch);
2699                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2700             }
2701         }
2702         if (!cv)
2703             DIE(aTHX_ "Not a CODE reference");
2704         goto retry;
2705     }
2706 }
2707
2708 void
2709 Perl_sub_crush_depth(pTHX_ CV *cv)
2710 {
2711     if (CvANON(cv))
2712         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2713     else {
2714         SV* tmpstr = sv_newmortal();
2715         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2716         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2717                 SvPVX(tmpstr));
2718     }
2719 }
2720
2721 PP(pp_aelem)
2722 {
2723     dSP;
2724     SV** svp;
2725     SV* elemsv = POPs;
2726     IV elem = SvIV(elemsv);
2727     AV* av = (AV*)POPs;
2728     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2729     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2730     SV *sv;
2731
2732     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2733         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2734     if (elem > 0)
2735         elem -= PL_curcop->cop_arybase;
2736     if (SvTYPE(av) != SVt_PVAV)
2737         RETPUSHUNDEF;
2738     svp = av_fetch(av, elem, lval && !defer);
2739     if (lval) {
2740         if (!svp || *svp == &PL_sv_undef) {
2741             SV* lv;
2742             if (!defer)
2743                 DIE(aTHX_ PL_no_aelem, elem);
2744             lv = sv_newmortal();
2745             sv_upgrade(lv, SVt_PVLV);
2746             LvTYPE(lv) = 'y';
2747             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2748             LvTARG(lv) = SvREFCNT_inc(av);
2749             LvTARGOFF(lv) = elem;
2750             LvTARGLEN(lv) = 1;
2751             PUSHs(lv);
2752             RETURN;
2753         }
2754         if (PL_op->op_private & OPpLVAL_INTRO)
2755             save_aelem(av, elem, svp);
2756         else if (PL_op->op_private & OPpDEREF)
2757             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2758     }
2759     sv = (svp ? *svp : &PL_sv_undef);
2760     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2761         sv = sv_mortalcopy(sv);
2762     PUSHs(sv);
2763     RETURN;
2764 }
2765
2766 void
2767 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2768 {
2769     if (SvGMAGICAL(sv))
2770         mg_get(sv);
2771     if (!SvOK(sv)) {
2772         if (SvREADONLY(sv))
2773             Perl_croak(aTHX_ PL_no_modify);
2774         if (SvTYPE(sv) < SVt_RV)
2775             sv_upgrade(sv, SVt_RV);
2776         else if (SvTYPE(sv) >= SVt_PV) {
2777             (void)SvOOK_off(sv);
2778             Safefree(SvPVX(sv));
2779             SvLEN(sv) = SvCUR(sv) = 0;
2780         }
2781         switch (to_what) {
2782         case OPpDEREF_SV:
2783             SvRV(sv) = NEWSV(355,0);
2784             break;
2785         case OPpDEREF_AV:
2786             SvRV(sv) = (SV*)newAV();
2787             break;
2788         case OPpDEREF_HV:
2789             SvRV(sv) = (SV*)newHV();
2790             break;
2791         }
2792         SvROK_on(sv);
2793         SvSETMAGIC(sv);
2794     }
2795 }
2796
2797 PP(pp_method)
2798 {
2799     dSP;
2800     SV* sv = TOPs;
2801
2802     if (SvROK(sv)) {
2803         SV* rsv = SvRV(sv);
2804         if (SvTYPE(rsv) == SVt_PVCV) {
2805             SETs(rsv);
2806             RETURN;
2807         }
2808     }
2809
2810     SETs(method_common(sv, Null(U32*)));
2811     RETURN;
2812 }
2813
2814 PP(pp_method_named)
2815 {
2816     dSP;
2817     SV* sv = cSVOP->op_sv;
2818     U32 hash = SvUVX(sv);
2819
2820     XPUSHs(method_common(sv, &hash));
2821     RETURN;
2822 }
2823
2824 STATIC SV *
2825 S_method_common(pTHX_ SV* meth, U32* hashp)
2826 {
2827     SV* sv;
2828     SV* ob;
2829     GV* gv;
2830     HV* stash;
2831     char* name;
2832     STRLEN namelen;
2833     char* packname = 0;
2834     SV *packsv = Nullsv;
2835     STRLEN packlen;
2836
2837     name = SvPV(meth, namelen);
2838     sv = *(PL_stack_base + TOPMARK + 1);
2839
2840     if (!sv)
2841         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2842
2843     if (SvGMAGICAL(sv))
2844         mg_get(sv);
2845     if (SvROK(sv))
2846         ob = (SV*)SvRV(sv);
2847     else {
2848         GV* iogv;
2849
2850         /* this isn't a reference */
2851         packname = Nullch;
2852         if (!SvOK(sv) ||
2853             !(packname = SvPV(sv, packlen)) ||
2854             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2855             !(ob=(SV*)GvIO(iogv)))
2856         {
2857             /* this isn't the name of a filehandle either */
2858             if (!packname ||
2859                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2860                     ? !isIDFIRST_utf8((U8*)packname)
2861                     : !isIDFIRST(*packname)
2862                 ))
2863             {
2864                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2865                            SvOK(sv) ? "without a package or object reference"
2866                                     : "on an undefined value");
2867             }
2868             /* assume it's a package name */
2869             stash = gv_stashpvn(packname, packlen, FALSE);
2870             if (!stash)
2871                 packsv = sv;
2872             goto fetch;
2873         }
2874         /* it _is_ a filehandle name -- replace with a reference */
2875         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2876     }
2877
2878     /* if we got here, ob should be a reference or a glob */
2879     if (!ob || !(SvOBJECT(ob)
2880                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2881                      && SvOBJECT(ob))))
2882     {
2883         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2884                    name);
2885     }
2886
2887     stash = SvSTASH(ob);
2888
2889   fetch:
2890     /* NOTE: stash may be null, hope hv_fetch_ent and
2891        gv_fetchmethod can cope (it seems they can) */
2892
2893     /* shortcut for simple names */
2894     if (hashp) {
2895         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2896         if (he) {
2897             gv = (GV*)HeVAL(he);
2898             if (isGV(gv) && GvCV(gv) &&
2899                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2900                 return (SV*)GvCV(gv);
2901         }
2902     }
2903
2904     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
2905
2906     if (!gv) {
2907         /* This code tries to figure out just what went wrong with
2908            gv_fetchmethod.  It therefore needs to duplicate a lot of
2909            the internals of that function.  We can't move it inside
2910            Perl_gv_fetchmethod_autoload(), however, since that would
2911            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2912            don't want that.
2913         */
2914         char* leaf = name;
2915         char* sep = Nullch;
2916         char* p;
2917
2918         for (p = name; *p; p++) {
2919             if (*p == '\'')
2920                 sep = p, leaf = p + 1;
2921             else if (*p == ':' && *(p + 1) == ':')
2922                 sep = p, leaf = p + 2;
2923         }
2924         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2925             /* the method name is unqualified or starts with SUPER:: */
2926             packname = sep ? CopSTASHPV(PL_curcop) :
2927                 stash ? HvNAME(stash) : packname;
2928             packlen = strlen(packname);
2929         }
2930         else {
2931             /* the method name is qualified */
2932             packname = name;
2933             packlen = sep - name;
2934         }
2935
2936         /* we're relying on gv_fetchmethod not autovivifying the stash */
2937         if (gv_stashpvn(packname, packlen, FALSE)) {
2938             Perl_croak(aTHX_
2939                        "Can't locate object method \"%s\" via package \"%.*s\"",
2940                        leaf, (int)packlen, packname);
2941         }
2942         else {
2943             Perl_croak(aTHX_
2944                        "Can't locate object method \"%s\" via package \"%.*s\""
2945                        " (perhaps you forgot to load \"%.*s\"?)",
2946                        leaf, (int)packlen, packname, (int)packlen, packname);
2947         }
2948     }
2949     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
2950 }