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