pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 #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     bool lbyte;
 153     STRLEN rlen;
 154     const char *rpv = SvPV(right, rlen);        /* mg_get(right) happens here */
 155     const bool rbyte = !DO_UTF8(right);
 156     bool rcopied = FALSE;
 157
 158     if (TARG == right && right != left) {
 159         right = sv_2mortal(newSVpvn(rpv, rlen));
 160         rpv = SvPV(right, rlen);        /* no point setting UTF-8 here */
 161         rcopied = TRUE;
 162     }
 163
 164     if (TARG != left) {
 165         STRLEN llen;
 166         const char* const 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         STRLEN llen;
 176         if (SvGMAGICAL(left))
 177             mg_get(left);               /* or mg_get(left) may happen here */
 178         if (!SvOK(TARG))
 179             sv_setpvn(left, "", 0);
 180         (void)SvPV_nomg(left, llen);    /* Needed to set UTF8 flag */
 181         lbyte = !DO_UTF8(left);
 182         if (IN_BYTES)
 183             SvUTF8_off(TARG);
 184     }
 185
 186 #if defined(PERL_Y2KWARN)
 187     if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
 188         if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
 189             && (llen == 2 || !isDIGIT(lpv[llen - 3])))
 190         {
 191             Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
 192                         "about to append an integer to '19'");
 193         }
 194     }
 195 #endif
 196
 197     if (lbyte != rbyte) {
 198         if (lbyte)
 199             sv_utf8_upgrade_nomg(TARG);
 200         else {
 201             if (!rcopied)
 202                 right = sv_2mortal(newSVpvn(rpv, rlen));
 203             sv_utf8_upgrade_nomg(right);
 204             rpv = SvPV(right, rlen);
 205         }
 206     }
 207     sv_catpvn_nomg(TARG, rpv, rlen);
 208
 209     SETTARG;
 210     RETURN;
 211   }
 212 }
 213
 214 PP(pp_padsv)
 215 {
 216     dSP; dTARGET;
 217     XPUSHs(TARG);
 218     if (PL_op->op_flags & OPf_MOD) {
 219         if (PL_op->op_private & OPpLVAL_INTRO)
 220             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 221         else if (PL_op->op_private & OPpDEREF) {
 222             PUTBACK;
 223             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 224             SPAGAIN;
 225         }
 226     }
 227     RETURN;
 228 }
 229
 230 PP(pp_readline)
 231 {
 232     tryAMAGICunTARGET(iter, 0);
 233     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 234     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 235         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 236             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 237         else {
 238             dSP;
 239             XPUSHs((SV*)PL_last_in_gv);
 240             PUTBACK;
 241             pp_rv2gv();
 242             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 243         }
 244     }
 245     return do_readline();
 246 }
 247
 248 PP(pp_eq)
 249 {
 250     dSP; tryAMAGICbinSET(eq,0);
 251 #ifndef NV_PRESERVES_UV
 252     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 253         SP--;
 254         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 255         RETURN;
 256     }
 257 #endif
 258 #ifdef PERL_PRESERVE_IVUV
 259     SvIV_please(TOPs);
 260     if (SvIOK(TOPs)) {
 261         /* Unless the left argument is integer in range we are going
 262            to have to use NV maths. Hence only attempt to coerce the
 263            right argument if we know the left is integer.  */
 264       SvIV_please(TOPm1s);
 265         if (SvIOK(TOPm1s)) {
 266             bool auvok = SvUOK(TOPm1s);
 267             bool buvok = SvUOK(TOPs);
 268
 269             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 270                 /* Casting IV to UV before comparison isn't going to matter
 271                    on 2s complement. On 1s complement or sign&magnitude
 272                    (if we have any of them) it could to make negative zero
 273                    differ from normal zero. As I understand it. (Need to
 274                    check - is negative zero implementation defined behaviour
 275                    anyway?). NWC  */
 276                 UV buv = SvUVX(POPs);
 277                 UV auv = SvUVX(TOPs);
 278
 279                 SETs(boolSV(auv == buv));
 280                 RETURN;
 281             }
 282             {                   /* ## Mixed IV,UV ## */
 283                 SV *ivp, *uvp;
 284                 IV iv;
 285
 286                 /* == is commutative so doesn't matter which is left or right */
 287                 if (auvok) {
 288                     /* top of stack (b) is the iv */
 289                     ivp = *SP;
 290                     uvp = *--SP;
 291                 } else {
 292                     uvp = *SP;
 293                     ivp = *--SP;
 294                 }
 295                 iv = SvIVX(ivp);
 296                 if (iv < 0) {
 297                     /* As uv is a UV, it's >0, so it cannot be == */
 298                     SETs(&PL_sv_no);
 299                     RETURN;
 300                 }
 301                 /* we know iv is >= 0 */
 302                 SETs(boolSV((UV)iv == SvUVX(uvp)));
 303                 RETURN;
 304             }
 305         }
 306     }
 307 #endif
 308     {
 309       dPOPnv;
 310       SETs(boolSV(TOPn == value));
 311       RETURN;
 312     }
 313 }
 314
 315 PP(pp_preinc)
 316 {
 317     dSP;
 318     if (SvTYPE(TOPs) > SVt_PVLV)
 319         DIE(aTHX_ PL_no_modify);
 320     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 321         && SvIVX(TOPs) != IV_MAX)
 322     {
 323         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 324         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 325     }
 326     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 327         sv_inc(TOPs);
 328     SvSETMAGIC(TOPs);
 329     return NORMAL;
 330 }
 331
 332 PP(pp_or)
 333 {
 334     dSP;
 335     if (SvTRUE(TOPs))
 336         RETURN;
 337     else {
 338         --SP;
 339         RETURNOP(cLOGOP->op_other);
 340     }
 341 }
 342
 343 PP(pp_add)
 344 {
 345     dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
 346     useleft = USE_LEFT(TOPm1s);
 347 #ifdef PERL_PRESERVE_IVUV
 348     /* We must see if we can perform the addition with integers if possible,
 349        as the integer code detects overflow while the NV code doesn't.
 350        If either argument hasn't had a numeric conversion yet attempt to get
 351        the IV. It's important to do this now, rather than just assuming that
 352        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 353        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 354        integer in case the second argument is IV=9223372036854775806
 355        We can (now) rely on sv_2iv to do the right thing, only setting the
 356        public IOK flag if the value in the NV (or PV) slot is truly integer.
 357
 358        A side effect is that this also aggressively prefers integer maths over
 359        fp maths for integer values.
 360
 361        How to detect overflow?
 362
 363        C 99 section 6.2.6.1 says
 364
 365        The range of nonnegative values of a signed integer type is a subrange
 366        of the corresponding unsigned integer type, and the representation of
 367        the same value in each type is the same. A computation involving
 368        unsigned operands can never overflow, because a result that cannot be
 369        represented by the resulting unsigned integer type is reduced modulo
 370        the number that is one greater than the largest value that can be
 371        represented by the resulting type.
 372
 373        (the 9th paragraph)
 374
 375        which I read as "unsigned ints wrap."
 376
 377        signed integer overflow seems to be classed as "exception condition"
 378
 379        If an exceptional condition occurs during the evaluation of an
 380        expression (that is, if the result is not mathematically defined or not
 381        in the range of representable values for its type), the behavior is
 382        undefined.
 383
 384        (6.5, the 5th paragraph)
 385
 386        I had assumed that on 2s complement machines signed arithmetic would
 387        wrap, hence coded pp_add and pp_subtract on the assumption that
 388        everything perl builds on would be happy.  After much wailing and
 389        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 390        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 391        unsigned code below is actually shorter than the old code. :-)
 392     */
 393
 394     SvIV_please(TOPs);
 395     if (SvIOK(TOPs)) {
 396         /* Unless the left argument is integer in range we are going to have to
 397            use NV maths. Hence only attempt to coerce the right argument if
 398            we know the left is integer.  */
 399         register UV auv = 0;
 400         bool auvok = FALSE;
 401         bool a_valid = 0;
 402
 403         if (!useleft) {
 404             auv = 0;
 405             a_valid = auvok = 1;
 406             /* left operand is undef, treat as zero. + 0 is identity,
 407                Could SETi or SETu right now, but space optimise by not adding
 408                lots of code to speed up what is probably a rarish case.  */
 409         } else {
 410             /* Left operand is defined, so is it IV? */
 411             SvIV_please(TOPm1s);
 412             if (SvIOK(TOPm1s)) {
 413                 if ((auvok = SvUOK(TOPm1s)))
 414                     auv = SvUVX(TOPm1s);
 415                 else {
 416                     register IV aiv = SvIVX(TOPm1s);
 417                     if (aiv >= 0) {
 418                         auv = aiv;
 419                         auvok = 1;      /* Now acting as a sign flag.  */
 420                     } else { /* 2s complement assumption for IV_MIN */
 421                         auv = (UV)-aiv;
 422                     }
 423                 }
 424                 a_valid = 1;
 425             }
 426         }
 427         if (a_valid) {
 428             bool result_good = 0;
 429             UV result;
 430             register UV buv;
 431             bool buvok = SvUOK(TOPs);
 432
 433             if (buvok)
 434                 buv = SvUVX(TOPs);
 435             else {
 436                 register IV biv = SvIVX(TOPs);
 437                 if (biv >= 0) {
 438                     buv = biv;
 439                     buvok = 1;
 440                 } else
 441                     buv = (UV)-biv;
 442             }
 443             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 444                else "IV" now, independent of how it came in.
 445                if a, b represents positive, A, B negative, a maps to -A etc
 446                a + b =>  (a + b)
 447                A + b => -(a - b)
 448                a + B =>  (a - b)
 449                A + B => -(a + b)
 450                all UV maths. negate result if A negative.
 451                add if signs same, subtract if signs differ. */
 452
 453             if (auvok ^ buvok) {
 454                 /* Signs differ.  */
 455                 if (auv >= buv) {
 456                     result = auv - buv;
 457                     /* Must get smaller */
 458                     if (result <= auv)
 459                         result_good = 1;
 460                 } else {
 461                     result = buv - auv;
 462                     if (result <= buv) {
 463                         /* result really should be -(auv-buv). as its negation
 464                            of true value, need to swap our result flag  */
 465                         auvok = !auvok;
 466                         result_good = 1;
 467                     }
 468                 }
 469             } else {
 470                 /* Signs same */
 471                 result = auv + buv;
 472                 if (result >= auv)
 473                     result_good = 1;
 474             }
 475             if (result_good) {
 476                 SP--;
 477                 if (auvok)
 478                     SETu( result );
 479                 else {
 480                     /* Negate result */
 481                     if (result <= (UV)IV_MIN)
 482                         SETi( -(IV)result );
 483                     else {
 484                         /* result valid, but out of range for IV.  */
 485                         SETn( -(NV)result );
 486                     }
 487                 }
 488                 RETURN;
 489             } /* Overflow, drop through to NVs.  */
 490         }
 491     }
 492 #endif
 493     {
 494         dPOPnv;
 495         if (!useleft) {
 496             /* left operand is undef, treat as zero. + 0.0 is identity. */
 497             SETn(value);
 498             RETURN;
 499         }
 500         SETn( value + TOPn );
 501         RETURN;
 502     }
 503 }
 504
 505 PP(pp_aelemfast)
 506 {
 507     dSP;
 508     AV *av = PL_op->op_flags & OPf_SPECIAL ?
 509                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 510     U32 lval = PL_op->op_flags & OPf_MOD;
 511     SV** svp = av_fetch(av, PL_op->op_private, lval);
 512     SV *sv = (svp ? *svp : &PL_sv_undef);
 513     EXTEND(SP, 1);
 514     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 515         sv = sv_mortalcopy(sv);
 516     PUSHs(sv);
 517     RETURN;
 518 }
 519
 520 PP(pp_join)
 521 {
 522     dSP; dMARK; dTARGET;
 523     MARK++;
 524     do_join(TARG, *MARK, MARK, SP);
 525     SP = MARK;
 526     SETs(TARG);
 527     RETURN;
 528 }
 529
 530 PP(pp_pushre)
 531 {
 532     dSP;
 533 #ifdef DEBUGGING
 534     /*
 535      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 536      * will be enough to hold an OP*.
 537      */
 538     SV* sv = sv_newmortal();
 539     sv_upgrade(sv, SVt_PVLV);
 540     LvTYPE(sv) = '/';
 541     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 542     XPUSHs(sv);
 543 #else
 544     XPUSHs((SV*)PL_op);
 545 #endif
 546     RETURN;
 547 }
 548
 549 /* Oversized hot code. */
 550
 551 PP(pp_print)
 552 {
 553     dSP; dMARK; dORIGMARK;
 554     GV *gv;
 555     IO *io;
 556     register PerlIO *fp;
 557     MAGIC *mg;
 558
 559     if (PL_op->op_flags & OPf_STACKED)
 560         gv = (GV*)*++MARK;
 561     else
 562         gv = PL_defoutgv;
 563
 564     if (gv && (io = GvIO(gv))
 565         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 566     {
 567       had_magic:
 568         if (MARK == ORIGMARK) {
 569             /* If using default handle then we need to make space to
 570              * pass object as 1st arg, so move other args up ...
 571              */
 572             MEXTEND(SP, 1);
 573             ++MARK;
 574             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 575             ++SP;
 576         }
 577         PUSHMARK(MARK - 1);
 578         *MARK = SvTIED_obj((SV*)io, mg);
 579         PUTBACK;
 580         ENTER;
 581         call_method("PRINT", G_SCALAR);
 582         LEAVE;
 583         SPAGAIN;
 584         MARK = ORIGMARK + 1;
 585         *MARK = *SP;
 586         SP = MARK;
 587         RETURN;
 588     }
 589     if (!(io = GvIO(gv))) {
 590         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 591             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 592             goto had_magic;
 593         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 594             report_evil_fh(gv, io, PL_op->op_type);
 595         SETERRNO(EBADF,RMS_IFI);
 596         goto just_say_no;
 597     }
 598     else if (!(fp = IoOFP(io))) {
 599         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 600             if (IoIFP(io))
 601                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 602             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 603                 report_evil_fh(gv, io, PL_op->op_type);
 604         }
 605         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 606         goto just_say_no;
 607     }
 608     else {
 609         MARK++;
 610         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 611             while (MARK <= SP) {
 612                 if (!do_print(*MARK, fp))
 613                     break;
 614                 MARK++;
 615                 if (MARK <= SP) {
 616                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 617                         MARK--;
 618                         break;
 619                     }
 620                 }
 621             }
 622         }
 623         else {
 624             while (MARK <= SP) {
 625                 if (!do_print(*MARK, fp))
 626                     break;
 627                 MARK++;
 628             }
 629         }
 630         if (MARK <= SP)
 631             goto just_say_no;
 632         else {
 633             if (PL_ors_sv && SvOK(PL_ors_sv))
 634                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 635                     goto just_say_no;
 636
 637             if (IoFLAGS(io) & IOf_FLUSH)
 638                 if (PerlIO_flush(fp) == EOF)
 639                     goto just_say_no;
 640         }
 641     }
 642     SP = ORIGMARK;
 643     PUSHs(&PL_sv_yes);
 644     RETURN;
 645
 646   just_say_no:
 647     SP = ORIGMARK;
 648     PUSHs(&PL_sv_undef);
 649     RETURN;
 650 }
 651
 652 PP(pp_rv2av)
 653 {
 654     dSP; dTOPss;
 655     AV *av;
 656
 657     if (SvROK(sv)) {
 658       wasref:
 659         tryAMAGICunDEREF(to_av);
 660
 661         av = (AV*)SvRV(sv);
 662         if (SvTYPE(av) != SVt_PVAV)
 663             DIE(aTHX_ "Not an ARRAY reference");
 664         if (PL_op->op_flags & OPf_REF) {
 665             SETs((SV*)av);
 666             RETURN;
 667         }
 668         else if (LVRET) {
 669             if (GIMME == G_SCALAR)
 670                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
 671             SETs((SV*)av);
 672             RETURN;
 673         }
 674         else if (PL_op->op_flags & OPf_MOD
 675                 && PL_op->op_private & OPpLVAL_INTRO)
 676             Perl_croak(aTHX_ PL_no_localize_ref);
 677     }
 678     else {
 679         if (SvTYPE(sv) == SVt_PVAV) {
 680             av = (AV*)sv;
 681             if (PL_op->op_flags & OPf_REF) {
 682                 SETs((SV*)av);
 683                 RETURN;
 684             }
 685             else if (LVRET) {
 686                 if (GIMME == G_SCALAR)
 687                     Perl_croak(aTHX_ "Can't return array to lvalue"
 688                                " scalar context");
 689                 SETs((SV*)av);
 690                 RETURN;
 691             }
 692         }
 693         else {
 694             GV *gv;
 695
 696             if (SvTYPE(sv) != SVt_PVGV) {
 697                 char *sym;
 698                 STRLEN len;
 699
 700                 if (SvGMAGICAL(sv)) {
 701                     mg_get(sv);
 702                     if (SvROK(sv))
 703                         goto wasref;
 704                 }
 705                 if (!SvOK(sv)) {
 706                     if (PL_op->op_flags & OPf_REF ||
 707                       PL_op->op_private & HINT_STRICT_REFS)
 708                         DIE(aTHX_ PL_no_usym, "an ARRAY");
 709                     if (ckWARN(WARN_UNINITIALIZED))
 710                         report_uninit();
 711                     if (GIMME == G_ARRAY) {
 712                         (void)POPs;
 713                         RETURN;
 714                     }
 715                     RETSETUNDEF;
 716                 }
 717                 sym = SvPV(sv,len);
 718                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 719                     !(PL_op->op_flags & OPf_MOD))
 720                 {
 721                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
 722                     if (!gv
 723                         && (!is_gv_magical(sym,len,0)
 724                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
 725                     {
 726                         RETSETUNDEF;
 727                     }
 728                 }
 729                 else {
 730                     if (PL_op->op_private & HINT_STRICT_REFS)
 731                         DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
 732                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 733                 }
 734             }
 735             else {
 736                 gv = (GV*)sv;
 737             }
 738             av = GvAVn(gv);
 739             if (PL_op->op_private & OPpLVAL_INTRO)
 740                 av = save_ary(gv);
 741             if (PL_op->op_flags & OPf_REF) {
 742                 SETs((SV*)av);
 743                 RETURN;
 744             }
 745             else if (LVRET) {
 746                 if (GIMME == G_SCALAR)
 747                     Perl_croak(aTHX_ "Can't return array to lvalue"
 748                                " scalar context");
 749                 SETs((SV*)av);
 750                 RETURN;
 751             }
 752         }
 753     }
 754
 755     if (GIMME == G_ARRAY) {
 756         I32 maxarg = AvFILL(av) + 1;
 757         (void)POPs;                     /* XXXX May be optimized away? */
 758         EXTEND(SP, maxarg);
 759         if (SvRMAGICAL(av)) {
 760             U32 i;
 761             for (i=0; i < (U32)maxarg; i++) {
 762                 SV **svp = av_fetch(av, i, FALSE);
 763                 /* See note in pp_helem, and bug id #27839 */
 764                 SP[i+1] = svp
 765                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 766                     : &PL_sv_undef;
 767             }
 768         }
 769         else {
 770             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 771         }
 772         SP += maxarg;
 773     }
 774     else if (GIMME_V == G_SCALAR) {
 775         dTARGET;
 776         I32 maxarg = AvFILL(av) + 1;
 777         SETi(maxarg);
 778     }
 779     RETURN;
 780 }
 781
 782 PP(pp_rv2hv)
 783 {
 784     dSP; dTOPss;
 785     HV *hv;
 786     I32 gimme = GIMME_V;
 787
 788     if (SvROK(sv)) {
 789       wasref:
 790         tryAMAGICunDEREF(to_hv);
 791
 792         hv = (HV*)SvRV(sv);
 793         if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
 794             DIE(aTHX_ "Not a HASH reference");
 795         if (PL_op->op_flags & OPf_REF) {
 796             SETs((SV*)hv);
 797             RETURN;
 798         }
 799         else if (LVRET) {
 800             if (gimme != G_ARRAY)
 801                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 802             SETs((SV*)hv);
 803             RETURN;
 804         }
 805         else if (PL_op->op_flags & OPf_MOD
 806                 && PL_op->op_private & OPpLVAL_INTRO)
 807             Perl_croak(aTHX_ PL_no_localize_ref);
 808     }
 809     else {
 810         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
 811             hv = (HV*)sv;
 812             if (PL_op->op_flags & OPf_REF) {
 813                 SETs((SV*)hv);
 814                 RETURN;
 815             }
 816             else if (LVRET) {
 817                 if (gimme != G_ARRAY)
 818                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 819                                " scalar context");
 820                 SETs((SV*)hv);
 821                 RETURN;
 822             }
 823         }
 824         else {
 825             GV *gv;
 826
 827             if (SvTYPE(sv) != SVt_PVGV) {
 828                 char *sym;
 829                 STRLEN len;
 830
 831                 if (SvGMAGICAL(sv)) {
 832                     mg_get(sv);
 833                     if (SvROK(sv))
 834                         goto wasref;
 835                 }
 836                 if (!SvOK(sv)) {
 837                     if (PL_op->op_flags & OPf_REF ||
 838                       PL_op->op_private & HINT_STRICT_REFS)
 839                         DIE(aTHX_ PL_no_usym, "a HASH");
 840                     if (ckWARN(WARN_UNINITIALIZED))
 841                         report_uninit();
 842                     if (gimme == G_ARRAY) {
 843                         SP--;
 844                         RETURN;
 845                     }
 846                     RETSETUNDEF;
 847                 }
 848                 sym = SvPV(sv,len);
 849                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 850                     !(PL_op->op_flags & OPf_MOD))
 851                 {
 852                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
 853                     if (!gv
 854                         && (!is_gv_magical(sym,len,0)
 855                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
 856                     {
 857                         RETSETUNDEF;
 858                     }
 859                 }
 860                 else {
 861                     if (PL_op->op_private & HINT_STRICT_REFS)
 862                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
 863                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 864                 }
 865             }
 866             else {
 867                 gv = (GV*)sv;
 868             }
 869             hv = GvHVn(gv);
 870             if (PL_op->op_private & OPpLVAL_INTRO)
 871                 hv = save_hash(gv);
 872             if (PL_op->op_flags & OPf_REF) {
 873                 SETs((SV*)hv);
 874                 RETURN;
 875             }
 876             else if (LVRET) {
 877                 if (gimme != G_ARRAY)
 878                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 879                                " scalar context");
 880                 SETs((SV*)hv);
 881                 RETURN;
 882             }
 883         }
 884     }
 885
 886     if (gimme == G_ARRAY) { /* array wanted */
 887         *PL_stack_sp = (SV*)hv;
 888         return do_kv();
 889     }
 890     else if (gimme == G_SCALAR) {
 891         dTARGET;
 892
 893         if (SvTYPE(hv) == SVt_PVAV)
 894             hv = avhv_keys((AV*)hv);
 895
 896         TARG = Perl_hv_scalar(aTHX_ hv);
 897         SETTARG;
 898     }
 899     RETURN;
 900 }
 901
 902 STATIC int
 903 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
 904                  SV **lastrelem)
 905 {
 906     OP *leftop;
 907     I32 i;
 908
 909     leftop = ((BINOP*)PL_op)->op_last;
 910     assert(leftop);
 911     assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
 912     leftop = ((LISTOP*)leftop)->op_first;
 913     assert(leftop);
 914     /* Skip PUSHMARK and each element already assigned to. */
 915     for (i = lelem - firstlelem; i > 0; i--) {
 916         leftop = leftop->op_sibling;
 917         assert(leftop);
 918     }
 919     if (leftop->op_type != OP_RV2HV)
 920         return 0;
 921
 922     /* pseudohash */
 923     if (av_len(ary) > 0)
 924         av_fill(ary, 0);                /* clear all but the fields hash */
 925     if (lastrelem >= relem) {
 926         while (relem < lastrelem) {     /* gobble up all the rest */
 927             SV *tmpstr;
 928             assert(relem[0]);
 929             assert(relem[1]);
 930             /* Avoid a memory leak when avhv_store_ent dies. */
 931             tmpstr = sv_newmortal();
 932             sv_setsv(tmpstr,relem[1]);  /* value */
 933             relem[1] = tmpstr;
 934             if (avhv_store_ent(ary,relem[0],tmpstr,0))
 935                 (void)SvREFCNT_inc(tmpstr);
 936             if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
 937                 mg_set(tmpstr);
 938             relem += 2;
 939             TAINT_NOT;
 940         }
 941     }
 942     if (relem == lastrelem)
 943         return 1;
 944     return 2;
 945 }
 946
 947 STATIC void
 948 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 949 {
 950     if (*relem) {
 951         SV *tmpstr;
 952         if (ckWARN(WARN_MISC)) {
 953             if (relem == firstrelem &&
 954                 SvROK(*relem) &&
 955                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 956                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 957             {
 958                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 959                             "Reference found where even-sized list expected");
 960             }
 961             else
 962                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 963                             "Odd number of elements in hash assignment");
 964         }
 965         if (SvTYPE(hash) == SVt_PVAV) {
 966             /* pseudohash */
 967             tmpstr = sv_newmortal();
 968             if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
 969                 (void)SvREFCNT_inc(tmpstr);
 970             if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
 971                 mg_set(tmpstr);
 972         }
 973         else {
 974             HE *didstore;
 975             tmpstr = NEWSV(29,0);
 976             didstore = hv_store_ent(hash,*relem,tmpstr,0);
 977             if (SvMAGICAL(hash)) {
 978                 if (SvSMAGICAL(tmpstr))
 979                     mg_set(tmpstr);
 980                 if (!didstore)
 981                     sv_2mortal(tmpstr);
 982             }
 983         }
 984         TAINT_NOT;
 985     }
 986 }
 987
 988 PP(pp_aassign)
 989 {
 990     dSP;
 991     SV **lastlelem = PL_stack_sp;
 992     SV **lastrelem = PL_stack_base + POPMARK;
 993     SV **firstrelem = PL_stack_base + POPMARK + 1;
 994     SV **firstlelem = lastrelem + 1;
 995
 996     register SV **relem;
 997     register SV **lelem;
 998
 999     register SV *sv;
1000     register AV *ary;
1001
1002     I32 gimme;
1003     HV *hash;
1004     I32 i;
1005     int magic;
1006     int duplicates = 0;
1007     SV **firsthashrelem = 0;    /* "= 0" keeps gcc 2.95 quiet  */
1008
1009
1010     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1011     gimme = GIMME_V;
1012
1013     /* If there's a common identifier on both sides we have to take
1014      * special care that assigning the identifier on the left doesn't
1015      * clobber a value on the right that's used later in the list.
1016      */
1017     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1018         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1019         for (relem = firstrelem; relem <= lastrelem; relem++) {
1020             /*SUPPRESS 560*/
1021             if ((sv = *relem)) {
1022                 TAINT_NOT;      /* Each item is independent */
1023                 *relem = sv_mortalcopy(sv);
1024             }
1025         }
1026     }
1027
1028     relem = firstrelem;
1029     lelem = firstlelem;
1030     ary = Null(AV*);
1031     hash = Null(HV*);
1032
1033     while (lelem <= lastlelem) {
1034         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1035         sv = *lelem++;
1036         switch (SvTYPE(sv)) {
1037         case SVt_PVAV:
1038             ary = (AV*)sv;
1039             magic = SvMAGICAL(ary) != 0;
1040             if (PL_op->op_private & OPpASSIGN_HASH) {
1041                 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1042                                        lastrelem))
1043                 {
1044                 case 0:
1045                     goto normal_array;
1046                 case 1:
1047                     do_oddball((HV*)ary, relem, firstrelem);
1048                 }
1049                 relem = lastrelem + 1;
1050                 break;
1051             }
1052         normal_array:
1053             av_clear(ary);
1054             av_extend(ary, lastrelem - relem);
1055             i = 0;
1056             while (relem <= lastrelem) {        /* gobble up all the rest */
1057                 SV **didstore;
1058                 assert(*relem);
1059                 sv = newSVsv(*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_set(sv, SvCUR(sv) - 1);
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              const U8 *s = (U8*)SvPVX(sv) + offset;
1658              const STRLEN len = SvCUR(sv) - offset;
1659              const U8 *f;
1660
1661              if (ckWARN(WARN_UTF8) &&
1662                  !Perl_is_utf8_string_loc(aTHX_ (U8 *) s, len, (U8 **) &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                 SvPV_shrink_to_cur(sv);
1671             }
1672             sv = sv_2mortal(NEWSV(58, 80));
1673             continue;
1674         }
1675         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1676             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1677             const STRLEN new_len
1678                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1679             SvPV_renew(sv, new_len);
1680         }
1681         RETURN;
1682     }
1683 }
1684
1685 PP(pp_enter)
1686 {
1687     dSP;
1688     register PERL_CONTEXT *cx;
1689     I32 gimme = OP_GIMME(PL_op, -1);
1690
1691     if (gimme == -1) {
1692         if (cxstack_ix >= 0)
1693             gimme = cxstack[cxstack_ix].blk_gimme;
1694         else
1695             gimme = G_SCALAR;
1696     }
1697
1698     ENTER;
1699
1700     SAVETMPS;
1701     PUSHBLOCK(cx, CXt_BLOCK, SP);
1702
1703     RETURN;
1704 }
1705
1706 PP(pp_helem)
1707 {
1708     dSP;
1709     HE* he;
1710     SV **svp;
1711     SV *keysv = POPs;
1712     HV *hv = (HV*)POPs;
1713     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1714     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1715     SV *sv;
1716     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1717     I32 preeminent = 0;
1718
1719     if (SvTYPE(hv) == SVt_PVHV) {
1720         if (PL_op->op_private & OPpLVAL_INTRO) {
1721             MAGIC *mg;
1722             HV *stash;
1723             /* does the element we're localizing already exist? */
1724             preeminent =
1725                 /* can we determine whether it exists? */
1726                 (    !SvRMAGICAL(hv)
1727                   || mg_find((SV*)hv, PERL_MAGIC_env)
1728                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1729                         /* Try to preserve the existenceness of a tied hash
1730                          * element by using EXISTS and DELETE if possible.
1731                          * Fallback to FETCH and STORE otherwise */
1732                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1733                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1734                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1735                     )
1736                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1737
1738         }
1739         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1740         svp = he ? &HeVAL(he) : 0;
1741     }
1742     else if (SvTYPE(hv) == SVt_PVAV) {
1743         if (PL_op->op_private & OPpLVAL_INTRO)
1744             DIE(aTHX_ "Can't localize pseudo-hash element");
1745         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1746     }
1747     else {
1748         RETPUSHUNDEF;
1749     }
1750     if (lval) {
1751         if (!svp || *svp == &PL_sv_undef) {
1752             SV* lv;
1753             SV* key2;
1754             if (!defer) {
1755                 DIE(aTHX_ PL_no_helem_sv, keysv);
1756             }
1757             lv = sv_newmortal();
1758             sv_upgrade(lv, SVt_PVLV);
1759             LvTYPE(lv) = 'y';
1760             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1761             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1762             LvTARG(lv) = SvREFCNT_inc(hv);
1763             LvTARGLEN(lv) = 1;
1764             PUSHs(lv);
1765             RETURN;
1766         }
1767         if (PL_op->op_private & OPpLVAL_INTRO) {
1768             if (HvNAME_get(hv) && isGV(*svp))
1769                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1770             else {
1771                 if (!preeminent) {
1772                     STRLEN keylen;
1773                     char *key = SvPV(keysv, keylen);
1774                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1775                 } else
1776                     save_helem(hv, keysv, svp);
1777             }
1778         }
1779         else if (PL_op->op_private & OPpDEREF)
1780             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1781     }
1782     sv = (svp ? *svp : &PL_sv_undef);
1783     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1784      * Pushing the magical RHS on to the stack is useless, since
1785      * that magic is soon destined to be misled by the local(),
1786      * and thus the later pp_sassign() will fail to mg_get() the
1787      * old value.  This should also cure problems with delayed
1788      * mg_get()s.  GSAR 98-07-03 */
1789     if (!lval && SvGMAGICAL(sv))
1790         sv = sv_mortalcopy(sv);
1791     PUSHs(sv);
1792     RETURN;
1793 }
1794
1795 PP(pp_leave)
1796 {
1797     dSP;
1798     register PERL_CONTEXT *cx;
1799     register SV **mark;
1800     SV **newsp;
1801     PMOP *newpm;
1802     I32 gimme;
1803
1804     if (PL_op->op_flags & OPf_SPECIAL) {
1805         cx = &cxstack[cxstack_ix];
1806         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1807     }
1808
1809     POPBLOCK(cx,newpm);
1810
1811     gimme = OP_GIMME(PL_op, -1);
1812     if (gimme == -1) {
1813         if (cxstack_ix >= 0)
1814             gimme = cxstack[cxstack_ix].blk_gimme;
1815         else
1816             gimme = G_SCALAR;
1817     }
1818
1819     TAINT_NOT;
1820     if (gimme == G_VOID)
1821         SP = newsp;
1822     else if (gimme == G_SCALAR) {
1823         MARK = newsp + 1;
1824         if (MARK <= SP) {
1825             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1826                 *MARK = TOPs;
1827             else
1828                 *MARK = sv_mortalcopy(TOPs);
1829         } else {
1830             MEXTEND(mark,0);
1831             *MARK = &PL_sv_undef;
1832         }
1833         SP = MARK;
1834     }
1835     else if (gimme == G_ARRAY) {
1836         /* in case LEAVE wipes old return values */
1837         for (mark = newsp + 1; mark <= SP; mark++) {
1838             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1839                 *mark = sv_mortalcopy(*mark);
1840                 TAINT_NOT;      /* Each item is independent */
1841             }
1842         }
1843     }
1844     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1845
1846     LEAVE;
1847
1848     RETURN;
1849 }
1850
1851 PP(pp_iter)
1852 {
1853     dSP;
1854     register PERL_CONTEXT *cx;
1855     SV *sv, *oldsv;
1856     AV* av;
1857     SV **itersvp;
1858
1859     EXTEND(SP, 1);
1860     cx = &cxstack[cxstack_ix];
1861     if (CxTYPE(cx) != CXt_LOOP)
1862         DIE(aTHX_ "panic: pp_iter");
1863
1864     itersvp = CxITERVAR(cx);
1865     av = cx->blk_loop.iterary;
1866     if (SvTYPE(av) != SVt_PVAV) {
1867         /* iterate ($min .. $max) */
1868         if (cx->blk_loop.iterlval) {
1869             /* string increment */
1870             register SV* cur = cx->blk_loop.iterlval;
1871             STRLEN maxlen = 0;
1872             const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1873             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1874 #ifndef USE_5005THREADS                   /* don't risk potential race */
1875                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1876                     /* safe to reuse old SV */
1877                     sv_setsv(*itersvp, cur);
1878                 }
1879                 else
1880 #endif
1881                 {
1882                     /* we need a fresh SV every time so that loop body sees a
1883                      * completely new SV for closures/references to work as
1884                      * they used to */
1885                     oldsv = *itersvp;
1886                     *itersvp = newSVsv(cur);
1887                     SvREFCNT_dec(oldsv);
1888                 }
1889                 if (strEQ(SvPVX(cur), max))
1890                     sv_setiv(cur, 0); /* terminate next time */
1891                 else
1892                     sv_inc(cur);
1893                 RETPUSHYES;
1894             }
1895             RETPUSHNO;
1896         }
1897         /* integer increment */
1898         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1899             RETPUSHNO;
1900
1901 #ifndef USE_5005THREADS                   /* don't risk potential race */
1902         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1903             /* safe to reuse old SV */
1904             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1905         }
1906         else
1907 #endif
1908         {
1909             /* we need a fresh SV every time so that loop body sees a
1910              * completely new SV for closures/references to work as they
1911              * used to */
1912             oldsv = *itersvp;
1913             *itersvp = newSViv(cx->blk_loop.iterix++);
1914             SvREFCNT_dec(oldsv);
1915         }
1916         RETPUSHYES;
1917     }
1918
1919     /* iterate array */
1920     if (PL_op->op_private & OPpITER_REVERSED) {
1921         /* In reverse, use itermax as the min :-)  */
1922         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1923             RETPUSHNO;
1924
1925         if (SvMAGICAL(av) || AvREIFY(av)) {
1926             SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1927             if (svp)
1928                 sv = *svp;
1929             else
1930                 sv = Nullsv;
1931         }
1932         else {
1933             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1934         }
1935     }
1936     else {
1937         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1938                                     AvFILL(av)))
1939             RETPUSHNO;
1940
1941         if (SvMAGICAL(av) || AvREIFY(av)) {
1942             SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1943             if (svp)
1944                 sv = *svp;
1945             else
1946                 sv = Nullsv;
1947         }
1948         else {
1949             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1950         }
1951     }
1952
1953     if (sv && SvREFCNT(sv) == 0) {
1954         *itersvp = Nullsv;
1955         Perl_croak(aTHX_ "Use of freed value in iteration");
1956     }
1957
1958     if (sv)
1959         SvTEMP_off(sv);
1960     else
1961         sv = &PL_sv_undef;
1962     if (av != PL_curstack && sv == &PL_sv_undef) {
1963         SV *lv = cx->blk_loop.iterlval;
1964         if (lv && SvREFCNT(lv) > 1) {
1965             SvREFCNT_dec(lv);
1966             lv = Nullsv;
1967         }
1968         if (lv)
1969             SvREFCNT_dec(LvTARG(lv));
1970         else {
1971             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1972             sv_upgrade(lv, SVt_PVLV);
1973             LvTYPE(lv) = 'y';
1974             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1975         }
1976         LvTARG(lv) = SvREFCNT_inc(av);
1977         LvTARGOFF(lv) = cx->blk_loop.iterix;
1978         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1979         sv = (SV*)lv;
1980     }
1981
1982     oldsv = *itersvp;
1983     *itersvp = SvREFCNT_inc(sv);
1984     SvREFCNT_dec(oldsv);
1985
1986     RETPUSHYES;
1987 }
1988
1989 PP(pp_subst)
1990 {
1991     dSP; dTARG;
1992     register PMOP *pm = cPMOP;
1993     PMOP *rpm = pm;
1994     register SV *dstr;
1995     register char *s;
1996     char *strend;
1997     register char *m;
1998     char *c;
1999     register char *d;
2000     STRLEN clen;
2001     I32 iters = 0;
2002     I32 maxiters;
2003     register I32 i;
2004     bool once;
2005     bool rxtainted;
2006     char *orig;
2007     I32 r_flags;
2008     register REGEXP *rx = PM_GETRE(pm);
2009     STRLEN len;
2010     int force_on_match = 0;
2011     I32 oldsave = PL_savestack_ix;
2012     STRLEN slen;
2013     bool doutf8 = FALSE;
2014     SV *nsv = Nullsv;
2015
2016     /* known replacement string? */
2017     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
2018     if (PL_op->op_flags & OPf_STACKED)
2019         TARG = POPs;
2020     else {
2021         TARG = DEFSV;
2022         EXTEND(SP,1);
2023     }
2024
2025     if (SvFAKE(TARG) && SvREADONLY(TARG))
2026         sv_force_normal(TARG);
2027     if (SvREADONLY(TARG)
2028         || (SvTYPE(TARG) > SVt_PVLV
2029             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
2030         DIE(aTHX_ PL_no_modify);
2031     PUTBACK;
2032
2033     s = SvPV(TARG, len);
2034     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2035         force_on_match = 1;
2036     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2037                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2038     if (PL_tainted)
2039         rxtainted |= 2;
2040     TAINT_NOT;
2041
2042     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2043
2044   force_it:
2045     if (!pm || !s)
2046         DIE(aTHX_ "panic: pp_subst");
2047
2048     strend = s + len;
2049     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2050     maxiters = 2 * slen + 10;   /* We can match twice at each
2051                                    position, once with zero-length,
2052                                    second time with non-zero. */
2053
2054     if (!rx->prelen && PL_curpm) {
2055         pm = PL_curpm;
2056         rx = PM_GETRE(pm);
2057     }
2058     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2059                 ? REXEC_COPY_STR : 0;
2060     if (SvSCREAM(TARG))
2061         r_flags |= REXEC_SCREAM;
2062     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
2063         SAVEINT(PL_multiline);
2064         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2065     }
2066     orig = m = s;
2067     if (rx->reganch & RE_USE_INTUIT) {
2068         PL_bostr = orig;
2069         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2070
2071         if (!s)
2072             goto nope;
2073         /* How to do it in subst? */
2074 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2075              && !PL_sawampersand
2076              && ((rx->reganch & ROPT_NOSCAN)
2077                  || !((rx->reganch & RE_INTUIT_TAIL)
2078                       && (r_flags & REXEC_SCREAM))))
2079             goto yup;
2080 */
2081     }
2082
2083     /* only replace once? */
2084     once = !(rpm->op_pmflags & PMf_GLOBAL);
2085
2086     /* known replacement string? */
2087     if (dstr) {
2088         /* replacement needing upgrading? */
2089         if (DO_UTF8(TARG) && !doutf8) {
2090              nsv = sv_newmortal();
2091              SvSetSV(nsv, dstr);
2092              if (PL_encoding)
2093                   sv_recode_to_utf8(nsv, PL_encoding);
2094              else
2095                   sv_utf8_upgrade(nsv);
2096              c = SvPV(nsv, clen);
2097              doutf8 = TRUE;
2098         }
2099         else {
2100             c = SvPV(dstr, clen);
2101             doutf8 = DO_UTF8(dstr);
2102         }
2103     }
2104     else {
2105         c = Nullch;
2106         doutf8 = FALSE;
2107     }
2108
2109     /* can do inplace substitution? */
2110     if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2111         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2112         && (!doutf8 || SvUTF8(TARG))) {
2113         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2114                          r_flags | REXEC_CHECKED))
2115         {
2116             SPAGAIN;
2117             PUSHs(&PL_sv_no);
2118             LEAVE_SCOPE(oldsave);
2119             RETURN;
2120         }
2121         if (force_on_match) {
2122             force_on_match = 0;
2123             s = SvPV_force(TARG, len);
2124             goto force_it;
2125         }
2126         d = s;
2127         PL_curpm = pm;
2128         SvSCREAM_off(TARG);     /* disable possible screamer */
2129         if (once) {
2130             rxtainted |= RX_MATCH_TAINTED(rx);
2131             m = orig + rx->startp[0];
2132             d = orig + rx->endp[0];
2133             s = orig;
2134             if (m - s > strend - d) {  /* faster to shorten from end */
2135                 if (clen) {
2136                     Copy(c, m, clen, char);
2137                     m += clen;
2138                 }
2139                 i = strend - d;
2140                 if (i > 0) {
2141                     Move(d, m, i, char);
2142                     m += i;
2143                 }
2144                 *m = '\0';
2145                 SvCUR_set(TARG, m - s);
2146             }
2147             /*SUPPRESS 560*/
2148             else if ((i = m - s)) {     /* faster from front */
2149                 d -= clen;
2150                 m = d;
2151                 sv_chop(TARG, d-i);
2152                 s += i;
2153                 while (i--)
2154                     *--d = *--s;
2155                 if (clen)
2156                     Copy(c, m, clen, char);
2157             }
2158             else if (clen) {
2159                 d -= clen;
2160                 sv_chop(TARG, d);
2161                 Copy(c, d, clen, char);
2162             }
2163             else {
2164                 sv_chop(TARG, d);
2165             }
2166             TAINT_IF(rxtainted & 1);
2167             SPAGAIN;
2168             PUSHs(&PL_sv_yes);
2169         }
2170         else {
2171             do {
2172                 if (iters++ > maxiters)
2173                     DIE(aTHX_ "Substitution loop");
2174                 rxtainted |= RX_MATCH_TAINTED(rx);
2175                 m = rx->startp[0] + orig;
2176                 /*SUPPRESS 560*/
2177                 if ((i = m - s)) {
2178                     if (s != d)
2179                         Move(s, d, i, char);
2180                     d += i;
2181                 }
2182                 if (clen) {
2183                     Copy(c, d, clen, char);
2184                     d += clen;
2185                 }
2186                 s = rx->endp[0] + orig;
2187             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2188                                  TARG, NULL,
2189                                  /* don't match same null twice */
2190                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2191             if (s != d) {
2192                 i = strend - s;
2193                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2194                 Move(s, d, i+1, char);          /* include the NUL */
2195             }
2196             TAINT_IF(rxtainted & 1);
2197             SPAGAIN;
2198             PUSHs(sv_2mortal(newSViv((I32)iters)));
2199         }
2200         (void)SvPOK_only_UTF8(TARG);
2201         TAINT_IF(rxtainted);
2202         if (SvSMAGICAL(TARG)) {
2203             PUTBACK;
2204             mg_set(TARG);
2205             SPAGAIN;
2206         }
2207         SvTAINT(TARG);
2208         if (doutf8)
2209             SvUTF8_on(TARG);
2210         LEAVE_SCOPE(oldsave);
2211         RETURN;
2212     }
2213
2214     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2215                     r_flags | REXEC_CHECKED))
2216     {
2217         if (force_on_match) {
2218             force_on_match = 0;
2219             s = SvPV_force(TARG, len);
2220             goto force_it;
2221         }
2222         rxtainted |= RX_MATCH_TAINTED(rx);
2223         dstr = newSVpvn(m, s-m);
2224         if (DO_UTF8(TARG))
2225             SvUTF8_on(dstr);
2226         PL_curpm = pm;
2227         if (!c) {
2228             register PERL_CONTEXT *cx;
2229             SPAGAIN;
2230             ReREFCNT_inc(rx);
2231             PUSHSUBST(cx);
2232             RETURNOP(cPMOP->op_pmreplroot);
2233         }
2234         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2235         do {
2236             if (iters++ > maxiters)
2237                 DIE(aTHX_ "Substitution loop");
2238             rxtainted |= RX_MATCH_TAINTED(rx);
2239             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2240                 m = s;
2241                 s = orig;
2242                 orig = rx->subbeg;
2243                 s = orig + (m - s);
2244                 strend = s + (strend - m);
2245             }
2246             m = rx->startp[0] + orig;
2247             if (doutf8 && !SvUTF8(dstr))
2248                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2249             else
2250                 sv_catpvn(dstr, s, m-s);
2251             s = rx->endp[0] + orig;
2252             if (clen)
2253                 sv_catpvn(dstr, c, clen);
2254             if (once)
2255                 break;
2256         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2257                              TARG, NULL, r_flags));
2258         if (doutf8 && !DO_UTF8(TARG))
2259             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2260         else
2261             sv_catpvn(dstr, s, strend - s);
2262
2263         SvPV_free(TARG);
2264         SvPV_set(TARG, SvPVX(dstr));
2265         SvCUR_set(TARG, SvCUR(dstr));
2266         SvLEN_set(TARG, SvLEN(dstr));
2267         doutf8 |= DO_UTF8(dstr);
2268         SvPV_set(dstr, (char*)0);
2269         sv_free(dstr);
2270
2271         TAINT_IF(rxtainted & 1);
2272         SPAGAIN;
2273         PUSHs(sv_2mortal(newSViv((I32)iters)));
2274
2275         (void)SvPOK_only(TARG);
2276         if (doutf8)
2277             SvUTF8_on(TARG);
2278         TAINT_IF(rxtainted);
2279         SvSETMAGIC(TARG);
2280         SvTAINT(TARG);
2281         LEAVE_SCOPE(oldsave);
2282         RETURN;
2283     }
2284     goto ret_no;
2285
2286 nope:
2287 ret_no:
2288     SPAGAIN;
2289     PUSHs(&PL_sv_no);
2290     LEAVE_SCOPE(oldsave);
2291     RETURN;
2292 }
2293
2294 PP(pp_grepwhile)
2295 {
2296     dSP;
2297
2298     if (SvTRUEx(POPs))
2299         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2300     ++*PL_markstack_ptr;
2301     LEAVE;                                      /* exit inner scope */
2302
2303     /* All done yet? */
2304     if (PL_stack_base + *PL_markstack_ptr > SP) {
2305         I32 items;
2306         I32 gimme = GIMME_V;
2307
2308         LEAVE;                                  /* exit outer scope */
2309         (void)POPMARK;                          /* pop src */
2310         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2311         (void)POPMARK;                          /* pop dst */
2312         SP = PL_stack_base + POPMARK;           /* pop original mark */
2313         if (gimme == G_SCALAR) {
2314             dTARGET;
2315             XPUSHi(items);
2316         }
2317         else if (gimme == G_ARRAY)
2318             SP += items;
2319         RETURN;
2320     }
2321     else {
2322         SV *src;
2323
2324         ENTER;                                  /* enter inner scope */
2325         SAVEVPTR(PL_curpm);
2326
2327         src = PL_stack_base[*PL_markstack_ptr];
2328         SvTEMP_off(src);
2329         DEFSV = src;
2330
2331         RETURNOP(cLOGOP->op_other);
2332     }
2333 }
2334
2335 PP(pp_leavesub)
2336 {
2337     dSP;
2338     SV **mark;
2339     SV **newsp;
2340     PMOP *newpm;
2341     I32 gimme;
2342     register PERL_CONTEXT *cx;
2343     SV *sv;
2344
2345     POPBLOCK(cx,newpm);
2346     cxstack_ix++; /* temporarily protect top context */
2347
2348     TAINT_NOT;
2349     if (gimme == G_SCALAR) {
2350         MARK = newsp + 1;
2351         if (MARK <= SP) {
2352             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2353                 if (SvTEMP(TOPs)) {
2354                     *MARK = SvREFCNT_inc(TOPs);
2355                     FREETMPS;
2356                     sv_2mortal(*MARK);
2357                 }
2358                 else {
2359                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2360                     FREETMPS;
2361                     *MARK = sv_mortalcopy(sv);
2362                     SvREFCNT_dec(sv);
2363                 }
2364             }
2365             else
2366                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2367         }
2368         else {
2369             MEXTEND(MARK, 0);
2370             *MARK = &PL_sv_undef;
2371         }
2372         SP = MARK;
2373     }
2374     else if (gimme == G_ARRAY) {
2375         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2376             if (!SvTEMP(*MARK)) {
2377                 *MARK = sv_mortalcopy(*MARK);
2378                 TAINT_NOT;      /* Each item is independent */
2379             }
2380         }
2381     }
2382     PUTBACK;
2383
2384     LEAVE;
2385     cxstack_ix--;
2386     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2387     PL_curpm = newpm;   /* ... and pop $1 et al */
2388
2389     LEAVESUB(sv);
2390     return pop_return();
2391 }
2392
2393 /* This duplicates the above code because the above code must not
2394  * get any slower by more conditions */
2395 PP(pp_leavesublv)
2396 {
2397     dSP;
2398     SV **mark;
2399     SV **newsp;
2400     PMOP *newpm;
2401     I32 gimme;
2402     register PERL_CONTEXT *cx;
2403     SV *sv;
2404
2405     POPBLOCK(cx,newpm);
2406     cxstack_ix++; /* temporarily protect top context */
2407
2408     TAINT_NOT;
2409
2410     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2411         /* We are an argument to a function or grep().
2412          * This kind of lvalueness was legal before lvalue
2413          * subroutines too, so be backward compatible:
2414          * cannot report errors.  */
2415
2416         /* Scalar context *is* possible, on the LHS of -> only,
2417          * as in f()->meth().  But this is not an lvalue. */
2418         if (gimme == G_SCALAR)
2419             goto temporise;
2420         if (gimme == G_ARRAY) {
2421             if (!CvLVALUE(cx->blk_sub.cv))
2422                 goto temporise_array;
2423             EXTEND_MORTAL(SP - newsp);
2424             for (mark = newsp + 1; mark <= SP; mark++) {
2425                 if (SvTEMP(*mark))
2426                     /* empty */ ;
2427                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2428                     *mark = sv_mortalcopy(*mark);
2429                 else {
2430                     /* Can be a localized value subject to deletion. */
2431                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2432                     (void)SvREFCNT_inc(*mark);
2433                 }
2434             }
2435         }
2436     }
2437     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2438         /* Here we go for robustness, not for speed, so we change all
2439          * the refcounts so the caller gets a live guy. Cannot set
2440          * TEMP, so sv_2mortal is out of question. */
2441         if (!CvLVALUE(cx->blk_sub.cv)) {
2442             LEAVE;
2443             cxstack_ix--;
2444             POPSUB(cx,sv);
2445             PL_curpm = newpm;
2446             LEAVESUB(sv);
2447             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2448         }
2449         if (gimme == G_SCALAR) {
2450             MARK = newsp + 1;
2451             EXTEND_MORTAL(1);
2452             if (MARK == SP) {
2453                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2454                     LEAVE;
2455                     cxstack_ix--;
2456                     POPSUB(cx,sv);
2457                     PL_curpm = newpm;
2458                     LEAVESUB(sv);
2459                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2460                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2461                         : "a readonly value" : "a temporary");
2462                 }
2463                 else {                  /* Can be a localized value
2464                                          * subject to deletion. */
2465                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2466                     (void)SvREFCNT_inc(*mark);
2467                 }
2468             }
2469             else {                      /* Should not happen? */
2470                 LEAVE;
2471                 cxstack_ix--;
2472                 POPSUB(cx,sv);
2473                 PL_curpm = newpm;
2474                 LEAVESUB(sv);
2475                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2476                     (MARK > SP ? "Empty array" : "Array"));
2477             }
2478             SP = MARK;
2479         }
2480         else if (gimme == G_ARRAY) {
2481             EXTEND_MORTAL(SP - newsp);
2482             for (mark = newsp + 1; mark <= SP; mark++) {
2483                 if (*mark != &PL_sv_undef
2484                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2485                     /* Might be flattened array after $#array =  */
2486                     PUTBACK;
2487                     LEAVE;
2488                     cxstack_ix--;
2489                     POPSUB(cx,sv);
2490                     PL_curpm = newpm;
2491                     LEAVESUB(sv);
2492                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2493                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2494                 }
2495                 else {
2496                     /* Can be a localized value subject to deletion. */
2497                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2498                     (void)SvREFCNT_inc(*mark);
2499                 }
2500             }
2501         }
2502     }
2503     else {
2504         if (gimme == G_SCALAR) {
2505           temporise:
2506             MARK = newsp + 1;
2507             if (MARK <= SP) {
2508                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2509                     if (SvTEMP(TOPs)) {
2510                         *MARK = SvREFCNT_inc(TOPs);
2511                         FREETMPS;
2512                         sv_2mortal(*MARK);
2513                     }
2514                     else {
2515                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2516                         FREETMPS;
2517                         *MARK = sv_mortalcopy(sv);
2518                         SvREFCNT_dec(sv);
2519                     }
2520                 }
2521                 else
2522                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2523             }
2524             else {
2525                 MEXTEND(MARK, 0);
2526                 *MARK = &PL_sv_undef;
2527             }
2528             SP = MARK;
2529         }
2530         else if (gimme == G_ARRAY) {
2531           temporise_array:
2532             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2533                 if (!SvTEMP(*MARK)) {
2534                     *MARK = sv_mortalcopy(*MARK);
2535                     TAINT_NOT;  /* Each item is independent */
2536                 }
2537             }
2538         }
2539     }
2540     PUTBACK;
2541
2542     LEAVE;
2543     cxstack_ix--;
2544     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2545     PL_curpm = newpm;   /* ... and pop $1 et al */
2546
2547     LEAVESUB(sv);
2548     return pop_return();
2549 }
2550
2551
2552 STATIC CV *
2553 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2554 {
2555     SV *dbsv = GvSV(PL_DBsub);
2556
2557     save_item(dbsv);
2558     if (!PERLDB_SUB_NN) {
2559         GV *gv = CvGV(cv);
2560
2561         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2562              || strEQ(GvNAME(gv), "END")
2563              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2564                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2565                     && (gv = (GV*)*svp) ))) {
2566             /* Use GV from the stack as a fallback. */
2567             /* GV is potentially non-unique, or contain different CV. */
2568             SV *tmp = newRV((SV*)cv);
2569             sv_setsv(dbsv, tmp);
2570             SvREFCNT_dec(tmp);
2571         }
2572         else {
2573             gv_efullname3(dbsv, gv, Nullch);
2574         }
2575     }
2576     else {
2577         const int type = SvTYPE(dbsv);
2578         if (type < SVt_PVIV && type != SVt_IV)
2579             sv_upgrade(dbsv, SVt_PVIV);
2580         (void)SvIOK_on(dbsv);
2581         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2582     }
2583
2584     if (CvXSUB(cv))
2585         PL_curcopdb = PL_curcop;
2586     cv = GvCV(PL_DBsub);
2587     return cv;
2588 }
2589
2590 PP(pp_entersub)
2591 {
2592     dSP; dPOPss;
2593     GV *gv;
2594     HV *stash;
2595     register CV *cv;
2596     register PERL_CONTEXT *cx;
2597     I32 gimme;
2598     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2599
2600     if (!sv)
2601         DIE(aTHX_ "Not a CODE reference");
2602     switch (SvTYPE(sv)) {
2603     default:
2604         if (!SvROK(sv)) {
2605             const char *sym;
2606             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2607                 if (hasargs)
2608                     SP = PL_stack_base + POPMARK;
2609                 RETURN;
2610             }
2611             if (SvGMAGICAL(sv)) {
2612                 mg_get(sv);
2613                 if (SvROK(sv))
2614                     goto got_rv;
2615                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2616             }
2617             else {
2618                 STRLEN n_a;
2619                 sym = SvPV(sv, n_a);
2620             }
2621             if (!sym)
2622                 DIE(aTHX_ PL_no_usym, "a subroutine");
2623             if (PL_op->op_private & HINT_STRICT_REFS)
2624                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2625             cv = get_cv(sym, TRUE);
2626             break;
2627         }
2628   got_rv:
2629         {
2630             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2631             tryAMAGICunDEREF(to_cv);
2632         }
2633         cv = (CV*)SvRV(sv);
2634         if (SvTYPE(cv) == SVt_PVCV)
2635             break;
2636         /* FALL THROUGH */
2637     case SVt_PVHV:
2638     case SVt_PVAV:
2639         DIE(aTHX_ "Not a CODE reference");
2640     case SVt_PVCV:
2641         cv = (CV*)sv;
2642         break;
2643     case SVt_PVGV:
2644         if (!(cv = GvCVu((GV*)sv)))
2645             cv = sv_2cv(sv, &stash, &gv, FALSE);
2646         if (!cv) {
2647             ENTER;
2648             SAVETMPS;
2649             goto try_autoload;
2650         }
2651         break;
2652     }
2653
2654     ENTER;
2655     SAVETMPS;
2656
2657   retry:
2658     if (!CvROOT(cv) && !CvXSUB(cv)) {
2659         GV* autogv;
2660         SV* sub_name;
2661
2662         /* anonymous or undef'd function leaves us no recourse */
2663         if (CvANON(cv) || !(gv = CvGV(cv)))
2664             DIE(aTHX_ "Undefined subroutine called");
2665
2666         /* autoloaded stub? */
2667         if (cv != GvCV(gv)) {
2668             cv = GvCV(gv);
2669         }
2670         /* should call AUTOLOAD now? */
2671         else {
2672 try_autoload:
2673             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2674                                    FALSE)))
2675             {
2676                 cv = GvCV(autogv);
2677             }
2678             /* sorry */
2679             else {
2680                 sub_name = sv_newmortal();
2681                 gv_efullname3(sub_name, gv, Nullch);
2682                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2683             }
2684         }
2685         if (!cv)
2686             DIE(aTHX_ "Not a CODE reference");
2687         goto retry;
2688     }
2689
2690     gimme = GIMME_V;
2691     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2692         cv = get_db_sub(&sv, cv);
2693         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2694             DIE(aTHX_ "No DB::sub routine defined");
2695     }
2696
2697 #ifdef USE_5005THREADS
2698     /*
2699      * First we need to check if the sub or method requires locking.
2700      * If so, we gain a lock on the CV, the first argument or the
2701      * stash (for static methods), as appropriate. This has to be
2702      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2703      * reschedule by returning a new op.
2704      */
2705     MUTEX_LOCK(CvMUTEXP(cv));
2706     if (CvFLAGS(cv) & CVf_LOCKED) {
2707         MAGIC *mg;
2708         if (CvFLAGS(cv) & CVf_METHOD) {
2709             if (SP > PL_stack_base + TOPMARK)
2710                 sv = *(PL_stack_base + TOPMARK + 1);
2711             else {
2712                 AV *av = (AV*)PAD_SVl(0);
2713                 if (hasargs || !av || AvFILLp(av) < 0
2714                     || !(sv = AvARRAY(av)[0]))
2715                 {
2716                     MUTEX_UNLOCK(CvMUTEXP(cv));
2717                     DIE(aTHX_ "no argument for locked method call");
2718                 }
2719             }
2720             if (SvROK(sv))
2721                 sv = SvRV(sv);
2722             else {
2723                 STRLEN len;
2724                 char *stashname = SvPV(sv, len);
2725                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2726             }
2727         }
2728         else {
2729             sv = (SV*)cv;
2730         }
2731         MUTEX_UNLOCK(CvMUTEXP(cv));
2732         mg = condpair_magic(sv);
2733         MUTEX_LOCK(MgMUTEXP(mg));
2734         if (MgOWNER(mg) == thr)
2735             MUTEX_UNLOCK(MgMUTEXP(mg));
2736         else {
2737             while (MgOWNER(mg))
2738                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2739             MgOWNER(mg) = thr;
2740             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2741                                   thr, sv));
2742             MUTEX_UNLOCK(MgMUTEXP(mg));
2743             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2744         }
2745         MUTEX_LOCK(CvMUTEXP(cv));
2746     }
2747     /*
2748      * Now we have permission to enter the sub, we must distinguish
2749      * four cases. (0) It's an XSUB (in which case we don't care
2750      * about ownership); (1) it's ours already (and we're recursing);
2751      * (2) it's free (but we may already be using a cached clone);
2752      * (3) another thread owns it. Case (1) is easy: we just use it.
2753      * Case (2) means we look for a clone--if we have one, use it
2754      * otherwise grab ownership of cv. Case (3) means we look for a
2755      * clone (for non-XSUBs) and have to create one if we don't
2756      * already have one.
2757      * Why look for a clone in case (2) when we could just grab
2758      * ownership of cv straight away? Well, we could be recursing,
2759      * i.e. we originally tried to enter cv while another thread
2760      * owned it (hence we used a clone) but it has been freed up
2761      * and we're now recursing into it. It may or may not be "better"
2762      * to use the clone but at least CvDEPTH can be trusted.
2763      */
2764     if (CvOWNER(cv) == thr || CvXSUB(cv))
2765         MUTEX_UNLOCK(CvMUTEXP(cv));
2766     else {
2767         /* Case (2) or (3) */
2768         SV **svp;
2769
2770         /*
2771          * XXX Might it be better to release CvMUTEXP(cv) while we
2772          * do the hv_fetch? We might find someone has pinched it
2773          * when we look again, in which case we would be in case
2774          * (3) instead of (2) so we'd have to clone. Would the fact
2775          * that we released the mutex more quickly make up for this?
2776          */
2777         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2778         {
2779             /* We already have a clone to use */
2780             MUTEX_UNLOCK(CvMUTEXP(cv));
2781             cv = *(CV**)svp;
2782             DEBUG_S(PerlIO_printf(Perl_debug_log,
2783                                   "entersub: %p already has clone %p:%s\n",
2784                                   thr, cv, SvPEEK((SV*)cv)));
2785             CvOWNER(cv) = thr;
2786             SvREFCNT_inc(cv);
2787             if (CvDEPTH(cv) == 0)
2788                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2789         }
2790         else {
2791             /* (2) => grab ownership of cv. (3) => make clone */
2792             if (!CvOWNER(cv)) {
2793                 CvOWNER(cv) = thr;
2794                 SvREFCNT_inc(cv);
2795                 MUTEX_UNLOCK(CvMUTEXP(cv));
2796                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2797                             "entersub: %p grabbing %p:%s in stash %s\n",
2798                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2799                                 HvNAME(CvSTASH(cv)) : "(none)"));
2800             }
2801             else {
2802                 /* Make a new clone. */
2803                 CV *clonecv;
2804                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2805                 MUTEX_UNLOCK(CvMUTEXP(cv));
2806                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2807                                        "entersub: %p cloning %p:%s\n",
2808                                        thr, cv, SvPEEK((SV*)cv))));
2809                 /*
2810                  * We're creating a new clone so there's no race
2811                  * between the original MUTEX_UNLOCK and the
2812                  * SvREFCNT_inc since no one will be trying to undef
2813                  * it out from underneath us. At least, I don't think
2814                  * there's a race...
2815                  */
2816                 clonecv = cv_clone(cv);
2817                 SvREFCNT_dec(cv); /* finished with this */
2818                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2819                 CvOWNER(clonecv) = thr;
2820                 cv = clonecv;
2821                 SvREFCNT_inc(cv);
2822             }
2823             DEBUG_S(if (CvDEPTH(cv) != 0)
2824                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2825                                      CvDEPTH(cv)));
2826             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2827         }
2828     }
2829 #endif /* USE_5005THREADS */
2830
2831     if (CvXSUB(cv)) {
2832 #ifdef PERL_XSUB_OLDSTYLE
2833         if (CvOLDSTYLE(cv)) {
2834             I32 (*fp3)(int,int,int);
2835             dMARK;
2836             register I32 items = SP - MARK;
2837                                         /* We dont worry to copy from @_. */
2838             while (SP > mark) {
2839                 SP[1] = SP[0];
2840                 SP--;
2841             }
2842             PL_stack_sp = mark + 1;
2843             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2844             items = (*fp3)(CvXSUBANY(cv).any_i32,
2845                            MARK - PL_stack_base + 1,
2846                            items);
2847             PL_stack_sp = PL_stack_base + items;
2848         }
2849         else
2850 #endif /* PERL_XSUB_OLDSTYLE */
2851         {
2852             I32 markix = TOPMARK;
2853
2854             PUTBACK;
2855
2856             if (!hasargs) {
2857                 /* Need to copy @_ to stack. Alternative may be to
2858                  * switch stack to @_, and copy return values
2859                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2860                 AV* av;
2861                 I32 items;
2862 #ifdef USE_5005THREADS
2863                 av = (AV*)PAD_SVl(0);
2864 #else
2865                 av = GvAV(PL_defgv);
2866 #endif /* USE_5005THREADS */
2867                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2868
2869                 if (items) {
2870                     /* Mark is at the end of the stack. */
2871                     EXTEND(SP, items);
2872                     Copy(AvARRAY(av), SP + 1, items, SV*);
2873                     SP += items;
2874                     PUTBACK ;
2875                 }
2876             }
2877             /* We assume first XSUB in &DB::sub is the called one. */
2878             if (PL_curcopdb) {
2879                 SAVEVPTR(PL_curcop);
2880                 PL_curcop = PL_curcopdb;
2881                 PL_curcopdb = NULL;
2882             }
2883             /* Do we need to open block here? XXXX */
2884             (void)(*CvXSUB(cv))(aTHX_ cv);
2885
2886             /* Enforce some sanity in scalar context. */
2887             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2888                 if (markix > PL_stack_sp - PL_stack_base)
2889                     *(PL_stack_base + markix) = &PL_sv_undef;
2890                 else
2891                     *(PL_stack_base + markix) = *PL_stack_sp;
2892                 PL_stack_sp = PL_stack_base + markix;
2893             }
2894         }
2895         LEAVE;
2896         return NORMAL;
2897     }
2898     else {
2899         dMARK;
2900         register I32 items = SP - MARK;
2901         AV* padlist = CvPADLIST(cv);
2902         push_return(PL_op->op_next);
2903         PUSHBLOCK(cx, CXt_SUB, MARK);
2904         PUSHSUB(cx);
2905         CvDEPTH(cv)++;
2906         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2907          * that eval'' ops within this sub know the correct lexical space.
2908          * Owing the speed considerations, we choose instead to search for
2909          * the cv using find_runcv() when calling doeval().
2910          */
2911         if (CvDEPTH(cv) >= 2) {
2912             PERL_STACK_OVERFLOW_CHECK();
2913             pad_push(padlist, CvDEPTH(cv), 1);
2914         }
2915 #ifdef USE_5005THREADS
2916         if (!hasargs) {
2917             AV* av = (AV*)PAD_SVl(0);
2918
2919             items = AvFILLp(av) + 1;
2920             if (items) {
2921                 /* Mark is at the end of the stack. */
2922                 EXTEND(SP, items);
2923                 Copy(AvARRAY(av), SP + 1, items, SV*);
2924                 SP += items;
2925                 PUTBACK ;
2926             }
2927         }
2928 #endif /* USE_5005THREADS */
2929         PAD_SET_CUR(padlist, CvDEPTH(cv));
2930 #ifndef USE_5005THREADS
2931         if (hasargs)
2932 #endif /* USE_5005THREADS */
2933         {
2934             AV* av;
2935             SV** ary;
2936
2937 #if 0
2938             DEBUG_S(PerlIO_printf(Perl_debug_log,
2939                                   "%p entersub preparing @_\n", thr));
2940 #endif
2941             av = (AV*)PAD_SVl(0);
2942             if (AvREAL(av)) {
2943                 /* @_ is normally not REAL--this should only ever
2944                  * happen when DB::sub() calls things that modify @_ */
2945                 av_clear(av);
2946                 AvREAL_off(av);
2947                 AvREIFY_on(av);
2948             }
2949 #ifndef USE_5005THREADS
2950             cx->blk_sub.savearray = GvAV(PL_defgv);
2951             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2952 #endif /* USE_5005THREADS */
2953             CX_CURPAD_SAVE(cx->blk_sub);
2954             cx->blk_sub.argarray = av;
2955             ++MARK;
2956
2957             if (items > AvMAX(av) + 1) {
2958                 ary = AvALLOC(av);
2959                 if (AvARRAY(av) != ary) {
2960                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2961                     SvPVX(av) = (char*)ary;
2962                 }
2963                 if (items > AvMAX(av) + 1) {
2964                     AvMAX(av) = items - 1;
2965                     Renew(ary,items,SV*);
2966                     AvALLOC(av) = ary;
2967                     SvPVX(av) = (char*)ary;
2968                 }
2969             }
2970             Copy(MARK,AvARRAY(av),items,SV*);
2971             AvFILLp(av) = items - 1;
2972
2973             while (items--) {
2974                 if (*MARK)
2975                     SvTEMP_off(*MARK);
2976                 MARK++;
2977             }
2978         }
2979         /* warning must come *after* we fully set up the context
2980          * stuff so that __WARN__ handlers can safely dounwind()
2981          * if they want to
2982          */
2983         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2984             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2985             sub_crush_depth(cv);
2986 #if 0
2987         DEBUG_S(PerlIO_printf(Perl_debug_log,
2988                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2989 #endif
2990         RETURNOP(CvSTART(cv));
2991     }
2992 }
2993
2994 void
2995 Perl_sub_crush_depth(pTHX_ CV *cv)
2996 {
2997     if (CvANON(cv))
2998         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2999     else {
3000         SV* tmpstr = sv_newmortal();
3001         gv_efullname3(tmpstr, CvGV(cv), Nullch);
3002         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3003                 tmpstr);
3004     }
3005 }
3006
3007 PP(pp_aelem)
3008 {
3009     dSP;
3010     SV** svp;
3011     SV* elemsv = POPs;
3012     IV elem = SvIV(elemsv);
3013     AV* av = (AV*)POPs;
3014     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3015     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3016     SV *sv;
3017
3018     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3019         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
3020     if (elem > 0)
3021         elem -= PL_curcop->cop_arybase;
3022     if (SvTYPE(av) != SVt_PVAV)
3023         RETPUSHUNDEF;
3024     svp = av_fetch(av, elem, lval && !defer);
3025     if (lval) {
3026 #ifdef PERL_MALLOC_WRAP
3027          static const char oom_array_extend[] =
3028               "Out of memory during array extend"; /* Duplicated in av.c */
3029          if (SvUOK(elemsv)) {
3030               const UV uv = SvUV(elemsv);
3031               elem = uv > IV_MAX ? IV_MAX : uv;
3032          }
3033          else if (SvNOK(elemsv))
3034               elem = (IV)SvNV(elemsv);
3035          if (elem > 0)
3036               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3037 #endif
3038         if (!svp || *svp == &PL_sv_undef) {
3039             SV* lv;
3040             if (!defer)
3041                 DIE(aTHX_ PL_no_aelem, elem);
3042             lv = sv_newmortal();
3043             sv_upgrade(lv, SVt_PVLV);
3044             LvTYPE(lv) = 'y';
3045             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
3046             LvTARG(lv) = SvREFCNT_inc(av);
3047             LvTARGOFF(lv) = elem;
3048             LvTARGLEN(lv) = 1;
3049             PUSHs(lv);
3050             RETURN;
3051         }
3052         if (PL_op->op_private & OPpLVAL_INTRO)
3053             save_aelem(av, elem, svp);
3054         else if (PL_op->op_private & OPpDEREF)
3055             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3056     }
3057     sv = (svp ? *svp : &PL_sv_undef);
3058     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
3059         sv = sv_mortalcopy(sv);
3060     PUSHs(sv);
3061     RETURN;
3062 }
3063
3064 void
3065 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3066 {
3067     if (SvGMAGICAL(sv))
3068         mg_get(sv);
3069     if (!SvOK(sv)) {
3070         if (SvREADONLY(sv))
3071             Perl_croak(aTHX_ PL_no_modify);
3072         if (SvTYPE(sv) < SVt_RV)
3073             sv_upgrade(sv, SVt_RV);
3074         else if (SvTYPE(sv) >= SVt_PV) {
3075             SvPV_free(sv);
3076             SvLEN_set(sv, 0);
3077             SvCUR_set(sv, 0);
3078         }
3079         switch (to_what) {
3080         case OPpDEREF_SV:
3081             SvRV_set(sv, NEWSV(355,0));
3082             break;
3083         case OPpDEREF_AV:
3084             SvRV_set(sv, (SV*)newAV());
3085             break;
3086         case OPpDEREF_HV:
3087             SvRV_set(sv, (SV*)newHV());
3088             break;
3089         }
3090         SvROK_on(sv);
3091         SvSETMAGIC(sv);
3092     }
3093 }
3094
3095 PP(pp_method)
3096 {
3097     dSP;
3098     SV* sv = TOPs;
3099
3100     if (SvROK(sv)) {
3101         SV* rsv = SvRV(sv);
3102         if (SvTYPE(rsv) == SVt_PVCV) {
3103             SETs(rsv);
3104             RETURN;
3105         }
3106     }
3107
3108     SETs(method_common(sv, Null(U32*)));
3109     RETURN;
3110 }
3111
3112 PP(pp_method_named)
3113 {
3114     dSP;
3115     SV* sv = cSVOP_sv;
3116     U32 hash = SvUVX(sv);
3117
3118     XPUSHs(method_common(sv, &hash));
3119     RETURN;
3120 }
3121
3122 STATIC SV *
3123 S_method_common(pTHX_ SV* meth, U32* hashp)
3124 {
3125     SV* sv;
3126     SV* ob;
3127     GV* gv;
3128     HV* stash;
3129     STRLEN namelen;
3130     const char* packname = 0;
3131     SV *packsv = Nullsv;
3132     STRLEN packlen;
3133     const char *name = SvPV(meth, namelen);
3134
3135     sv = *(PL_stack_base + TOPMARK + 1);
3136
3137     if (!sv)
3138         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3139
3140     if (SvGMAGICAL(sv))
3141         mg_get(sv);
3142     if (SvROK(sv))
3143         ob = (SV*)SvRV(sv);
3144     else {
3145         GV* iogv;
3146
3147         /* this isn't a reference */
3148         packname = Nullch;
3149
3150         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3151           HE* he;
3152           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3153           if (he) {
3154             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3155             goto fetch;
3156           }
3157         }
3158
3159         if (!SvOK(sv) ||
3160             !(packname) ||
3161             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3162             !(ob=(SV*)GvIO(iogv)))
3163         {
3164             /* this isn't the name of a filehandle either */
3165             if (!packname ||
3166                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3167                     ? !isIDFIRST_utf8((U8*)packname)
3168                     : !isIDFIRST(*packname)
3169                 ))
3170             {
3171                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3172                            SvOK(sv) ? "without a package or object reference"
3173                                     : "on an undefined value");
3174             }
3175             /* assume it's a package name */
3176             stash = gv_stashpvn(packname, packlen, FALSE);
3177             if (!stash)
3178                 packsv = sv;
3179             else {
3180                 SV* ref = newSViv(PTR2IV(stash));
3181                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3182             }
3183             goto fetch;
3184         }
3185         /* it _is_ a filehandle name -- replace with a reference */
3186         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3187     }
3188
3189     /* if we got here, ob should be a reference or a glob */
3190     if (!ob || !(SvOBJECT(ob)
3191                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3192                      && SvOBJECT(ob))))
3193     {
3194         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3195                    name);
3196     }
3197
3198     stash = SvSTASH(ob);
3199
3200   fetch:
3201     /* NOTE: stash may be null, hope hv_fetch_ent and
3202        gv_fetchmethod can cope (it seems they can) */
3203
3204     /* shortcut for simple names */
3205     if (hashp) {
3206         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3207         if (he) {
3208             gv = (GV*)HeVAL(he);
3209             if (isGV(gv) && GvCV(gv) &&
3210                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3211                 return (SV*)GvCV(gv);
3212         }
3213     }
3214
3215     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3216
3217     if (!gv) {
3218         /* This code tries to figure out just what went wrong with
3219            gv_fetchmethod.  It therefore needs to duplicate a lot of
3220            the internals of that function.  We can't move it inside
3221            Perl_gv_fetchmethod_autoload(), however, since that would
3222            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3223            don't want that.
3224         */
3225         const char* leaf = name;
3226         const char* sep = Nullch;
3227         const char* p;
3228
3229         for (p = name; *p; p++) {
3230             if (*p == '\'')
3231                 sep = p, leaf = p + 1;
3232             else if (*p == ':' && *(p + 1) == ':')
3233                 sep = p, leaf = p + 2;
3234         }
3235         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3236             /* the method name is unqualified or starts with SUPER:: */
3237             packname = sep ? CopSTASHPV(PL_curcop) :
3238                 stash ? HvNAME_get(stash) : packname;
3239             if (!packname)
3240                 Perl_croak(aTHX_
3241                            "Can't use anonymous symbol table for method lookup");
3242             else
3243                 packlen = strlen(packname);
3244         }
3245         else {
3246             /* the method name is qualified */
3247             packname = name;
3248             packlen = sep - name;
3249         }
3250
3251         /* we're relying on gv_fetchmethod not autovivifying the stash */
3252         if (gv_stashpvn(packname, packlen, FALSE)) {
3253             Perl_croak(aTHX_
3254                        "Can't locate object method \"%s\" via package \"%.*s\"",
3255                        leaf, (int)packlen, packname);
3256         }
3257         else {
3258             Perl_croak(aTHX_
3259                        "Can't locate object method \"%s\" via package \"%.*s\""
3260                        " (perhaps you forgot to load \"%.*s\"?)",
3261                        leaf, (int)packlen, packname, (int)packlen, packname);
3262         }
3263     }
3264     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3265 }
3266
3267 #ifdef USE_5005THREADS
3268 static void
3269 unset_cvowner(pTHX_ void *cvarg)
3270 {
3271     register CV* cv = (CV *) cvarg;
3272
3273     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3274                            thr, cv, SvPEEK((SV*)cv))));
3275     MUTEX_LOCK(CvMUTEXP(cv));
3276     DEBUG_S(if (CvDEPTH(cv) != 0)
3277                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3278                              CvDEPTH(cv)));
3279     assert(thr == CvOWNER(cv));
3280     CvOWNER(cv) = 0;
3281     MUTEX_UNLOCK(CvMUTEXP(cv));
3282     SvREFCNT_dec(cv);
3283 }
3284 #endif /* USE_5005THREADS */
3285
3286 /*
3287  * Local variables:
3288  * c-indentation-style: bsd
3289  * c-basic-offset: 4
3290  * indent-tabs-mode: t
3291  * End:
3292  *
3293  * ex: set ts=8 sts=4 sw=4 noet:
3294  */