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