pp_hot.c

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