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