pp_hot.c

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