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