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         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1280
1281         if (!s)
1282             goto nope;
1283         if ( (rx->reganch & ROPT_CHECK_ALL)
1284              && !PL_sawampersand
1285              && ((rx->reganch & ROPT_NOSCAN)
1286                  || !((rx->reganch & RE_INTUIT_TAIL)
1287                       && (r_flags & REXEC_SCREAM)))
1288              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1289             goto yup;
1290     }
1291     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1292     {
1293         PL_curpm = pm;
1294         if (pm->op_pmflags & PMf_ONCE)
1295             pm->op_pmdynflags |= PMdf_USED;
1296         goto gotcha;
1297     }
1298     else
1299         goto ret_no;
1300     /*NOTREACHED*/
1301
1302   gotcha:
1303     if (rxtainted)
1304         RX_MATCH_TAINTED_on(rx);
1305     TAINT_IF(RX_MATCH_TAINTED(rx));
1306     if (gimme == G_ARRAY) {
1307         I32 nparens, i, len;
1308
1309         nparens = rx->nparens;
1310         if (global && !nparens)
1311             i = 1;
1312         else
1313             i = 0;
1314         SPAGAIN;                        /* EVAL blocks could move the stack. */
1315         EXTEND(SP, nparens + i);
1316         EXTEND_MORTAL(nparens + i);
1317         for (i = !i; i <= nparens; i++) {
1318             PUSHs(sv_newmortal());
1319             /*SUPPRESS 560*/
1320             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321                 len = rx->endp[i] - rx->startp[i];
1322                 s = rx->startp[i] + truebase;
1323                 sv_setpvn(*SP, s, len);
1324                 if (DO_UTF8(TARG))
1325                     SvUTF8_on(*SP);
1326             }
1327         }
1328         if (global) {
1329             had_zerolen = (rx->startp[0] != -1
1330                            && rx->startp[0] == rx->endp[0]);
1331             PUTBACK;                    /* EVAL blocks may use stack */
1332             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1333             goto play_it_again;
1334         }
1335         else if (!nparens)
1336             XPUSHs(&PL_sv_yes);
1337         LEAVE_SCOPE(oldsave);
1338         RETURN;
1339     }
1340     else {
1341         if (global) {
1342             MAGIC* mg = 0;
1343             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344                 mg = mg_find(TARG, 'g');
1345             if (!mg) {
1346                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1347                 mg = mg_find(TARG, 'g');
1348             }
1349             if (rx->startp[0] != -1) {
1350                 mg->mg_len = rx->endp[0];
1351                 if (rx->startp[0] == rx->endp[0])
1352                     mg->mg_flags |= MGf_MINMATCH;
1353                 else
1354                     mg->mg_flags &= ~MGf_MINMATCH;
1355             }
1356         }
1357         LEAVE_SCOPE(oldsave);
1358         RETPUSHYES;
1359     }
1360
1361 yup:                                    /* Confirmed by INTUIT */
1362     if (rxtainted)
1363         RX_MATCH_TAINTED_on(rx);
1364     TAINT_IF(RX_MATCH_TAINTED(rx));
1365     PL_curpm = pm;
1366     if (pm->op_pmflags & PMf_ONCE)
1367         pm->op_pmdynflags |= PMdf_USED;
1368     if (RX_MATCH_COPIED(rx))
1369         Safefree(rx->subbeg);
1370     RX_MATCH_COPIED_off(rx);
1371     rx->subbeg = Nullch;
1372     if (global) {
1373         rx->subbeg = truebase;
1374         rx->startp[0] = s - truebase;
1375         if (DO_UTF8(PL_reg_sv)) {
1376             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1377             rx->endp[0] = t - truebase;
1378         }
1379         else {
1380             rx->endp[0] = s - truebase + rx->minlen;
1381         }
1382         rx->sublen = strend - truebase;
1383         goto gotcha;
1384     }
1385     if (PL_sawampersand) {
1386         I32 off;
1387
1388         rx->subbeg = savepvn(t, strend - t);
1389         rx->sublen = strend - t;
1390         RX_MATCH_COPIED_on(rx);
1391         off = rx->startp[0] = s - t;
1392         rx->endp[0] = off + rx->minlen;
1393     }
1394     else {                      /* startp/endp are used by @- @+. */
1395         rx->startp[0] = s - truebase;
1396         rx->endp[0] = s - truebase + rx->minlen;
1397     }
1398     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1399     LEAVE_SCOPE(oldsave);
1400     RETPUSHYES;
1401
1402 nope:
1403 ret_no:
1404     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1405         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1406             MAGIC* mg = mg_find(TARG, 'g');
1407             if (mg)
1408                 mg->mg_len = -1;
1409         }
1410     }
1411     LEAVE_SCOPE(oldsave);
1412     if (gimme == G_ARRAY)
1413         RETURN;
1414     RETPUSHNO;
1415 }
1416
1417 OP *
1418 Perl_do_readline(pTHX)
1419 {
1420     dSP; dTARGETSTACKED;
1421     register SV *sv;
1422     STRLEN tmplen = 0;
1423     STRLEN offset;
1424     PerlIO *fp;
1425     register IO *io = GvIO(PL_last_in_gv);
1426     register I32 type = PL_op->op_type;
1427     I32 gimme = GIMME_V;
1428     MAGIC *mg;
1429
1430     if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1431         PUSHMARK(SP);
1432         XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1433         PUTBACK;
1434         ENTER;
1435         call_method("READLINE", gimme);
1436         LEAVE;
1437         SPAGAIN;
1438         if (gimme == G_SCALAR)
1439             SvSetMagicSV_nosteal(TARG, TOPs);
1440         RETURN;
1441     }
1442     fp = Nullfp;
1443     if (io) {
1444         fp = IoIFP(io);
1445         if (!fp) {
1446             if (IoFLAGS(io) & IOf_ARGV) {
1447                 if (IoFLAGS(io) & IOf_START) {
1448                     IoLINES(io) = 0;
1449                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1450                         IoFLAGS(io) &= ~IOf_START;
1451                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1452                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1453                         SvSETMAGIC(GvSV(PL_last_in_gv));
1454                         fp = IoIFP(io);
1455                         goto have_fp;
1456                     }
1457                 }
1458                 fp = nextargv(PL_last_in_gv);
1459                 if (!fp) { /* Note: fp != IoIFP(io) */
1460                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1461                 }
1462             }
1463             else if (type == OP_GLOB)
1464                 fp = Perl_start_glob(aTHX_ POPs, io);
1465         }
1466         else if (type == OP_GLOB)
1467             SP--;
1468         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1469             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1470         }
1471     }
1472     if (!fp) {
1473         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1474                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1475             if (type == OP_GLOB)
1476                 Perl_warner(aTHX_ WARN_GLOB,
1477                             "glob failed (can't start child: %s)",
1478                             Strerror(errno));
1479             else
1480                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1481         }
1482         if (gimme == G_SCALAR) {
1483             (void)SvOK_off(TARG);
1484             PUSHTARG;
1485         }
1486         RETURN;
1487     }
1488   have_fp:
1489     if (gimme == G_SCALAR) {
1490         sv = TARG;
1491         if (SvROK(sv))
1492             sv_unref(sv);
1493         (void)SvUPGRADE(sv, SVt_PV);
1494         tmplen = SvLEN(sv);     /* remember if already alloced */
1495         if (!tmplen)
1496             Sv_Grow(sv, 80);    /* try short-buffering it */
1497         if (type == OP_RCATLINE)
1498             offset = SvCUR(sv);
1499         else
1500             offset = 0;
1501     }
1502     else {
1503         sv = sv_2mortal(NEWSV(57, 80));
1504         offset = 0;
1505     }
1506
1507     /* This should not be marked tainted if the fp is marked clean */
1508 #define MAYBE_TAINT_LINE(io, sv) \
1509     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1510         TAINT;                          \
1511         SvTAINTED_on(sv);               \
1512     }
1513
1514 /* delay EOF state for a snarfed empty file */
1515 #define SNARF_EOF(gimme,rs,io,sv) \
1516     (gimme != G_SCALAR || SvCUR(sv)                                     \
1517      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1518
1519     for (;;) {
1520         PUTBACK;
1521         if (!sv_gets(sv, fp, offset)
1522             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1523         {
1524             PerlIO_clearerr(fp);
1525             if (IoFLAGS(io) & IOf_ARGV) {
1526                 fp = nextargv(PL_last_in_gv);
1527                 if (fp)
1528                     continue;
1529                 (void)do_close(PL_last_in_gv, FALSE);
1530             }
1531             else if (type == OP_GLOB) {
1532                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1533                     Perl_warner(aTHX_ WARN_GLOB,
1534                            "glob failed (child exited with status %d%s)",
1535                            (int)(STATUS_CURRENT >> 8),
1536                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1537                 }
1538             }
1539             if (gimme == G_SCALAR) {
1540                 (void)SvOK_off(TARG);
1541                 SPAGAIN;
1542                 PUSHTARG;
1543             }
1544             MAYBE_TAINT_LINE(io, sv);
1545             RETURN;
1546         }
1547         MAYBE_TAINT_LINE(io, sv);
1548         IoLINES(io)++;
1549         IoFLAGS(io) |= IOf_NOLINE;
1550         SvSETMAGIC(sv);
1551         SPAGAIN;
1552         XPUSHs(sv);
1553         if (type == OP_GLOB) {
1554             char *tmps;
1555
1556             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1557                 tmps = SvEND(sv) - 1;
1558                 if (*tmps == *SvPVX(PL_rs)) {
1559                     *tmps = '\0';
1560                     SvCUR(sv)--;
1561                 }
1562             }
1563             for (tmps = SvPVX(sv); *tmps; tmps++)
1564                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1565                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1566                         break;
1567             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1568                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1569                 continue;
1570             }
1571         }
1572         if (gimme == G_ARRAY) {
1573             if (SvLEN(sv) - SvCUR(sv) > 20) {
1574                 SvLEN_set(sv, SvCUR(sv)+1);
1575                 Renew(SvPVX(sv), SvLEN(sv), char);
1576             }
1577             sv = sv_2mortal(NEWSV(58, 80));
1578             continue;
1579         }
1580         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1581             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1582             if (SvCUR(sv) < 60)
1583                 SvLEN_set(sv, 80);
1584             else
1585                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1586             Renew(SvPVX(sv), SvLEN(sv), char);
1587         }
1588         RETURN;
1589     }
1590 }
1591
1592 PP(pp_enter)
1593 {
1594     dSP;
1595     register PERL_CONTEXT *cx;
1596     I32 gimme = OP_GIMME(PL_op, -1);
1597
1598     if (gimme == -1) {
1599         if (cxstack_ix >= 0)
1600             gimme = cxstack[cxstack_ix].blk_gimme;
1601         else
1602             gimme = G_SCALAR;
1603     }
1604
1605     ENTER;
1606
1607     SAVETMPS;
1608     PUSHBLOCK(cx, CXt_BLOCK, SP);
1609
1610     RETURN;
1611 }
1612
1613 PP(pp_helem)
1614 {
1615     dSP;
1616     HE* he;
1617     SV **svp;
1618     SV *keysv = POPs;
1619     HV *hv = (HV*)POPs;
1620     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1621     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1622     SV *sv;
1623     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1624     I32 preeminent;
1625
1626     if (SvTYPE(hv) == SVt_PVHV) {
1627         if (PL_op->op_private & OPpLVAL_INTRO)
1628             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1629         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1630         svp = he ? &HeVAL(he) : 0;
1631     }
1632     else if (SvTYPE(hv) == SVt_PVAV) {
1633         if (PL_op->op_private & OPpLVAL_INTRO)
1634             DIE(aTHX_ "Can't localize pseudo-hash element");
1635         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1636     }
1637     else {
1638         RETPUSHUNDEF;
1639     }
1640     if (lval) {
1641         if (!svp || *svp == &PL_sv_undef) {
1642             SV* lv;
1643             SV* key2;
1644             if (!defer) {
1645                 STRLEN n_a;
1646                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1647             }
1648             lv = sv_newmortal();
1649             sv_upgrade(lv, SVt_PVLV);
1650             LvTYPE(lv) = 'y';
1651             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1652             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1653             LvTARG(lv) = SvREFCNT_inc(hv);
1654             LvTARGLEN(lv) = 1;
1655             PUSHs(lv);
1656             RETURN;
1657         }
1658         if (PL_op->op_private & OPpLVAL_INTRO) {
1659             if (HvNAME(hv) && isGV(*svp))
1660                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1661             else {
1662                 if (!preeminent) {
1663                     STRLEN keylen;
1664                     char *key = SvPV(keysv, keylen);
1665                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1666                 } else
1667                     save_helem(hv, keysv, svp);
1668             }
1669         }
1670         else if (PL_op->op_private & OPpDEREF)
1671             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1672     }
1673     sv = (svp ? *svp : &PL_sv_undef);
1674     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1675      * Pushing the magical RHS on to the stack is useless, since
1676      * that magic is soon destined to be misled by the local(),
1677      * and thus the later pp_sassign() will fail to mg_get() the
1678      * old value.  This should also cure problems with delayed
1679      * mg_get()s.  GSAR 98-07-03 */
1680     if (!lval && SvGMAGICAL(sv))
1681         sv = sv_mortalcopy(sv);
1682     PUSHs(sv);
1683     RETURN;
1684 }
1685
1686 PP(pp_leave)
1687 {
1688     dSP;
1689     register PERL_CONTEXT *cx;
1690     register SV **mark;
1691     SV **newsp;
1692     PMOP *newpm;
1693     I32 gimme;
1694
1695     if (PL_op->op_flags & OPf_SPECIAL) {
1696         cx = &cxstack[cxstack_ix];
1697         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1698     }
1699
1700     POPBLOCK(cx,newpm);
1701
1702     gimme = OP_GIMME(PL_op, -1);
1703     if (gimme == -1) {
1704         if (cxstack_ix >= 0)
1705             gimme = cxstack[cxstack_ix].blk_gimme;
1706         else
1707             gimme = G_SCALAR;
1708     }
1709
1710     TAINT_NOT;
1711     if (gimme == G_VOID)
1712         SP = newsp;
1713     else if (gimme == G_SCALAR) {
1714         MARK = newsp + 1;
1715         if (MARK <= SP)
1716             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1717                 *MARK = TOPs;
1718             else
1719                 *MARK = sv_mortalcopy(TOPs);
1720         else {
1721             MEXTEND(mark,0);
1722             *MARK = &PL_sv_undef;
1723         }
1724         SP = MARK;
1725     }
1726     else if (gimme == G_ARRAY) {
1727         /* in case LEAVE wipes old return values */
1728         for (mark = newsp + 1; mark <= SP; mark++) {
1729             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1730                 *mark = sv_mortalcopy(*mark);
1731                 TAINT_NOT;      /* Each item is independent */
1732             }
1733         }
1734     }
1735     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1736
1737     LEAVE;
1738
1739     RETURN;
1740 }
1741
1742 PP(pp_iter)
1743 {
1744     dSP;
1745     register PERL_CONTEXT *cx;
1746     SV* sv;
1747     AV* av;
1748     SV **itersvp;
1749
1750     EXTEND(SP, 1);
1751     cx = &cxstack[cxstack_ix];
1752     if (CxTYPE(cx) != CXt_LOOP)
1753         DIE(aTHX_ "panic: pp_iter");
1754
1755     itersvp = CxITERVAR(cx);
1756     av = cx->blk_loop.iterary;
1757     if (SvTYPE(av) != SVt_PVAV) {
1758         /* iterate ($min .. $max) */
1759         if (cx->blk_loop.iterlval) {
1760             /* string increment */
1761             register SV* cur = cx->blk_loop.iterlval;
1762             STRLEN maxlen;
1763             char *max = SvPV((SV*)av, maxlen);
1764             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1765 #ifndef USE_THREADS                       /* don't risk potential race */
1766                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1767                     /* safe to reuse old SV */
1768                     sv_setsv(*itersvp, cur);
1769                 }
1770                 else
1771 #endif
1772                 {
1773                     /* we need a fresh SV every time so that loop body sees a
1774                      * completely new SV for closures/references to work as
1775                      * they used to */
1776                     SvREFCNT_dec(*itersvp);
1777                     *itersvp = newSVsv(cur);
1778                 }
1779                 if (strEQ(SvPVX(cur), max))
1780                     sv_setiv(cur, 0); /* terminate next time */
1781                 else
1782                     sv_inc(cur);
1783                 RETPUSHYES;
1784             }
1785             RETPUSHNO;
1786         }
1787         /* integer increment */
1788         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1789             RETPUSHNO;
1790
1791 #ifndef USE_THREADS                       /* don't risk potential race */
1792         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1793             /* safe to reuse old SV */
1794             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1795         }
1796         else
1797 #endif
1798         {
1799             /* we need a fresh SV every time so that loop body sees a
1800              * completely new SV for closures/references to work as they
1801              * used to */
1802             SvREFCNT_dec(*itersvp);
1803             *itersvp = newSViv(cx->blk_loop.iterix++);
1804         }
1805         RETPUSHYES;
1806     }
1807
1808     /* iterate array */
1809     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1810         RETPUSHNO;
1811
1812     SvREFCNT_dec(*itersvp);
1813
1814     if ((sv = SvMAGICAL(av)
1815               ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1816               : AvARRAY(av)[++cx->blk_loop.iterix]))
1817         SvTEMP_off(sv);
1818     else
1819         sv = &PL_sv_undef;
1820     if (av != PL_curstack && SvIMMORTAL(sv)) {
1821         SV *lv = cx->blk_loop.iterlval;
1822         if (lv && SvREFCNT(lv) > 1) {
1823             SvREFCNT_dec(lv);
1824             lv = Nullsv;
1825         }
1826         if (lv)
1827             SvREFCNT_dec(LvTARG(lv));
1828         else {
1829             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1830             sv_upgrade(lv, SVt_PVLV);
1831             LvTYPE(lv) = 'y';
1832             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1833         }
1834         LvTARG(lv) = SvREFCNT_inc(av);
1835         LvTARGOFF(lv) = cx->blk_loop.iterix;
1836         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1837         sv = (SV*)lv;
1838     }
1839
1840     *itersvp = SvREFCNT_inc(sv);
1841     RETPUSHYES;
1842 }
1843
1844 PP(pp_subst)
1845 {
1846     dSP; dTARG;
1847     register PMOP *pm = cPMOP;
1848     PMOP *rpm = pm;
1849     register SV *dstr;
1850     register char *s;
1851     char *strend;
1852     register char *m;
1853     char *c;
1854     register char *d;
1855     STRLEN clen;
1856     I32 iters = 0;
1857     I32 maxiters;
1858     register I32 i;
1859     bool once;
1860     bool rxtainted;
1861     char *orig;
1862     I32 r_flags;
1863     register REGEXP *rx = pm->op_pmregexp;
1864     STRLEN len;
1865     int force_on_match = 0;
1866     I32 oldsave = PL_savestack_ix;
1867     bool do_utf8;
1868     STRLEN slen;
1869
1870     /* known replacement string? */
1871     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1872     if (PL_op->op_flags & OPf_STACKED)
1873         TARG = POPs;
1874     else {
1875         TARG = DEFSV;
1876         EXTEND(SP,1);
1877     }
1878     PL_reg_sv = TARG;
1879     do_utf8 = DO_UTF8(PL_reg_sv);
1880     if (SvFAKE(TARG) && SvREADONLY(TARG))
1881         sv_force_normal(TARG);
1882     if (SvREADONLY(TARG)
1883         || (SvTYPE(TARG) > SVt_PVLV
1884             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1885         DIE(aTHX_ PL_no_modify);
1886     PUTBACK;
1887
1888     s = SvPV(TARG, len);
1889     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1890         force_on_match = 1;
1891     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1892                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1893     if (PL_tainted)
1894         rxtainted |= 2;
1895     TAINT_NOT;
1896
1897   force_it:
1898     if (!pm || !s)
1899         DIE(aTHX_ "panic: pp_subst");
1900
1901     strend = s + len;
1902     slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1903     maxiters = 2 * slen + 10;   /* We can match twice at each
1904                                    position, once with zero-length,
1905                                    second time with non-zero. */
1906
1907     if (!rx->prelen && PL_curpm) {
1908         pm = PL_curpm;
1909         rx = pm->op_pmregexp;
1910     }
1911     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1912                 ? REXEC_COPY_STR : 0;
1913     if (SvSCREAM(TARG))
1914         r_flags |= REXEC_SCREAM;
1915     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1916         SAVEINT(PL_multiline);
1917         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1918     }
1919     orig = m = s;
1920     if (rx->reganch & RE_USE_INTUIT) {
1921         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1922
1923         if (!s)
1924             goto nope;
1925         /* How to do it in subst? */
1926 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1927              && !PL_sawampersand
1928              && ((rx->reganch & ROPT_NOSCAN)
1929                  || !((rx->reganch & RE_INTUIT_TAIL)
1930                       && (r_flags & REXEC_SCREAM))))
1931             goto yup;
1932 */
1933     }
1934
1935     /* only replace once? */
1936     once = !(rpm->op_pmflags & PMf_GLOBAL);
1937
1938     /* known replacement string? */
1939     c = dstr ? SvPV(dstr, clen) : Nullch;
1940
1941     /* can do inplace substitution? */
1942     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1943         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1944         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1945                          r_flags | REXEC_CHECKED))
1946         {
1947             SPAGAIN;
1948             PUSHs(&PL_sv_no);
1949             LEAVE_SCOPE(oldsave);
1950             RETURN;
1951         }
1952         if (force_on_match) {
1953             force_on_match = 0;
1954             s = SvPV_force(TARG, len);
1955             goto force_it;
1956         }
1957         d = s;
1958         PL_curpm = pm;
1959         SvSCREAM_off(TARG);     /* disable possible screamer */
1960         if (once) {
1961             rxtainted |= RX_MATCH_TAINTED(rx);
1962             m = orig + rx->startp[0];
1963             d = orig + rx->endp[0];
1964             s = orig;
1965             if (m - s > strend - d) {  /* faster to shorten from end */
1966                 if (clen) {
1967                     Copy(c, m, clen, char);
1968                     m += clen;
1969                 }
1970                 i = strend - d;
1971                 if (i > 0) {
1972                     Move(d, m, i, char);
1973                     m += i;
1974                 }
1975                 *m = '\0';
1976                 SvCUR_set(TARG, m - s);
1977             }
1978             /*SUPPRESS 560*/
1979             else if ((i = m - s)) {     /* faster from front */
1980                 d -= clen;
1981                 m = d;
1982                 sv_chop(TARG, d-i);
1983                 s += i;
1984                 while (i--)
1985                     *--d = *--s;
1986                 if (clen)
1987                     Copy(c, m, clen, char);
1988             }
1989             else if (clen) {
1990                 d -= clen;
1991                 sv_chop(TARG, d);
1992                 Copy(c, d, clen, char);
1993             }
1994             else {
1995                 sv_chop(TARG, d);
1996             }
1997             TAINT_IF(rxtainted & 1);
1998             SPAGAIN;
1999             PUSHs(&PL_sv_yes);
2000         }
2001         else {
2002             do {
2003                 if (iters++ > maxiters)
2004                     DIE(aTHX_ "Substitution loop");
2005                 rxtainted |= RX_MATCH_TAINTED(rx);
2006                 m = rx->startp[0] + orig;
2007                 /*SUPPRESS 560*/
2008                 if ((i = m - s)) {
2009                     if (s != d)
2010                         Move(s, d, i, char);
2011                     d += i;
2012                 }
2013                 if (clen) {
2014                     Copy(c, d, clen, char);
2015                     d += clen;
2016                 }
2017                 s = rx->endp[0] + orig;
2018             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2019                                  TARG, NULL,
2020                                  /* don't match same null twice */
2021                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2022             if (s != d) {
2023                 i = strend - s;
2024                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2025                 Move(s, d, i+1, char);          /* include the NUL */
2026             }
2027             TAINT_IF(rxtainted & 1);
2028             SPAGAIN;
2029             PUSHs(sv_2mortal(newSViv((I32)iters)));
2030         }
2031         (void)SvPOK_only_UTF8(TARG);
2032         TAINT_IF(rxtainted);
2033         if (SvSMAGICAL(TARG)) {
2034             PUTBACK;
2035             mg_set(TARG);
2036             SPAGAIN;
2037         }
2038         SvTAINT(TARG);
2039         LEAVE_SCOPE(oldsave);
2040         RETURN;
2041     }
2042
2043     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2044                     r_flags | REXEC_CHECKED))
2045     {
2046         bool isutf8;
2047
2048         if (force_on_match) {
2049             force_on_match = 0;
2050             s = SvPV_force(TARG, len);
2051             goto force_it;
2052         }
2053         rxtainted |= RX_MATCH_TAINTED(rx);
2054         dstr = NEWSV(25, len);
2055         sv_setpvn(dstr, m, s-m);
2056         if (DO_UTF8(TARG))
2057             SvUTF8_on(dstr);
2058         PL_curpm = pm;
2059         if (!c) {
2060             register PERL_CONTEXT *cx;
2061             SPAGAIN;
2062             PUSHSUBST(cx);
2063             RETURNOP(cPMOP->op_pmreplroot);
2064         }
2065         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2066         do {
2067             if (iters++ > maxiters)
2068                 DIE(aTHX_ "Substitution loop");
2069             rxtainted |= RX_MATCH_TAINTED(rx);
2070             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2071                 m = s;
2072                 s = orig;
2073                 orig = rx->subbeg;
2074                 s = orig + (m - s);
2075                 strend = s + (strend - m);
2076             }
2077             m = rx->startp[0] + orig;
2078             sv_catpvn(dstr, s, m-s);
2079             s = rx->endp[0] + orig;
2080             if (clen)
2081                 sv_catpvn(dstr, c, clen);
2082             if (once)
2083                 break;
2084         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2085                              TARG, NULL, r_flags));
2086         sv_catpvn(dstr, s, strend - s);
2087
2088         (void)SvOOK_off(TARG);
2089         Safefree(SvPVX(TARG));
2090         SvPVX(TARG) = SvPVX(dstr);
2091         SvCUR_set(TARG, SvCUR(dstr));
2092         SvLEN_set(TARG, SvLEN(dstr));
2093         isutf8 = DO_UTF8(dstr);
2094         SvPVX(dstr) = 0;
2095         sv_free(dstr);
2096
2097         TAINT_IF(rxtainted & 1);
2098         SPAGAIN;
2099         PUSHs(sv_2mortal(newSViv((I32)iters)));
2100
2101         (void)SvPOK_only(TARG);
2102         if (isutf8)
2103             SvUTF8_on(TARG);
2104         TAINT_IF(rxtainted);
2105         SvSETMAGIC(TARG);
2106         SvTAINT(TARG);
2107         LEAVE_SCOPE(oldsave);
2108         RETURN;
2109     }
2110     goto ret_no;
2111
2112 nope:
2113 ret_no:
2114     SPAGAIN;
2115     PUSHs(&PL_sv_no);
2116     LEAVE_SCOPE(oldsave);
2117     RETURN;
2118 }
2119
2120 PP(pp_grepwhile)
2121 {
2122     dSP;
2123
2124     if (SvTRUEx(POPs))
2125         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2126     ++*PL_markstack_ptr;
2127     LEAVE;                                      /* exit inner scope */
2128
2129     /* All done yet? */
2130     if (PL_stack_base + *PL_markstack_ptr > SP) {
2131         I32 items;
2132         I32 gimme = GIMME_V;
2133
2134         LEAVE;                                  /* exit outer scope */
2135         (void)POPMARK;                          /* pop src */
2136         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2137         (void)POPMARK;                          /* pop dst */
2138         SP = PL_stack_base + POPMARK;           /* pop original mark */
2139         if (gimme == G_SCALAR) {
2140             dTARGET;
2141             XPUSHi(items);
2142         }
2143         else if (gimme == G_ARRAY)
2144             SP += items;
2145         RETURN;
2146     }
2147     else {
2148         SV *src;
2149
2150         ENTER;                                  /* enter inner scope */
2151         SAVEVPTR(PL_curpm);
2152
2153         src = PL_stack_base[*PL_markstack_ptr];
2154         SvTEMP_off(src);
2155         DEFSV = src;
2156
2157         RETURNOP(cLOGOP->op_other);
2158     }
2159 }
2160
2161 PP(pp_leavesub)
2162 {
2163     dSP;
2164     SV **mark;
2165     SV **newsp;
2166     PMOP *newpm;
2167     I32 gimme;
2168     register PERL_CONTEXT *cx;
2169     SV *sv;
2170
2171     POPBLOCK(cx,newpm);
2172
2173     TAINT_NOT;
2174     if (gimme == G_SCALAR) {
2175         MARK = newsp + 1;
2176         if (MARK <= SP) {
2177             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2178                 if (SvTEMP(TOPs)) {
2179                     *MARK = SvREFCNT_inc(TOPs);
2180                     FREETMPS;
2181                     sv_2mortal(*MARK);
2182                 }
2183                 else {
2184                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2185                     FREETMPS;
2186                     *MARK = sv_mortalcopy(sv);
2187                     SvREFCNT_dec(sv);
2188                 }
2189             }
2190             else
2191                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2192         }
2193         else {
2194             MEXTEND(MARK, 0);
2195             *MARK = &PL_sv_undef;
2196         }
2197         SP = MARK;
2198     }
2199     else if (gimme == G_ARRAY) {
2200         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2201             if (!SvTEMP(*MARK)) {
2202                 *MARK = sv_mortalcopy(*MARK);
2203                 TAINT_NOT;      /* Each item is independent */
2204             }
2205         }
2206     }
2207     PUTBACK;
2208
2209     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2210     PL_curpm = newpm;   /* ... and pop $1 et al */
2211
2212     LEAVE;
2213     LEAVESUB(sv);
2214     return pop_return();
2215 }
2216
2217 /* This duplicates the above code because the above code must not
2218  * get any slower by more conditions */
2219 PP(pp_leavesublv)
2220 {
2221     dSP;
2222     SV **mark;
2223     SV **newsp;
2224     PMOP *newpm;
2225     I32 gimme;
2226     register PERL_CONTEXT *cx;
2227     SV *sv;
2228
2229     POPBLOCK(cx,newpm);
2230
2231     TAINT_NOT;
2232
2233     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2234         /* We are an argument to a function or grep().
2235          * This kind of lvalueness was legal before lvalue
2236          * subroutines too, so be backward compatible:
2237          * cannot report errors.  */
2238
2239         /* Scalar context *is* possible, on the LHS of -> only,
2240          * as in f()->meth().  But this is not an lvalue. */
2241         if (gimme == G_SCALAR)
2242             goto temporise;
2243         if (gimme == G_ARRAY) {
2244             if (!CvLVALUE(cx->blk_sub.cv))
2245                 goto temporise_array;
2246             EXTEND_MORTAL(SP - newsp);
2247             for (mark = newsp + 1; mark <= SP; mark++) {
2248                 if (SvTEMP(*mark))
2249                     /* empty */ ;
2250                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2251                     *mark = sv_mortalcopy(*mark);
2252                 else {
2253                     /* Can be a localized value subject to deletion. */
2254                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2255                     (void)SvREFCNT_inc(*mark);
2256                 }
2257             }
2258         }
2259     }
2260     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2261         /* Here we go for robustness, not for speed, so we change all
2262          * the refcounts so the caller gets a live guy. Cannot set
2263          * TEMP, so sv_2mortal is out of question. */
2264         if (!CvLVALUE(cx->blk_sub.cv)) {
2265             POPSUB(cx,sv);
2266             PL_curpm = newpm;
2267             LEAVE;
2268             LEAVESUB(sv);
2269             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2270         }
2271         if (gimme == G_SCALAR) {
2272             MARK = newsp + 1;
2273             EXTEND_MORTAL(1);
2274             if (MARK == SP) {
2275                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2276                     POPSUB(cx,sv);
2277                     PL_curpm = newpm;
2278                     LEAVE;
2279                     LEAVESUB(sv);
2280                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2281                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2282                 }
2283                 else {                  /* Can be a localized value
2284                                          * subject to deletion. */
2285                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2286                     (void)SvREFCNT_inc(*mark);
2287                 }
2288             }
2289             else {                      /* Should not happen? */
2290                 POPSUB(cx,sv);
2291                 PL_curpm = newpm;
2292                 LEAVE;
2293                 LEAVESUB(sv);
2294                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2295                     (MARK > SP ? "Empty array" : "Array"));
2296             }
2297             SP = MARK;
2298         }
2299         else if (gimme == G_ARRAY) {
2300             EXTEND_MORTAL(SP - newsp);
2301             for (mark = newsp + 1; mark <= SP; mark++) {
2302                 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2303                     /* Might be flattened array after $#array =  */
2304                     PUTBACK;
2305                     POPSUB(cx,sv);
2306                     PL_curpm = newpm;
2307                     LEAVE;
2308                     LEAVESUB(sv);
2309                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2310                         (*mark != &PL_sv_undef)
2311                         ? (SvREADONLY(TOPs)
2312                             ? "a readonly value" : "a temporary")
2313                         : "an uninitialized value");
2314                 }
2315                 else {
2316                     /* Can be a localized value subject to deletion. */
2317                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2318                     (void)SvREFCNT_inc(*mark);
2319                 }
2320             }
2321         }
2322     }
2323     else {
2324         if (gimme == G_SCALAR) {
2325           temporise:
2326             MARK = newsp + 1;
2327             if (MARK <= SP) {
2328                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2329                     if (SvTEMP(TOPs)) {
2330                         *MARK = SvREFCNT_inc(TOPs);
2331                         FREETMPS;
2332                         sv_2mortal(*MARK);
2333                     }
2334                     else {
2335                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2336                         FREETMPS;
2337                         *MARK = sv_mortalcopy(sv);
2338                         SvREFCNT_dec(sv);
2339                     }
2340                 }
2341                 else
2342                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2343             }
2344             else {
2345                 MEXTEND(MARK, 0);
2346                 *MARK = &PL_sv_undef;
2347             }
2348             SP = MARK;
2349         }
2350         else if (gimme == G_ARRAY) {
2351           temporise_array:
2352             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2353                 if (!SvTEMP(*MARK)) {
2354                     *MARK = sv_mortalcopy(*MARK);
2355                     TAINT_NOT;  /* Each item is independent */
2356                 }
2357             }
2358         }
2359     }
2360     PUTBACK;
2361
2362     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2363     PL_curpm = newpm;   /* ... and pop $1 et al */
2364
2365     LEAVE;
2366     LEAVESUB(sv);
2367     return pop_return();
2368 }
2369
2370
2371 STATIC CV *
2372 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2373 {
2374     SV *dbsv = GvSV(PL_DBsub);
2375
2376     if (!PERLDB_SUB_NN) {
2377         GV *gv = CvGV(cv);
2378
2379         save_item(dbsv);
2380         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2381              || strEQ(GvNAME(gv), "END")
2382              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2383                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2384                     && (gv = (GV*)*svp) ))) {
2385             /* Use GV from the stack as a fallback. */
2386             /* GV is potentially non-unique, or contain different CV. */
2387             SV *tmp = newRV((SV*)cv);
2388             sv_setsv(dbsv, tmp);
2389             SvREFCNT_dec(tmp);
2390         }
2391         else {
2392             gv_efullname3(dbsv, gv, Nullch);
2393         }
2394     }
2395     else {
2396         (void)SvUPGRADE(dbsv, SVt_PVIV);
2397         (void)SvIOK_on(dbsv);
2398         SAVEIV(SvIVX(dbsv));
2399         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2400     }
2401
2402     if (CvXSUB(cv))
2403         PL_curcopdb = PL_curcop;
2404     cv = GvCV(PL_DBsub);
2405     return cv;
2406 }
2407
2408 PP(pp_entersub)
2409 {
2410     dSP; dPOPss;
2411     GV *gv;
2412     HV *stash;
2413     register CV *cv;
2414     register PERL_CONTEXT *cx;
2415     I32 gimme;
2416     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2417
2418     if (!sv)
2419         DIE(aTHX_ "Not a CODE reference");
2420     switch (SvTYPE(sv)) {
2421     default:
2422         if (!SvROK(sv)) {
2423             char *sym;
2424             STRLEN n_a;
2425
2426             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2427                 if (hasargs)
2428                     SP = PL_stack_base + POPMARK;
2429                 RETURN;
2430             }
2431             if (SvGMAGICAL(sv)) {
2432                 mg_get(sv);
2433                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2434             }
2435             else
2436                 sym = SvPV(sv, n_a);
2437             if (!sym)
2438                 DIE(aTHX_ PL_no_usym, "a subroutine");
2439             if (PL_op->op_private & HINT_STRICT_REFS)
2440                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2441             cv = get_cv(sym, TRUE);
2442             break;
2443         }
2444         {
2445             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2446             tryAMAGICunDEREF(to_cv);
2447         }
2448         cv = (CV*)SvRV(sv);
2449         if (SvTYPE(cv) == SVt_PVCV)
2450             break;
2451         /* FALL THROUGH */
2452     case SVt_PVHV:
2453     case SVt_PVAV:
2454         DIE(aTHX_ "Not a CODE reference");
2455     case SVt_PVCV:
2456         cv = (CV*)sv;
2457         break;
2458     case SVt_PVGV:
2459         if (!(cv = GvCVu((GV*)sv)))
2460             cv = sv_2cv(sv, &stash, &gv, FALSE);
2461         if (!cv) {
2462             ENTER;
2463             SAVETMPS;
2464             goto try_autoload;
2465         }
2466         break;
2467     }
2468
2469     ENTER;
2470     SAVETMPS;
2471
2472   retry:
2473     if (!CvROOT(cv) && !CvXSUB(cv)) {
2474         GV* autogv;
2475         SV* sub_name;
2476
2477         /* anonymous or undef'd function leaves us no recourse */
2478         if (CvANON(cv) || !(gv = CvGV(cv)))
2479             DIE(aTHX_ "Undefined subroutine called");
2480
2481         /* autoloaded stub? */
2482         if (cv != GvCV(gv)) {
2483             cv = GvCV(gv);
2484         }
2485         /* should call AUTOLOAD now? */
2486         else {
2487 try_autoload:
2488             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2489                                    FALSE)))
2490             {
2491                 cv = GvCV(autogv);
2492             }
2493             /* sorry */
2494             else {
2495                 sub_name = sv_newmortal();
2496                 gv_efullname3(sub_name, gv, Nullch);
2497                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2498             }
2499         }
2500         if (!cv)
2501             DIE(aTHX_ "Not a CODE reference");
2502         goto retry;
2503     }
2504
2505     gimme = GIMME_V;
2506     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2507         cv = get_db_sub(&sv, cv);
2508         if (!cv)
2509             DIE(aTHX_ "No DBsub routine");
2510     }
2511
2512 #ifdef USE_THREADS
2513     /*
2514      * First we need to check if the sub or method requires locking.
2515      * If so, we gain a lock on the CV, the first argument or the
2516      * stash (for static methods), as appropriate. This has to be
2517      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2518      * reschedule by returning a new op.
2519      */
2520     MUTEX_LOCK(CvMUTEXP(cv));
2521     if (CvFLAGS(cv) & CVf_LOCKED) {
2522         MAGIC *mg;
2523         if (CvFLAGS(cv) & CVf_METHOD) {
2524             if (SP > PL_stack_base + TOPMARK)
2525                 sv = *(PL_stack_base + TOPMARK + 1);
2526             else {
2527                 AV *av = (AV*)PL_curpad[0];
2528                 if (hasargs || !av || AvFILLp(av) < 0
2529                     || !(sv = AvARRAY(av)[0]))
2530                 {
2531                     MUTEX_UNLOCK(CvMUTEXP(cv));
2532                     DIE(aTHX_ "no argument for locked method call");
2533                 }
2534             }
2535             if (SvROK(sv))
2536                 sv = SvRV(sv);
2537             else {
2538                 STRLEN len;
2539                 char *stashname = SvPV(sv, len);
2540                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2541             }
2542         }
2543         else {
2544             sv = (SV*)cv;
2545         }
2546         MUTEX_UNLOCK(CvMUTEXP(cv));
2547         mg = condpair_magic(sv);
2548         MUTEX_LOCK(MgMUTEXP(mg));
2549         if (MgOWNER(mg) == thr)
2550             MUTEX_UNLOCK(MgMUTEXP(mg));
2551         else {
2552             while (MgOWNER(mg))
2553                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2554             MgOWNER(mg) = thr;
2555             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2556                                   thr, sv);)
2557             MUTEX_UNLOCK(MgMUTEXP(mg));
2558             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2559         }
2560         MUTEX_LOCK(CvMUTEXP(cv));
2561     }
2562     /*
2563      * Now we have permission to enter the sub, we must distinguish
2564      * four cases. (0) It's an XSUB (in which case we don't care
2565      * about ownership); (1) it's ours already (and we're recursing);
2566      * (2) it's free (but we may already be using a cached clone);
2567      * (3) another thread owns it. Case (1) is easy: we just use it.
2568      * Case (2) means we look for a clone--if we have one, use it
2569      * otherwise grab ownership of cv. Case (3) means we look for a
2570      * clone (for non-XSUBs) and have to create one if we don't
2571      * already have one.
2572      * Why look for a clone in case (2) when we could just grab
2573      * ownership of cv straight away? Well, we could be recursing,
2574      * i.e. we originally tried to enter cv while another thread
2575      * owned it (hence we used a clone) but it has been freed up
2576      * and we're now recursing into it. It may or may not be "better"
2577      * to use the clone but at least CvDEPTH can be trusted.
2578      */
2579     if (CvOWNER(cv) == thr || CvXSUB(cv))
2580         MUTEX_UNLOCK(CvMUTEXP(cv));
2581     else {
2582         /* Case (2) or (3) */
2583         SV **svp;
2584
2585         /*
2586          * XXX Might it be better to release CvMUTEXP(cv) while we
2587          * do the hv_fetch? We might find someone has pinched it
2588          * when we look again, in which case we would be in case
2589          * (3) instead of (2) so we'd have to clone. Would the fact
2590          * that we released the mutex more quickly make up for this?
2591          */
2592         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2593         {
2594             /* We already have a clone to use */
2595             MUTEX_UNLOCK(CvMUTEXP(cv));
2596             cv = *(CV**)svp;
2597             DEBUG_S(PerlIO_printf(Perl_debug_log,
2598                                   "entersub: %p already has clone %p:%s\n",
2599                                   thr, cv, SvPEEK((SV*)cv)));
2600             CvOWNER(cv) = thr;
2601             SvREFCNT_inc(cv);
2602             if (CvDEPTH(cv) == 0)
2603                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2604         }
2605         else {
2606             /* (2) => grab ownership of cv. (3) => make clone */
2607             if (!CvOWNER(cv)) {
2608                 CvOWNER(cv) = thr;
2609                 SvREFCNT_inc(cv);
2610                 MUTEX_UNLOCK(CvMUTEXP(cv));
2611                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2612                             "entersub: %p grabbing %p:%s in stash %s\n",
2613                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2614                                 HvNAME(CvSTASH(cv)) : "(none)"));
2615             }
2616             else {
2617                 /* Make a new clone. */
2618                 CV *clonecv;
2619                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2620                 MUTEX_UNLOCK(CvMUTEXP(cv));
2621                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2622                                        "entersub: %p cloning %p:%s\n",
2623                                        thr, cv, SvPEEK((SV*)cv))));
2624                 /*
2625                  * We're creating a new clone so there's no race
2626                  * between the original MUTEX_UNLOCK and the
2627                  * SvREFCNT_inc since no one will be trying to undef
2628                  * it out from underneath us. At least, I don't think
2629                  * there's a race...
2630                  */
2631                 clonecv = cv_clone(cv);
2632                 SvREFCNT_dec(cv); /* finished with this */
2633                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2634                 CvOWNER(clonecv) = thr;
2635                 cv = clonecv;
2636                 SvREFCNT_inc(cv);
2637             }
2638             DEBUG_S(if (CvDEPTH(cv) != 0)
2639                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2640                                       CvDEPTH(cv)););
2641             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2642         }
2643     }
2644 #endif /* USE_THREADS */
2645
2646     if (CvXSUB(cv)) {
2647 #ifdef PERL_XSUB_OLDSTYLE
2648         if (CvOLDSTYLE(cv)) {
2649             I32 (*fp3)(int,int,int);
2650             dMARK;
2651             register I32 items = SP - MARK;
2652                                         /* We dont worry to copy from @_. */
2653             while (SP > mark) {
2654                 SP[1] = SP[0];
2655                 SP--;
2656             }
2657             PL_stack_sp = mark + 1;
2658             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2659             items = (*fp3)(CvXSUBANY(cv).any_i32,
2660                            MARK - PL_stack_base + 1,
2661                            items);
2662             PL_stack_sp = PL_stack_base + items;
2663         }
2664         else
2665 #endif /* PERL_XSUB_OLDSTYLE */
2666         {
2667             I32 markix = TOPMARK;
2668
2669             PUTBACK;
2670
2671             if (!hasargs) {
2672                 /* Need to copy @_ to stack. Alternative may be to
2673                  * switch stack to @_, and copy return values
2674                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2675                 AV* av;
2676                 I32 items;
2677 #ifdef USE_THREADS
2678                 av = (AV*)PL_curpad[0];
2679 #else
2680                 av = GvAV(PL_defgv);
2681 #endif /* USE_THREADS */
2682                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2683
2684                 if (items) {
2685                     /* Mark is at the end of the stack. */
2686                     EXTEND(SP, items);
2687                     Copy(AvARRAY(av), SP + 1, items, SV*);
2688                     SP += items;
2689                     PUTBACK ;
2690                 }
2691             }
2692             /* We assume first XSUB in &DB::sub is the called one. */
2693             if (PL_curcopdb) {
2694                 SAVEVPTR(PL_curcop);
2695                 PL_curcop = PL_curcopdb;
2696                 PL_curcopdb = NULL;
2697             }
2698             /* Do we need to open block here? XXXX */
2699             (void)(*CvXSUB(cv))(aTHXo_ cv);
2700
2701             /* Enforce some sanity in scalar context. */
2702             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2703                 if (markix > PL_stack_sp - PL_stack_base)
2704                     *(PL_stack_base + markix) = &PL_sv_undef;
2705                 else
2706                     *(PL_stack_base + markix) = *PL_stack_sp;
2707                 PL_stack_sp = PL_stack_base + markix;
2708             }
2709         }
2710         LEAVE;
2711         return NORMAL;
2712     }
2713     else {
2714         dMARK;
2715         register I32 items = SP - MARK;
2716         AV* padlist = CvPADLIST(cv);
2717         SV** svp = AvARRAY(padlist);
2718         push_return(PL_op->op_next);
2719         PUSHBLOCK(cx, CXt_SUB, MARK);
2720         PUSHSUB(cx);
2721         CvDEPTH(cv)++;
2722         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2723          * that eval'' ops within this sub know the correct lexical space.
2724          * Owing the speed considerations, we choose to search for the cv
2725          * in doeval() instead.
2726          */
2727         if (CvDEPTH(cv) < 2)
2728             (void)SvREFCNT_inc(cv);
2729         else {  /* save temporaries on recursion? */
2730             PERL_STACK_OVERFLOW_CHECK();
2731             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2732                 AV *av;
2733                 AV *newpad = newAV();
2734                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2735                 I32 ix = AvFILLp((AV*)svp[1]);
2736                 I32 names_fill = AvFILLp((AV*)svp[0]);
2737                 svp = AvARRAY(svp[0]);
2738                 for ( ;ix > 0; ix--) {
2739                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2740                         char *name = SvPVX(svp[ix]);
2741                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2742                             || *name == '&')              /* anonymous code? */
2743                         {
2744                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2745                         }
2746                         else {                          /* our own lexical */
2747                             if (*name == '@')
2748                                 av_store(newpad, ix, sv = (SV*)newAV());
2749                             else if (*name == '%')
2750                                 av_store(newpad, ix, sv = (SV*)newHV());
2751                             else
2752                                 av_store(newpad, ix, sv = NEWSV(0,0));
2753                             SvPADMY_on(sv);
2754                         }
2755                     }
2756                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2757                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2758                     }
2759                     else {
2760                         av_store(newpad, ix, sv = NEWSV(0,0));
2761                         SvPADTMP_on(sv);
2762                     }
2763                 }
2764                 av = newAV();           /* will be @_ */
2765                 av_extend(av, 0);
2766                 av_store(newpad, 0, (SV*)av);
2767                 AvFLAGS(av) = AVf_REIFY;
2768                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2769                 AvFILLp(padlist) = CvDEPTH(cv);
2770                 svp = AvARRAY(padlist);
2771             }
2772         }
2773 #ifdef USE_THREADS
2774         if (!hasargs) {
2775             AV* av = (AV*)PL_curpad[0];
2776
2777             items = AvFILLp(av) + 1;
2778             if (items) {
2779                 /* Mark is at the end of the stack. */
2780                 EXTEND(SP, items);
2781                 Copy(AvARRAY(av), SP + 1, items, SV*);
2782                 SP += items;
2783                 PUTBACK ;
2784             }
2785         }
2786 #endif /* USE_THREADS */
2787         SAVEVPTR(PL_curpad);
2788         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2789 #ifndef USE_THREADS
2790         if (hasargs)
2791 #endif /* USE_THREADS */
2792         {
2793             AV* av;
2794             SV** ary;
2795
2796 #if 0
2797             DEBUG_S(PerlIO_printf(Perl_debug_log,
2798                                   "%p entersub preparing @_\n", thr));
2799 #endif
2800             av = (AV*)PL_curpad[0];
2801             if (AvREAL(av)) {
2802                 /* @_ is normally not REAL--this should only ever
2803                  * happen when DB::sub() calls things that modify @_ */
2804                 av_clear(av);
2805                 AvREAL_off(av);
2806                 AvREIFY_on(av);
2807             }
2808 #ifndef USE_THREADS
2809             cx->blk_sub.savearray = GvAV(PL_defgv);
2810             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2811 #endif /* USE_THREADS */
2812             cx->blk_sub.oldcurpad = PL_curpad;
2813             cx->blk_sub.argarray = av;
2814             ++MARK;
2815
2816             if (items > AvMAX(av) + 1) {
2817                 ary = AvALLOC(av);
2818                 if (AvARRAY(av) != ary) {
2819                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2820                     SvPVX(av) = (char*)ary;
2821                 }
2822                 if (items > AvMAX(av) + 1) {
2823                     AvMAX(av) = items - 1;
2824                     Renew(ary,items,SV*);
2825                     AvALLOC(av) = ary;
2826                     SvPVX(av) = (char*)ary;
2827                 }
2828             }
2829             Copy(MARK,AvARRAY(av),items,SV*);
2830             AvFILLp(av) = items - 1;
2831
2832             while (items--) {
2833                 if (*MARK)
2834                     SvTEMP_off(*MARK);
2835                 MARK++;
2836             }
2837         }
2838         /* warning must come *after* we fully set up the context
2839          * stuff so that __WARN__ handlers can safely dounwind()
2840          * if they want to
2841          */
2842         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2843             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2844             sub_crush_depth(cv);
2845 #if 0
2846         DEBUG_S(PerlIO_printf(Perl_debug_log,
2847                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2848 #endif
2849         RETURNOP(CvSTART(cv));
2850     }
2851 }
2852
2853 void
2854 Perl_sub_crush_depth(pTHX_ CV *cv)
2855 {
2856     if (CvANON(cv))
2857         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2858     else {
2859         SV* tmpstr = sv_newmortal();
2860         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2861         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2862                 SvPVX(tmpstr));
2863     }
2864 }
2865
2866 PP(pp_aelem)
2867 {
2868     dSP;
2869     SV** svp;
2870     SV* elemsv = POPs;
2871     IV elem = SvIV(elemsv);
2872     AV* av = (AV*)POPs;
2873     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2875     SV *sv;
2876
2877     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878         Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2879     if (elem > 0)
2880         elem -= PL_curcop->cop_arybase;
2881     if (SvTYPE(av) != SVt_PVAV)
2882         RETPUSHUNDEF;
2883     svp = av_fetch(av, elem, lval && !defer);
2884     if (lval) {
2885         if (!svp || *svp == &PL_sv_undef) {
2886             SV* lv;
2887             if (!defer)
2888                 DIE(aTHX_ PL_no_aelem, elem);
2889             lv = sv_newmortal();
2890             sv_upgrade(lv, SVt_PVLV);
2891             LvTYPE(lv) = 'y';
2892             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2893             LvTARG(lv) = SvREFCNT_inc(av);
2894             LvTARGOFF(lv) = elem;
2895             LvTARGLEN(lv) = 1;
2896             PUSHs(lv);
2897             RETURN;
2898         }
2899         if (PL_op->op_private & OPpLVAL_INTRO)
2900             save_aelem(av, elem, svp);
2901         else if (PL_op->op_private & OPpDEREF)
2902             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2903     }
2904     sv = (svp ? *svp : &PL_sv_undef);
2905     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2906         sv = sv_mortalcopy(sv);
2907     PUSHs(sv);
2908     RETURN;
2909 }
2910
2911 void
2912 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2913 {
2914     if (SvGMAGICAL(sv))
2915         mg_get(sv);
2916     if (!SvOK(sv)) {
2917         if (SvREADONLY(sv))
2918             Perl_croak(aTHX_ PL_no_modify);
2919         if (SvTYPE(sv) < SVt_RV)
2920             sv_upgrade(sv, SVt_RV);
2921         else if (SvTYPE(sv) >= SVt_PV) {
2922             (void)SvOOK_off(sv);
2923             Safefree(SvPVX(sv));
2924             SvLEN(sv) = SvCUR(sv) = 0;
2925         }
2926         switch (to_what) {
2927         case OPpDEREF_SV:
2928             SvRV(sv) = NEWSV(355,0);
2929             break;
2930         case OPpDEREF_AV:
2931             SvRV(sv) = (SV*)newAV();
2932             break;
2933         case OPpDEREF_HV:
2934             SvRV(sv) = (SV*)newHV();
2935             break;
2936         }
2937         SvROK_on(sv);
2938         SvSETMAGIC(sv);
2939     }
2940 }
2941
2942 PP(pp_method)
2943 {
2944     dSP;
2945     SV* sv = TOPs;
2946
2947     if (SvROK(sv)) {
2948         SV* rsv = SvRV(sv);
2949         if (SvTYPE(rsv) == SVt_PVCV) {
2950             SETs(rsv);
2951             RETURN;
2952         }
2953     }
2954
2955     SETs(method_common(sv, Null(U32*)));
2956     RETURN;
2957 }
2958
2959 PP(pp_method_named)
2960 {
2961     dSP;
2962     SV* sv = cSVOP->op_sv;
2963     U32 hash = SvUVX(sv);
2964
2965     XPUSHs(method_common(sv, &hash));
2966     RETURN;
2967 }
2968
2969 STATIC SV *
2970 S_method_common(pTHX_ SV* meth, U32* hashp)
2971 {
2972     SV* sv;
2973     SV* ob;
2974     GV* gv;
2975     HV* stash;
2976     char* name;
2977     STRLEN namelen;
2978     char* packname;
2979     STRLEN packlen;
2980
2981     name = SvPV(meth, namelen);
2982     sv = *(PL_stack_base + TOPMARK + 1);
2983
2984     if (!sv)
2985         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2986
2987     if (SvGMAGICAL(sv))
2988         mg_get(sv);
2989     if (SvROK(sv))
2990         ob = (SV*)SvRV(sv);
2991     else {
2992         GV* iogv;
2993
2994         packname = Nullch;
2995         if (!SvOK(sv) ||
2996             !(packname = SvPV(sv, packlen)) ||
2997             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2998             !(ob=(SV*)GvIO(iogv)))
2999         {
3000             if (!packname ||
3001                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3002                     ? !isIDFIRST_utf8((U8*)packname)
3003                     : !isIDFIRST(*packname)
3004                 ))
3005             {
3006                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3007                            SvOK(sv) ? "without a package or object reference"
3008                                     : "on an undefined value");
3009             }
3010             stash = gv_stashpvn(packname, packlen, TRUE);
3011             goto fetch;
3012         }
3013         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3014     }
3015
3016     if (!ob || !(SvOBJECT(ob)
3017                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3018                      && SvOBJECT(ob))))
3019     {
3020         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3021                    name);
3022     }
3023
3024     stash = SvSTASH(ob);
3025
3026   fetch:
3027     /* shortcut for simple names */
3028     if (hashp) {
3029         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3030         if (he) {
3031             gv = (GV*)HeVAL(he);
3032             if (isGV(gv) && GvCV(gv) &&
3033                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3034                 return (SV*)GvCV(gv);
3035         }
3036     }
3037
3038     gv = gv_fetchmethod(stash, name);
3039     if (!gv) {
3040         char* leaf = name;
3041         char* sep = Nullch;
3042         char* p;
3043         GV* gv;
3044
3045         for (p = name; *p; p++) {
3046             if (*p == '\'')
3047                 sep = p, leaf = p + 1;
3048             else if (*p == ':' && *(p + 1) == ':')
3049                 sep = p, leaf = p + 2;
3050         }
3051         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3052             packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3053             packlen = strlen(packname);
3054         }
3055         else {
3056             packname = name;
3057             packlen = sep - name;
3058         }
3059         gv = gv_fetchpv(packname, 0, SVt_PVHV);
3060         if (gv && isGV(gv)) {
3061             Perl_croak(aTHX_
3062                        "Can't locate object method \"%s\" via package \"%s\"",
3063                        leaf, packname);
3064         }
3065         else {
3066             Perl_croak(aTHX_
3067                        "Can't locate object method \"%s\" via package \"%s\""
3068                        " (perhaps you forgot to load \"%s\"?)",
3069                        leaf, packname, packname);
3070         }
3071     }
3072     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3073 }
3074
3075 #ifdef USE_THREADS
3076 static void
3077 unset_cvowner(pTHXo_ void *cvarg)
3078 {
3079     register CV* cv = (CV *) cvarg;
3080
3081     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3082                            thr, cv, SvPEEK((SV*)cv))));
3083     MUTEX_LOCK(CvMUTEXP(cv));
3084     DEBUG_S(if (CvDEPTH(cv) != 0)
3085                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3086                               CvDEPTH(cv)););
3087     assert(thr == CvOWNER(cv));
3088     CvOWNER(cv) = 0;
3089     MUTEX_UNLOCK(CvMUTEXP(cv));
3090     SvREFCNT_dec(cv);
3091 }
3092 #endif /* USE_THREADS */