pp_hot.c

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