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