pp_hot.c

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