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