pp_hot.c

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