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