pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  20
  21 /* Hot code. */
  22
  23 #ifdef USE_THREADS
  24 static void
  25 unset_cvowner(cvarg)
  26 void *cvarg;
  27 {
  28     register CV* cv = (CV *) cvarg;
  29 #ifdef DEBUGGING
  30     dTHR;
  31 #endif /* DEBUGGING */
  32
  33     DEBUG_L((PerlIO_printf(PerlIO_stderr(), "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
  34                      (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv))));
  35     MUTEX_LOCK(CvMUTEXP(cv));
  36     DEBUG_L(if (CvDEPTH(cv) != 0)
  37                 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
  38                               CvDEPTH(cv)););
  39     assert(thr == CvOWNER(cv));
  40     CvOWNER(cv) = 0;
  41     MUTEX_UNLOCK(CvMUTEXP(cv));
  42     SvREFCNT_dec(cv);
  43 }
  44 #endif /* USE_THREADS */
  45
  46 PP(pp_const)
  47 {
  48     dSP;
  49     XPUSHs(cSVOP->op_sv);
  50     RETURN;
  51 }
  52
  53 PP(pp_nextstate)
  54 {
  55     curcop = (COP*)op;
  56     TAINT_NOT;          /* Each statement is presumed innocent */
  57     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
  58     FREETMPS;
  59     return NORMAL;
  60 }
  61
  62 PP(pp_gvsv)
  63 {
  64     dSP;
  65     EXTEND(sp,1);
  66     if (op->op_private & OPpLVAL_INTRO)
  67         PUSHs(save_scalar(cGVOP->op_gv));
  68     else
  69         PUSHs(GvSV(cGVOP->op_gv));
  70     RETURN;
  71 }
  72
  73 PP(pp_null)
  74 {
  75     return NORMAL;
  76 }
  77
  78 PP(pp_pushmark)
  79 {
  80     PUSHMARK(stack_sp);
  81     return NORMAL;
  82 }
  83
  84 PP(pp_stringify)
  85 {
  86     dSP; dTARGET;
  87     STRLEN len;
  88     char *s;
  89     s = SvPV(TOPs,len);
  90     sv_setpvn(TARG,s,len);
  91     SETTARG;
  92     RETURN;
  93 }
  94
  95 PP(pp_gv)
  96 {
  97     dSP;
  98     XPUSHs((SV*)cGVOP->op_gv);
  99     RETURN;
 100 }
 101
 102 PP(pp_gelem)
 103 {
 104     GV *gv;
 105     SV *sv;
 106     SV *ref;
 107     char *elem;
 108     dSP;
 109
 110     sv = POPs;
 111     elem = SvPV(sv, na);
 112     gv = (GV*)POPs;
 113     ref = Nullsv;
 114     sv = Nullsv;
 115     switch (elem ? *elem : '\0')
 116     {
 117     case 'A':
 118         if (strEQ(elem, "ARRAY"))
 119             ref = (SV*)GvAV(gv);
 120         break;
 121     case 'C':
 122         if (strEQ(elem, "CODE"))
 123             ref = (SV*)GvCVu(gv);
 124         break;
 125     case 'F':
 126         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 127             ref = (SV*)GvIOp(gv);
 128         break;
 129     case 'G':
 130         if (strEQ(elem, "GLOB"))
 131             ref = (SV*)gv;
 132         break;
 133     case 'H':
 134         if (strEQ(elem, "HASH"))
 135             ref = (SV*)GvHV(gv);
 136         break;
 137     case 'I':
 138         if (strEQ(elem, "IO"))
 139             ref = (SV*)GvIOp(gv);
 140         break;
 141     case 'N':
 142         if (strEQ(elem, "NAME"))
 143             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
 144         break;
 145     case 'P':
 146         if (strEQ(elem, "PACKAGE"))
 147             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 148         break;
 149     case 'S':
 150         if (strEQ(elem, "SCALAR"))
 151             ref = GvSV(gv);
 152         break;
 153     }
 154     if (ref)
 155         sv = newRV(ref);
 156     if (sv)
 157         sv_2mortal(sv);
 158     else
 159         sv = &sv_undef;
 160     XPUSHs(sv);
 161     RETURN;
 162 }
 163
 164 PP(pp_and)
 165 {
 166     dSP;
 167     if (!SvTRUE(TOPs))
 168         RETURN;
 169     else {
 170         --SP;
 171         RETURNOP(cLOGOP->op_other);
 172     }
 173 }
 174
 175 PP(pp_sassign)
 176 {
 177     dSP; dPOPTOPssrl;
 178     MAGIC *mg;
 179
 180     if (op->op_private & OPpASSIGN_BACKWARDS) {
 181         SV *temp;
 182         temp = left; left = right; right = temp;
 183     }
 184     if (tainting && tainted && !SvTAINTED(left))
 185         TAINT_NOT;
 186     SvSetMagicSV(right, left);
 187     SETs(right);
 188     RETURN;
 189 }
 190
 191 PP(pp_cond_expr)
 192 {
 193     dSP;
 194     if (SvTRUEx(POPs))
 195         RETURNOP(cCONDOP->op_true);
 196     else
 197         RETURNOP(cCONDOP->op_false);
 198 }
 199
 200 PP(pp_unstack)
 201 {
 202     I32 oldsave;
 203     TAINT_NOT;          /* Each statement is presumed innocent */
 204     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
 205     FREETMPS;
 206     oldsave = scopestack[scopestack_ix - 1];
 207     LEAVE_SCOPE(oldsave);
 208     return NORMAL;
 209 }
 210
 211 PP(pp_concat)
 212 {
 213   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 214   {
 215     dPOPTOPssrl;
 216     STRLEN len;
 217     char *s;
 218     if (TARG != left) {
 219         s = SvPV(left,len);
 220         sv_setpvn(TARG,s,len);
 221     }
 222     else if (SvGMAGICAL(TARG))
 223         mg_get(TARG);
 224     else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
 225         sv_setpv(TARG, "");     /* Suppress warning. */
 226         s = SvPV_force(TARG, len);
 227     }
 228     s = SvPV(right,len);
 229     if (SvOK(TARG))
 230         sv_catpvn(TARG,s,len);
 231     else
 232         sv_setpvn(TARG,s,len);  /* suppress warning */
 233     SETTARG;
 234     RETURN;
 235   }
 236 }
 237
 238 PP(pp_padsv)
 239 {
 240     dSP; dTARGET;
 241     XPUSHs(TARG);
 242     if (op->op_flags & OPf_MOD) {
 243         if (op->op_private & OPpLVAL_INTRO)
 244             SAVECLEARSV(curpad[op->op_targ]);
 245         else if (op->op_private & OPpDEREF)
 246             vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF);
 247     }
 248     RETURN;
 249 }
 250
 251 PP(pp_readline)
 252 {
 253     last_in_gv = (GV*)(*stack_sp--);
 254     return do_readline();
 255 }
 256
 257 PP(pp_eq)
 258 {
 259     dSP; tryAMAGICbinSET(eq,0);
 260     {
 261       dPOPnv;
 262       SETs(boolSV(TOPn == value));
 263       RETURN;
 264     }
 265 }
 266
 267 PP(pp_preinc)
 268 {
 269     dSP;
 270     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 271         croak(no_modify);
 272     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 273         SvIVX(TOPs) != IV_MAX)
 274     {
 275         ++SvIVX(TOPs);
 276         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 277     }
 278     else
 279         sv_inc(TOPs);
 280     SvSETMAGIC(TOPs);
 281     return NORMAL;
 282 }
 283
 284 PP(pp_or)
 285 {
 286     dSP;
 287     if (SvTRUE(TOPs))
 288         RETURN;
 289     else {
 290         --SP;
 291         RETURNOP(cLOGOP->op_other);
 292     }
 293 }
 294
 295 PP(pp_add)
 296 {
 297     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
 298     {
 299       dPOPTOPnnrl_ul;
 300       SETn( left + right );
 301       RETURN;
 302     }
 303 }
 304
 305 PP(pp_aelemfast)
 306 {
 307     dSP;
 308     AV *av = GvAV((GV*)cSVOP->op_sv);
 309     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
 310     PUSHs(svp ? *svp : &sv_undef);
 311     RETURN;
 312 }
 313
 314 PP(pp_join)
 315 {
 316     dSP; dMARK; dTARGET;
 317     MARK++;
 318     do_join(TARG, *MARK, MARK, SP);
 319     SP = MARK;
 320     SETs(TARG);
 321     RETURN;
 322 }
 323
 324 PP(pp_pushre)
 325 {
 326     dSP;
 327 #ifdef DEBUGGING
 328     /*
 329      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 330      * will be enough to hold an OP*.
 331      */
 332     SV* sv = sv_newmortal();
 333     sv_upgrade(sv, SVt_PVLV);
 334     LvTYPE(sv) = '/';
 335     Copy(&op, &LvTARGOFF(sv), 1, OP*);
 336     XPUSHs(sv);
 337 #else
 338     XPUSHs((SV*)op);
 339 #endif
 340     RETURN;
 341 }
 342
 343 /* Oversized hot code. */
 344
 345 PP(pp_print)
 346 {
 347     dSP; dMARK; dORIGMARK;
 348     GV *gv;
 349     IO *io;
 350     register PerlIO *fp;
 351     MAGIC *mg;
 352
 353     if (op->op_flags & OPf_STACKED)
 354         gv = (GV*)*++MARK;
 355     else
 356         gv = defoutgv;
 357     if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
 358         if (MARK == ORIGMARK) {
 359             EXTEND(SP, 1);
 360             ++MARK;
 361             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 362             ++SP;
 363         }
 364         PUSHMARK(MARK - 1);
 365         *MARK = mg->mg_obj;
 366         PUTBACK;
 367         ENTER;
 368         perl_call_method("PRINT", G_SCALAR);
 369         LEAVE;
 370         SPAGAIN;
 371         MARK = ORIGMARK + 1;
 372         *MARK = *SP;
 373         SP = MARK;
 374         RETURN;
 375     }
 376     if (!(io = GvIO(gv))) {
 377         if (dowarn) {
 378             SV* sv = sv_newmortal();
 379             gv_fullname3(sv, gv, Nullch);
 380             warn("Filehandle %s never opened", SvPV(sv,na));
 381         }
 382
 383         SETERRNO(EBADF,RMS$_IFI);
 384         goto just_say_no;
 385     }
 386     else if (!(fp = IoOFP(io))) {
 387         if (dowarn)  {
 388             SV* sv = sv_newmortal();
 389             gv_fullname3(sv, gv, Nullch);
 390             if (IoIFP(io))
 391                 warn("Filehandle %s opened only for input", SvPV(sv,na));
 392             else
 393                 warn("print on closed filehandle %s", SvPV(sv,na));
 394         }
 395         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 396         goto just_say_no;
 397     }
 398     else {
 399         MARK++;
 400         if (ofslen) {
 401             while (MARK <= SP) {
 402                 if (!do_print(*MARK, fp))
 403                     break;
 404                 MARK++;
 405                 if (MARK <= SP) {
 406                     if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) {
 407                         MARK--;
 408                         break;
 409                     }
 410                 }
 411             }
 412         }
 413         else {
 414             while (MARK <= SP) {
 415                 if (!do_print(*MARK, fp))
 416                     break;
 417                 MARK++;
 418             }
 419         }
 420         if (MARK <= SP)
 421             goto just_say_no;
 422         else {
 423             if (orslen)
 424                 if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp))
 425                     goto just_say_no;
 426
 427             if (IoFLAGS(io) & IOf_FLUSH)
 428                 if (PerlIO_flush(fp) == EOF)
 429                     goto just_say_no;
 430         }
 431     }
 432     SP = ORIGMARK;
 433     PUSHs(&sv_yes);
 434     RETURN;
 435
 436   just_say_no:
 437     SP = ORIGMARK;
 438     PUSHs(&sv_undef);
 439     RETURN;
 440 }
 441
 442 PP(pp_rv2av)
 443 {
 444     dSP; dPOPss;
 445     AV *av;
 446
 447     if (SvROK(sv)) {
 448       wasref:
 449         av = (AV*)SvRV(sv);
 450         if (SvTYPE(av) != SVt_PVAV)
 451             DIE("Not an ARRAY reference");
 452         if (op->op_private & OPpLVAL_INTRO)
 453             av = (AV*)save_svref((SV**)sv);
 454         if (op->op_flags & OPf_REF) {
 455             PUSHs((SV*)av);
 456             RETURN;
 457         }
 458     }
 459     else {
 460         if (SvTYPE(sv) == SVt_PVAV) {
 461             av = (AV*)sv;
 462             if (op->op_flags & OPf_REF) {
 463                 PUSHs((SV*)av);
 464                 RETURN;
 465             }
 466         }
 467         else {
 468             GV *gv;
 469
 470             if (SvTYPE(sv) != SVt_PVGV) {
 471                 char *sym;
 472
 473                 if (SvGMAGICAL(sv)) {
 474                     mg_get(sv);
 475                     if (SvROK(sv))
 476                         goto wasref;
 477                 }
 478                 if (!SvOK(sv)) {
 479                     if (op->op_flags & OPf_REF ||
 480                       op->op_private & HINT_STRICT_REFS)
 481                         DIE(no_usym, "an ARRAY");
 482                     if (dowarn)
 483                         warn(warn_uninit);
 484                     if (GIMME == G_ARRAY)
 485                         RETURN;
 486                     RETPUSHUNDEF;
 487                 }
 488                 sym = SvPV(sv,na);
 489                 if (op->op_private & HINT_STRICT_REFS)
 490                     DIE(no_symref, sym, "an ARRAY");
 491                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 492             } else {
 493                 gv = (GV*)sv;
 494             }
 495             av = GvAVn(gv);
 496             if (op->op_private & OPpLVAL_INTRO)
 497                 av = save_ary(gv);
 498             if (op->op_flags & OPf_REF) {
 499                 PUSHs((SV*)av);
 500                 RETURN;
 501             }
 502         }
 503     }
 504
 505     if (GIMME == G_ARRAY) {
 506         I32 maxarg = AvFILL(av) + 1;
 507         EXTEND(SP, maxarg);
 508         Copy(AvARRAY(av), SP+1, maxarg, SV*);
 509         SP += maxarg;
 510     }
 511     else {
 512         dTARGET;
 513         I32 maxarg = AvFILL(av) + 1;
 514         PUSHi(maxarg);
 515     }
 516     RETURN;
 517 }
 518
 519 PP(pp_rv2hv)
 520 {
 521     dSP; dTOPss;
 522     HV *hv;
 523
 524     if (SvROK(sv)) {
 525       wasref:
 526         hv = (HV*)SvRV(sv);
 527         if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
 528             DIE("Not a HASH reference");
 529         if (op->op_private & OPpLVAL_INTRO)
 530             hv = (HV*)save_svref((SV**)sv);
 531         if (op->op_flags & OPf_REF) {
 532             SETs((SV*)hv);
 533             RETURN;
 534         }
 535     }
 536     else {
 537         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
 538             hv = (HV*)sv;
 539             if (op->op_flags & OPf_REF) {
 540                 SETs((SV*)hv);
 541                 RETURN;
 542             }
 543         }
 544         else {
 545             GV *gv;
 546
 547             if (SvTYPE(sv) != SVt_PVGV) {
 548                 char *sym;
 549
 550                 if (SvGMAGICAL(sv)) {
 551                     mg_get(sv);
 552                     if (SvROK(sv))
 553                         goto wasref;
 554                 }
 555                 if (!SvOK(sv)) {
 556                     if (op->op_flags & OPf_REF ||
 557                       op->op_private & HINT_STRICT_REFS)
 558                         DIE(no_usym, "a HASH");
 559                     if (dowarn)
 560                         warn(warn_uninit);
 561                     if (GIMME == G_ARRAY) {
 562                         SP--;
 563                         RETURN;
 564                     }
 565                     RETSETUNDEF;
 566                 }
 567                 sym = SvPV(sv,na);
 568                 if (op->op_private & HINT_STRICT_REFS)
 569                     DIE(no_symref, sym, "a HASH");
 570                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 571             } else {
 572                 gv = (GV*)sv;
 573             }
 574             hv = GvHVn(gv);
 575             if (op->op_private & OPpLVAL_INTRO)
 576                 hv = save_hash(gv);
 577             if (op->op_flags & OPf_REF) {
 578                 SETs((SV*)hv);
 579                 RETURN;
 580             }
 581         }
 582     }
 583
 584     if (GIMME == G_ARRAY) { /* array wanted */
 585         *stack_sp = (SV*)hv;
 586         return do_kv(ARGS);
 587     }
 588     else {
 589         dTARGET;
 590         /* This bit is OK even when hv is really an AV */
 591         if (HvFILL(hv))
 592             sv_setpvf(TARG, "%ld/%ld",
 593                       (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 594         else
 595             sv_setiv(TARG, 0);
 596
 597         SETTARG;
 598         RETURN;
 599     }
 600 }
 601
 602 PP(pp_aassign)
 603 {
 604     dSP;
 605     SV **lastlelem = stack_sp;
 606     SV **lastrelem = stack_base + POPMARK;
 607     SV **firstrelem = stack_base + POPMARK + 1;
 608     SV **firstlelem = lastrelem + 1;
 609
 610     register SV **relem;
 611     register SV **lelem;
 612
 613     register SV *sv;
 614     register AV *ary;
 615
 616     I32 gimme;
 617     HV *hash;
 618     I32 i;
 619     int magic;
 620
 621     delaymagic = DM_DELAY;              /* catch simultaneous items */
 622
 623     /* If there's a common identifier on both sides we have to take
 624      * special care that assigning the identifier on the left doesn't
 625      * clobber a value on the right that's used later in the list.
 626      */
 627     if (op->op_private & OPpASSIGN_COMMON) {
 628         for (relem = firstrelem; relem <= lastrelem; relem++) {
 629             /*SUPPRESS 560*/
 630             if (sv = *relem) {
 631                 TAINT_NOT;      /* Each item is independent */
 632                 *relem = sv_mortalcopy(sv);
 633             }
 634         }
 635     }
 636
 637     relem = firstrelem;
 638     lelem = firstlelem;
 639     ary = Null(AV*);
 640     hash = Null(HV*);
 641     while (lelem <= lastlelem) {
 642         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 643         sv = *lelem++;
 644         switch (SvTYPE(sv)) {
 645         case SVt_PVAV:
 646             ary = (AV*)sv;
 647             magic = SvMAGICAL(ary) != 0;
 648
 649             av_clear(ary);
 650             av_extend(ary, lastrelem - relem);
 651             i = 0;
 652             while (relem <= lastrelem) {        /* gobble up all the rest */
 653                 SV **didstore;
 654                 sv = NEWSV(28,0);
 655                 assert(*relem);
 656                 sv_setsv(sv,*relem);
 657                 *(relem++) = sv;
 658                 didstore = av_store(ary,i++,sv);
 659                 if (magic) {
 660                     mg_set(sv);
 661                     if (!didstore)
 662                         SvREFCNT_dec(sv);
 663                 }
 664                 TAINT_NOT;
 665             }
 666             break;
 667         case SVt_PVHV: {
 668                 SV *tmpstr;
 669
 670                 hash = (HV*)sv;
 671                 magic = SvMAGICAL(hash) != 0;
 672                 hv_clear(hash);
 673
 674                 while (relem < lastrelem) {     /* gobble up all the rest */
 675                     STRLEN len;
 676                     HE *didstore;
 677                     if (*relem)
 678                         sv = *(relem++);
 679                     else
 680                         sv = &sv_no, relem++;
 681                     tmpstr = NEWSV(29,0);
 682                     if (*relem)
 683                         sv_setsv(tmpstr,*relem);        /* value */
 684                     *(relem++) = tmpstr;
 685                     didstore = hv_store_ent(hash,sv,tmpstr,0);
 686                     if (magic) {
 687                         mg_set(tmpstr);
 688                         if (!didstore)
 689                             SvREFCNT_dec(tmpstr);
 690                     }
 691                     TAINT_NOT;
 692                 }
 693                 if (relem == lastrelem)
 694                     warn("Odd number of elements in hash list");
 695             }
 696             break;
 697         default:
 698             if (SvTHINKFIRST(sv)) {
 699                 if (SvREADONLY(sv) && curcop != &compiling) {
 700                     if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
 701                         DIE(no_modify);
 702                     if (relem <= lastrelem)
 703                         relem++;
 704                     break;
 705                 }
 706                 if (SvROK(sv))
 707                     sv_unref(sv);
 708             }
 709             if (relem <= lastrelem) {
 710                 sv_setsv(sv, *relem);
 711                 *(relem++) = sv;
 712             }
 713             else
 714                 sv_setsv(sv, &sv_undef);
 715             SvSETMAGIC(sv);
 716             break;
 717         }
 718     }
 719     if (delaymagic & ~DM_DELAY) {
 720         if (delaymagic & DM_UID) {
 721 #ifdef HAS_SETRESUID
 722             (void)setresuid(uid,euid,(Uid_t)-1);
 723 #else
 724 #  ifdef HAS_SETREUID
 725             (void)setreuid(uid,euid);
 726 #  else
 727 #    ifdef HAS_SETRUID
 728             if ((delaymagic & DM_UID) == DM_RUID) {
 729                 (void)setruid(uid);
 730                 delaymagic &= ~DM_RUID;
 731             }
 732 #    endif /* HAS_SETRUID */
 733 #    ifdef HAS_SETEUID
 734             if ((delaymagic & DM_UID) == DM_EUID) {
 735                 (void)seteuid(uid);
 736                 delaymagic &= ~DM_EUID;
 737             }
 738 #    endif /* HAS_SETEUID */
 739             if (delaymagic & DM_UID) {
 740                 if (uid != euid)
 741                     DIE("No setreuid available");
 742                 (void)setuid(uid);
 743             }
 744 #  endif /* HAS_SETREUID */
 745 #endif /* HAS_SETRESUID */
 746             uid = (int)getuid();
 747             euid = (int)geteuid();
 748         }
 749         if (delaymagic & DM_GID) {
 750 #ifdef HAS_SETRESGID
 751             (void)setresgid(gid,egid,(Gid_t)-1);
 752 #else
 753 #  ifdef HAS_SETREGID
 754             (void)setregid(gid,egid);
 755 #  else
 756 #    ifdef HAS_SETRGID
 757             if ((delaymagic & DM_GID) == DM_RGID) {
 758                 (void)setrgid(gid);
 759                 delaymagic &= ~DM_RGID;
 760             }
 761 #    endif /* HAS_SETRGID */
 762 #    ifdef HAS_SETEGID
 763             if ((delaymagic & DM_GID) == DM_EGID) {
 764                 (void)setegid(gid);
 765                 delaymagic &= ~DM_EGID;
 766             }
 767 #    endif /* HAS_SETEGID */
 768             if (delaymagic & DM_GID) {
 769                 if (gid != egid)
 770                     DIE("No setregid available");
 771                 (void)setgid(gid);
 772             }
 773 #  endif /* HAS_SETREGID */
 774 #endif /* HAS_SETRESGID */
 775             gid = (int)getgid();
 776             egid = (int)getegid();
 777         }
 778         tainting |= (uid && (euid != uid || egid != gid));
 779     }
 780     delaymagic = 0;
 781
 782     gimme = GIMME_V;
 783     if (gimme == G_VOID)
 784         SP = firstrelem - 1;
 785     else if (gimme == G_SCALAR) {
 786         dTARGET;
 787         SP = firstrelem;
 788         SETi(lastrelem - firstrelem + 1);
 789     }
 790     else {
 791         if (ary || hash)
 792             SP = lastrelem;
 793         else
 794             SP = firstrelem + (lastlelem - firstlelem);
 795         lelem = firstlelem + (relem - firstrelem);
 796         while (relem <= SP)
 797             *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef;
 798     }
 799     RETURN;
 800 }
 801
 802 PP(pp_match)
 803 {
 804     dSP; dTARG;
 805     register PMOP *pm = cPMOP;
 806     register char *t;
 807     register char *s;
 808     char *strend;
 809     I32 global;
 810     I32 safebase;
 811     char *truebase;
 812     register REGEXP *rx = pm->op_pmregexp;
 813     I32 gimme = GIMME;
 814     STRLEN len;
 815     I32 minmatch = 0;
 816     I32 oldsave = savestack_ix;
 817     I32 update_minmatch = 1;
 818
 819     if (op->op_flags & OPf_STACKED)
 820         TARG = POPs;
 821     else {
 822         TARG = GvSV(defgv);
 823         EXTEND(SP,1);
 824     }
 825     s = SvPV(TARG, len);
 826     strend = s + len;
 827     if (!s)
 828         DIE("panic: do_match");
 829     TAINT_NOT;
 830
 831     if (pm->op_pmflags & PMf_USED) {
 832         if (gimme == G_ARRAY)
 833             RETURN;
 834         RETPUSHNO;
 835     }
 836
 837     if (!rx->prelen && curpm) {
 838         pm = curpm;
 839         rx = pm->op_pmregexp;
 840     }
 841     truebase = t = s;
 842     if (global = pm->op_pmflags & PMf_GLOBAL) {
 843         rx->startp[0] = 0;
 844         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
 845             MAGIC* mg = mg_find(TARG, 'g');
 846             if (mg && mg->mg_len >= 0) {
 847                 rx->endp[0] = rx->startp[0] = s + mg->mg_len;
 848                 minmatch = (mg->mg_flags & MGf_MINMATCH);
 849                 update_minmatch = 0;
 850             }
 851         }
 852     }
 853     if (!rx->nparens && !global)
 854         gimme = G_SCALAR;                       /* accidental array context? */
 855     safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
 856                 && !sawampersand);
 857     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
 858         SAVEINT(multiline);
 859         multiline = pm->op_pmflags & PMf_MULTILINE;
 860     }
 861
 862 play_it_again:
 863     if (global && rx->startp[0]) {
 864         t = s = rx->endp[0];
 865         if ((s + rx->minlen) > strend)
 866             goto nope;
 867         if (update_minmatch++)
 868             minmatch = (s == rx->startp[0]);
 869     }
 870     if (pm->op_pmshort) {
 871         if (pm->op_pmflags & PMf_SCANFIRST) {
 872             if (SvSCREAM(TARG)) {
 873                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
 874                     goto nope;
 875                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
 876                     goto nope;
 877                 else if (pm->op_pmflags & PMf_ALL)
 878                     goto yup;
 879             }
 880             else if (!(s = fbm_instr((unsigned char*)s,
 881               (unsigned char*)strend, pm->op_pmshort)))
 882                 goto nope;
 883             else if (pm->op_pmflags & PMf_ALL)
 884                 goto yup;
 885             if (s && rx->regback >= 0) {
 886                 ++BmUSEFUL(pm->op_pmshort);
 887                 s -= rx->regback;
 888                 if (s < t)
 889                     s = t;
 890             }
 891             else
 892                 s = t;
 893         }
 894         else if (!multiline) {
 895             if (*SvPVX(pm->op_pmshort) != *s
 896                 || (pm->op_pmslen > 1
 897                     && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
 898                 goto nope;
 899         }
 900         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
 901             SvREFCNT_dec(pm->op_pmshort);
 902             pm->op_pmshort = Nullsv;    /* opt is being useless */
 903         }
 904     }
 905     if (pregexec(rx, s, strend, truebase, minmatch,
 906                  SvSCREAM(TARG) ? TARG : Nullsv, safebase))
 907     {
 908         curpm = pm;
 909         if (pm->op_pmflags & PMf_ONCE)
 910             pm->op_pmflags |= PMf_USED;
 911         goto gotcha;
 912     }
 913     else
 914         goto ret_no;
 915     /*NOTREACHED*/
 916
 917   gotcha:
 918     TAINT_IF(rx->exec_tainted);
 919     if (gimme == G_ARRAY) {
 920         I32 iters, i, len;
 921
 922         iters = rx->nparens;
 923         if (global && !iters)
 924             i = 1;
 925         else
 926             i = 0;
 927         EXTEND(SP, iters + i);
 928         EXTEND_MORTAL(iters + i);
 929         for (i = !i; i <= iters; i++) {
 930             PUSHs(sv_newmortal());
 931             /*SUPPRESS 560*/
 932             if ((s = rx->startp[i]) && rx->endp[i] ) {
 933                 len = rx->endp[i] - s;
 934                 sv_setpvn(*SP, s, len);
 935             }
 936         }
 937         if (global) {
 938             truebase = rx->subbeg;
 939             strend = rx->subend;
 940             if (rx->startp[0] && rx->startp[0] == rx->endp[0])
 941                 ++rx->endp[0];
 942             goto play_it_again;
 943         }
 944         LEAVE_SCOPE(oldsave);
 945         RETURN;
 946     }
 947     else {
 948         if (global) {
 949             MAGIC* mg = 0;
 950             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
 951                 mg = mg_find(TARG, 'g');
 952             if (!mg) {
 953                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
 954                 mg = mg_find(TARG, 'g');
 955             }
 956             if (rx->startp[0]) {
 957                 mg->mg_len = rx->endp[0] - rx->subbeg;
 958                 if (rx->startp[0] == rx->endp[0])
 959                     mg->mg_flags |= MGf_MINMATCH;
 960                 else
 961                     mg->mg_flags &= ~MGf_MINMATCH;
 962             }
 963         }
 964         LEAVE_SCOPE(oldsave);
 965         RETPUSHYES;
 966     }
 967
 968 yup:
 969     TAINT_IF(rx->exec_tainted);
 970     ++BmUSEFUL(pm->op_pmshort);
 971     curpm = pm;
 972     if (pm->op_pmflags & PMf_ONCE)
 973         pm->op_pmflags |= PMf_USED;
 974     Safefree(rx->subbase);
 975     rx->subbase = Nullch;
 976     if (global) {
 977         rx->subbeg = truebase;
 978         rx->subend = strend;
 979         rx->startp[0] = s;
 980         rx->endp[0] = s + SvCUR(pm->op_pmshort);
 981         goto gotcha;
 982     }
 983     if (sawampersand) {
 984         char *tmps;
 985
 986         tmps = rx->subbase = savepvn(t, strend-t);
 987         rx->subbeg = tmps;
 988         rx->subend = tmps + (strend-t);
 989         tmps = rx->startp[0] = tmps + (s - t);
 990         rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
 991     }
 992     LEAVE_SCOPE(oldsave);
 993     RETPUSHYES;
 994
 995 nope:
 996     if (pm->op_pmshort)
 997         ++BmUSEFUL(pm->op_pmshort);
 998
 999 ret_no:
1000     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1001         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1002             MAGIC* mg = mg_find(TARG, 'g');
1003             if (mg)
1004                 mg->mg_len = -1;
1005         }
1006     }
1007     LEAVE_SCOPE(oldsave);
1008     if (gimme == G_ARRAY)
1009         RETURN;
1010     RETPUSHNO;
1011 }
1012
1013 OP *
1014 do_readline()
1015 {
1016     dTHR;
1017     dSP; dTARGETSTACKED;
1018     register SV *sv;
1019     STRLEN tmplen = 0;
1020     STRLEN offset;
1021     PerlIO *fp;
1022     register IO *io = GvIO(last_in_gv);
1023     register I32 type = op->op_type;
1024     I32 gimme = GIMME_V;
1025     MAGIC *mg;
1026
1027     if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) {
1028         PUSHMARK(SP);
1029         XPUSHs(mg->mg_obj);
1030         PUTBACK;
1031         ENTER;
1032         perl_call_method("READLINE", gimme);
1033         LEAVE;
1034         SPAGAIN;
1035         if (gimme == G_SCALAR)
1036             SvSetMagicSV_nosteal(TARG, TOPs);
1037         RETURN;
1038     }
1039     fp = Nullfp;
1040     if (io) {
1041         fp = IoIFP(io);
1042         if (!fp) {
1043             if (IoFLAGS(io) & IOf_ARGV) {
1044                 if (IoFLAGS(io) & IOf_START) {
1045                     IoFLAGS(io) &= ~IOf_START;
1046                     IoLINES(io) = 0;
1047                     if (av_len(GvAVn(last_in_gv)) < 0) {
1048                         SV *tmpstr = newSVpv("-", 1); /* assume stdin */
1049                         av_push(GvAVn(last_in_gv), tmpstr);
1050                     }
1051                 }
1052                 fp = nextargv(last_in_gv);
1053                 if (!fp) { /* Note: fp != IoIFP(io) */
1054                     (void)do_close(last_in_gv, FALSE); /* now it does*/
1055                     IoFLAGS(io) |= IOf_START;
1056                 }
1057             }
1058             else if (type == OP_GLOB) {
1059                 SV *tmpcmd = NEWSV(55, 0);
1060                 SV *tmpglob = POPs;
1061                 ENTER;
1062                 SAVEFREESV(tmpcmd);
1063 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1064            /* since spawning off a process is a real performance hit */
1065                 {
1066 #include <descrip.h>
1067 #include <lib$routines.h>
1068 #include <nam.h>
1069 #include <rmsdef.h>
1070                     char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1071                     char vmsspec[NAM$C_MAXRSS+1];
1072                     char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1073                     char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1074                     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1075                     PerlIO *tmpfp;
1076                     STRLEN i;
1077                     struct dsc$descriptor_s wilddsc
1078                        = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1079                     struct dsc$descriptor_vs rsdsc
1080                        = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1081                     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1082
1083                     /* We could find out if there's an explicit dev/dir or version
1084                        by peeking into lib$find_file's internal context at
1085                        ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1086                        but that's unsupported, so I don't want to do it now and
1087                        have it bite someone in the future. */
1088                     strcat(tmpfnam,tmpnam(NULL));
1089                     cp = SvPV(tmpglob,i);
1090                     for (; i; i--) {
1091                        if (cp[i] == ';') hasver = 1;
1092                        if (cp[i] == '.') {
1093                            if (sts) hasver = 1;
1094                            else sts = 1;
1095                        }
1096                        if (cp[i] == '/') {
1097                           hasdir = isunix = 1;
1098                           break;
1099                        }
1100                        if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1101                            hasdir = 1;
1102                            break;
1103                        }
1104                     }
1105                     if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
1106                         ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1107                         if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1108                         while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1109                                                     &dfltdsc,NULL,NULL,NULL))&1)) {
1110                             end = rstr + (unsigned long int) *rslt;
1111                             if (!hasver) while (*end != ';') end--;
1112                             *(end++) = '\n';  *end = '\0';
1113                             for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1114                             if (hasdir) {
1115                               if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
1116                               begin = rstr;
1117                             }
1118                             else {
1119                                 begin = end;
1120                                 while (*(--begin) != ']' && *begin != '>') ;
1121                                 ++begin;
1122                             }
1123                             ok = (PerlIO_puts(tmpfp,begin) != EOF);
1124                         }
1125                         if (cxt) (void)lib$find_file_end(&cxt);
1126                         if (ok && sts != RMS$_NMF &&
1127                             sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1128                         if (!ok) {
1129                             if (!(sts & 1)) {
1130                               SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1131                             }
1132                             PerlIO_close(tmpfp);
1133                             fp = NULL;
1134                         }
1135                         else {
1136                            PerlIO_rewind(tmpfp);
1137                            IoTYPE(io) = '<';
1138                            IoIFP(io) = fp = tmpfp;
1139                            IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
1140                         }
1141                     }
1142                 }
1143 #else /* !VMS */
1144 #ifdef DOSISH
1145 #ifdef OS2
1146                 sv_setpv(tmpcmd, "for a in ");
1147                 sv_catsv(tmpcmd, tmpglob);
1148                 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1149 #else
1150                 sv_setpv(tmpcmd, "perlglob ");
1151                 sv_catsv(tmpcmd, tmpglob);
1152                 sv_catpv(tmpcmd, " |");
1153 #endif /* !OS2 */
1154 #else /* !DOSISH */
1155 #if defined(CSH)
1156                 sv_setpvn(tmpcmd, cshname, cshlen);
1157                 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1158                 sv_catsv(tmpcmd, tmpglob);
1159                 sv_catpv(tmpcmd, "' 2>/dev/null |");
1160 #else
1161                 sv_setpv(tmpcmd, "echo ");
1162                 sv_catsv(tmpcmd, tmpglob);
1163 #if 'z' - 'a' == 25
1164                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1165 #else
1166                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1167 #endif
1168 #endif /* !CSH */
1169 #endif /* !DOSISH */
1170                 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1171                               FALSE, 0, 0, Nullfp);
1172                 fp = IoIFP(io);
1173 #endif /* !VMS */
1174                 LEAVE;
1175             }
1176         }
1177         else if (type == OP_GLOB)
1178             SP--;
1179     }
1180     if (!fp) {
1181         if (dowarn && io && !(IoFLAGS(io) & IOf_START))
1182             warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
1183         if (gimme == G_SCALAR) {
1184             (void)SvOK_off(TARG);
1185             PUSHTARG;
1186         }
1187         RETURN;
1188     }
1189     if (gimme == G_SCALAR) {
1190         sv = TARG;
1191         if (SvROK(sv))
1192             sv_unref(sv);
1193         (void)SvUPGRADE(sv, SVt_PV);
1194         tmplen = SvLEN(sv);     /* remember if already alloced */
1195         if (!tmplen)
1196             Sv_Grow(sv, 80);    /* try short-buffering it */
1197         if (type == OP_RCATLINE)
1198             offset = SvCUR(sv);
1199         else
1200             offset = 0;
1201     }
1202     else {
1203         sv = sv_2mortal(NEWSV(57, 80));
1204         offset = 0;
1205     }
1206     for (;;) {
1207         if (!sv_gets(sv, fp, offset)) {
1208             PerlIO_clearerr(fp);
1209             if (IoFLAGS(io) & IOf_ARGV) {
1210                 fp = nextargv(last_in_gv);
1211                 if (fp)
1212                     continue;
1213                 (void)do_close(last_in_gv, FALSE);
1214                 IoFLAGS(io) |= IOf_START;
1215             }
1216             else if (type == OP_GLOB) {
1217                 if (do_close(last_in_gv, FALSE) & ~0xFF)
1218                     warn("internal error: glob failed");
1219             }
1220             if (gimme == G_SCALAR) {
1221                 (void)SvOK_off(TARG);
1222                 PUSHTARG;
1223             }
1224             RETURN;
1225         }
1226         /* This should not be marked tainted if the fp is marked clean */
1227         if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1228             TAINT;
1229             SvTAINTED_on(sv);
1230         }
1231         IoLINES(io)++;
1232         SvSETMAGIC(sv);
1233         XPUSHs(sv);
1234         if (type == OP_GLOB) {
1235             char *tmps;
1236
1237             if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
1238                 tmps = SvEND(sv) - 1;
1239                 if (*tmps == *SvPVX(rs)) {
1240                     *tmps = '\0';
1241                     SvCUR(sv)--;
1242                 }
1243             }
1244             for (tmps = SvPVX(sv); *tmps; tmps++)
1245                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1246                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1247                         break;
1248             if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
1249                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1250                 continue;
1251             }
1252         }
1253         if (gimme == G_ARRAY) {
1254             if (SvLEN(sv) - SvCUR(sv) > 20) {
1255                 SvLEN_set(sv, SvCUR(sv)+1);
1256                 Renew(SvPVX(sv), SvLEN(sv), char);
1257             }
1258             sv = sv_2mortal(NEWSV(58, 80));
1259             continue;
1260         }
1261         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1262             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1263             if (SvCUR(sv) < 60)
1264                 SvLEN_set(sv, 80);
1265             else
1266                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1267             Renew(SvPVX(sv), SvLEN(sv), char);
1268         }
1269         RETURN;
1270     }
1271 }
1272
1273 PP(pp_enter)
1274 {
1275     dSP;
1276     register CONTEXT *cx;
1277     I32 gimme = OP_GIMME(op, -1);
1278
1279     if (gimme == -1) {
1280         if (cxstack_ix >= 0)
1281             gimme = cxstack[cxstack_ix].blk_gimme;
1282         else
1283             gimme = G_SCALAR;
1284     }
1285
1286     ENTER;
1287
1288     SAVETMPS;
1289     PUSHBLOCK(cx, CXt_BLOCK, sp);
1290
1291     RETURN;
1292 }
1293
1294 PP(pp_helem)
1295 {
1296     dSP;
1297     HE* he;
1298     SV **svp;
1299     SV *keysv = POPs;
1300     HV *hv = (HV*)POPs;
1301     U32 lval = op->op_flags & OPf_MOD;
1302     U32 defer = op->op_private & OPpLVAL_DEFER;
1303
1304     if (SvTYPE(hv) == SVt_PVHV) {
1305         he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1306         svp = he ? &HeVAL(he) : 0;
1307     }
1308     else if (SvTYPE(hv) == SVt_PVAV) {
1309         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
1310     }
1311     else {
1312         RETPUSHUNDEF;
1313     }
1314     if (lval) {
1315         if (!svp || *svp == &sv_undef) {
1316             SV* lv;
1317             SV* key2;
1318             if (!defer)
1319                 DIE(no_helem, SvPV(keysv, na));
1320             lv = sv_newmortal();
1321             sv_upgrade(lv, SVt_PVLV);
1322             LvTYPE(lv) = 'y';
1323             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1324             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1325             LvTARG(lv) = SvREFCNT_inc(hv);
1326             LvTARGLEN(lv) = 1;
1327             PUSHs(lv);
1328             RETURN;
1329         }
1330         if (op->op_private & OPpLVAL_INTRO) {
1331             if (HvNAME(hv) && isGV(*svp))
1332                 save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL));
1333             else
1334                 save_svref(svp);
1335         }
1336         else if (op->op_private & OPpDEREF)
1337             vivify_ref(*svp, op->op_private & OPpDEREF);
1338     }
1339     PUSHs(svp ? *svp : &sv_undef);
1340     RETURN;
1341 }
1342
1343 PP(pp_leave)
1344 {
1345     dSP;
1346     register CONTEXT *cx;
1347     register SV **mark;
1348     SV **newsp;
1349     PMOP *newpm;
1350     I32 gimme;
1351
1352     if (op->op_flags & OPf_SPECIAL) {
1353         cx = &cxstack[cxstack_ix];
1354         cx->blk_oldpm = curpm;  /* fake block should preserve $1 et al */
1355     }
1356
1357     POPBLOCK(cx,newpm);
1358
1359     gimme = OP_GIMME(op, -1);
1360     if (gimme == -1) {
1361         if (cxstack_ix >= 0)
1362             gimme = cxstack[cxstack_ix].blk_gimme;
1363         else
1364             gimme = G_SCALAR;
1365     }
1366
1367     TAINT_NOT;
1368     if (gimme == G_VOID)
1369         SP = newsp;
1370     else if (gimme == G_SCALAR) {
1371         MARK = newsp + 1;
1372         if (MARK <= SP)
1373             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1374                 *MARK = TOPs;
1375             else
1376                 *MARK = sv_mortalcopy(TOPs);
1377         else {
1378             MEXTEND(mark,0);
1379             *MARK = &sv_undef;
1380         }
1381         SP = MARK;
1382     }
1383     else if (gimme == G_ARRAY) {
1384         /* in case LEAVE wipes old return values */
1385         for (mark = newsp + 1; mark <= SP; mark++) {
1386             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1387                 *mark = sv_mortalcopy(*mark);
1388                 TAINT_NOT;      /* Each item is independent */
1389             }
1390         }
1391     }
1392     curpm = newpm;      /* Don't pop $1 et al till now */
1393
1394     LEAVE;
1395
1396     RETURN;
1397 }
1398
1399 PP(pp_iter)
1400 {
1401     dSP;
1402     register CONTEXT *cx;
1403     SV* sv;
1404     AV* av;
1405
1406     EXTEND(sp, 1);
1407     cx = &cxstack[cxstack_ix];
1408     if (cx->cx_type != CXt_LOOP)
1409         DIE("panic: pp_iter");
1410
1411     av = cx->blk_loop.iterary;
1412     if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
1413         RETPUSHNO;
1414
1415     SvREFCNT_dec(*cx->blk_loop.itervar);
1416
1417     if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
1418         SvTEMP_off(sv);
1419     else
1420         sv = &sv_undef;
1421     if (av != curstack && SvIMMORTAL(sv)) {
1422         SV *lv = cx->blk_loop.iterlval;
1423         if (lv && SvREFCNT(lv) > 1) {
1424             SvREFCNT_dec(lv);
1425             lv = Nullsv;
1426         }
1427         if (lv)
1428             SvREFCNT_dec(LvTARG(lv));
1429         else {
1430             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1431             sv_upgrade(lv, SVt_PVLV);
1432             LvTYPE(lv) = 'y';
1433             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1434         }
1435         LvTARG(lv) = SvREFCNT_inc(av);
1436         LvTARGOFF(lv) = cx->blk_loop.iterix;
1437         LvTARGLEN(lv) = -1;
1438         sv = (SV*)lv;
1439     }
1440
1441     *cx->blk_loop.itervar = SvREFCNT_inc(sv);
1442     RETPUSHYES;
1443 }
1444
1445 PP(pp_subst)
1446 {
1447     dSP; dTARG;
1448     register PMOP *pm = cPMOP;
1449     PMOP *rpm = pm;
1450     register SV *dstr;
1451     register char *s;
1452     char *strend;
1453     register char *m;
1454     char *c;
1455     register char *d;
1456     STRLEN clen;
1457     I32 iters = 0;
1458     I32 maxiters;
1459     register I32 i;
1460     bool once;
1461     bool rxtainted;
1462     char *orig;
1463     I32 safebase;
1464     register REGEXP *rx = pm->op_pmregexp;
1465     STRLEN len;
1466     int force_on_match = 0;
1467     I32 oldsave = savestack_ix;
1468
1469     /* known replacement string? */
1470     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1471     if (op->op_flags & OPf_STACKED)
1472         TARG = POPs;
1473     else {
1474         TARG = GvSV(defgv);
1475         EXTEND(SP,1);
1476     }
1477     if (SvREADONLY(TARG)
1478         || (SvTYPE(TARG) > SVt_PVLV
1479             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1480         croak(no_modify);
1481     s = SvPV(TARG, len);
1482     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1483         force_on_match = 1;
1484     TAINT_NOT;
1485
1486   force_it:
1487     if (!pm || !s)
1488         DIE("panic: do_subst");
1489
1490     strend = s + len;
1491     maxiters = (strend - s) + 10;
1492
1493     if (!rx->prelen && curpm) {
1494         pm = curpm;
1495         rx = pm->op_pmregexp;
1496     }
1497     safebase = (!rx->nparens && !sawampersand);
1498     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1499         SAVEINT(multiline);
1500         multiline = pm->op_pmflags & PMf_MULTILINE;
1501     }
1502     orig = m = s;
1503     if (pm->op_pmshort) {
1504         if (pm->op_pmflags & PMf_SCANFIRST) {
1505             if (SvSCREAM(TARG)) {
1506                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
1507                     goto nope;
1508                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
1509                     goto nope;
1510             }
1511             else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
1512               pm->op_pmshort)))
1513                 goto nope;
1514             if (s && rx->regback >= 0) {
1515                 ++BmUSEFUL(pm->op_pmshort);
1516                 s -= rx->regback;
1517                 if (s < m)
1518                     s = m;
1519             }
1520             else
1521                 s = m;
1522         }
1523         else if (!multiline) {
1524             if (*SvPVX(pm->op_pmshort) != *s
1525                 || (pm->op_pmslen > 1
1526                     && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
1527                 goto nope;
1528         }
1529         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
1530             SvREFCNT_dec(pm->op_pmshort);
1531             pm->op_pmshort = Nullsv;    /* opt is being useless */
1532         }
1533     }
1534
1535     /* only replace once? */
1536     once = !(rpm->op_pmflags & PMf_GLOBAL);
1537
1538     /* known replacement string? */
1539     c = dstr ? SvPV(dstr, clen) : Nullch;
1540
1541     /* can do inplace substitution? */
1542     if (c && clen <= rx->minlen && safebase) {
1543         if (! pregexec(rx, s, strend, orig, 0,
1544                        SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1545             PUSHs(&sv_no);
1546             LEAVE_SCOPE(oldsave);
1547             RETURN;
1548         }
1549         if (force_on_match) {
1550             force_on_match = 0;
1551             s = SvPV_force(TARG, len);
1552             goto force_it;
1553         }
1554         d = s;
1555         curpm = pm;
1556         SvSCREAM_off(TARG);     /* disable possible screamer */
1557         if (once) {
1558             rxtainted = rx->exec_tainted;
1559             m = rx->startp[0];
1560             d = rx->endp[0];
1561             s = orig;
1562             if (m - s > strend - d) {  /* faster to shorten from end */
1563                 if (clen) {
1564                     Copy(c, m, clen, char);
1565                     m += clen;
1566                 }
1567                 i = strend - d;
1568                 if (i > 0) {
1569                     Move(d, m, i, char);
1570                     m += i;
1571                 }
1572                 *m = '\0';
1573                 SvCUR_set(TARG, m - s);
1574             }
1575             /*SUPPRESS 560*/
1576             else if (i = m - s) {       /* faster from front */
1577                 d -= clen;
1578                 m = d;
1579                 sv_chop(TARG, d-i);
1580                 s += i;
1581                 while (i--)
1582                     *--d = *--s;
1583                 if (clen)
1584                     Copy(c, m, clen, char);
1585             }
1586             else if (clen) {
1587                 d -= clen;
1588                 sv_chop(TARG, d);
1589                 Copy(c, d, clen, char);
1590             }
1591             else {
1592                 sv_chop(TARG, d);
1593             }
1594             TAINT_IF(rxtainted);
1595             PUSHs(&sv_yes);
1596         }
1597         else {
1598             rxtainted = 0;
1599             do {
1600                 if (iters++ > maxiters)
1601                     DIE("Substitution loop");
1602                 rxtainted |= rx->exec_tainted;
1603                 m = rx->startp[0];
1604                 /*SUPPRESS 560*/
1605                 if (i = m - s) {
1606                     if (s != d)
1607                         Move(s, d, i, char);
1608                     d += i;
1609                 }
1610                 if (clen) {
1611                     Copy(c, d, clen, char);
1612                     d += clen;
1613                 }
1614                 s = rx->endp[0];
1615             } while (pregexec(rx, s, strend, orig, s == m,
1616                               Nullsv, TRUE)); /* don't match same null twice */
1617             if (s != d) {
1618                 i = strend - s;
1619                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1620                 Move(s, d, i+1, char);          /* include the NUL */
1621             }
1622             TAINT_IF(rxtainted);
1623             PUSHs(sv_2mortal(newSViv((I32)iters)));
1624         }
1625         (void)SvPOK_only(TARG);
1626         SvSETMAGIC(TARG);
1627         SvTAINT(TARG);
1628         LEAVE_SCOPE(oldsave);
1629         RETURN;
1630     }
1631
1632     if (pregexec(rx, s, strend, orig, 0,
1633                  SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1634         if (force_on_match) {
1635             force_on_match = 0;
1636             s = SvPV_force(TARG, len);
1637             goto force_it;
1638         }
1639         rxtainted = rx->exec_tainted;
1640         dstr = NEWSV(25, sv_len(TARG));
1641         sv_setpvn(dstr, m, s-m);
1642         curpm = pm;
1643         if (!c) {
1644             register CONTEXT *cx;
1645             PUSHSUBST(cx);
1646             RETURNOP(cPMOP->op_pmreplroot);
1647         }
1648         do {
1649             if (iters++ > maxiters)
1650                 DIE("Substitution loop");
1651             rxtainted |= rx->exec_tainted;
1652             if (rx->subbase && rx->subbase != orig) {
1653                 m = s;
1654                 s = orig;
1655                 orig = rx->subbase;
1656                 s = orig + (m - s);
1657                 strend = s + (strend - m);
1658             }
1659             m = rx->startp[0];
1660             sv_catpvn(dstr, s, m-s);
1661             s = rx->endp[0];
1662             if (clen)
1663                 sv_catpvn(dstr, c, clen);
1664             if (once)
1665                 break;
1666         } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase));
1667         sv_catpvn(dstr, s, strend - s);
1668
1669         TAINT_IF(rxtainted);
1670
1671         (void)SvOOK_off(TARG);
1672         Safefree(SvPVX(TARG));
1673         SvPVX(TARG) = SvPVX(dstr);
1674         SvCUR_set(TARG, SvCUR(dstr));
1675         SvLEN_set(TARG, SvLEN(dstr));
1676         SvPVX(dstr) = 0;
1677         sv_free(dstr);
1678
1679         (void)SvPOK_only(TARG);
1680         SvSETMAGIC(TARG);
1681         SvTAINT(TARG);
1682         PUSHs(sv_2mortal(newSViv((I32)iters)));
1683         LEAVE_SCOPE(oldsave);
1684         RETURN;
1685     }
1686     goto ret_no;
1687
1688 nope:
1689     ++BmUSEFUL(pm->op_pmshort);
1690
1691 ret_no:
1692     PUSHs(&sv_no);
1693     LEAVE_SCOPE(oldsave);
1694     RETURN;
1695 }
1696
1697 PP(pp_grepwhile)
1698 {
1699     dSP;
1700
1701     if (SvTRUEx(POPs))
1702         stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
1703     ++*markstack_ptr;
1704     LEAVE;                                      /* exit inner scope */
1705
1706     /* All done yet? */
1707     if (stack_base + *markstack_ptr > sp) {
1708         I32 items;
1709         I32 gimme = GIMME_V;
1710
1711         LEAVE;                                  /* exit outer scope */
1712         (void)POPMARK;                          /* pop src */
1713         items = --*markstack_ptr - markstack_ptr[-1];
1714         (void)POPMARK;                          /* pop dst */
1715         SP = stack_base + POPMARK;              /* pop original mark */
1716         if (gimme == G_SCALAR) {
1717             dTARGET;
1718             XPUSHi(items);
1719         }
1720         else if (gimme == G_ARRAY)
1721             SP += items;
1722         RETURN;
1723     }
1724     else {
1725         SV *src;
1726
1727         ENTER;                                  /* enter inner scope */
1728         SAVESPTR(curpm);
1729
1730         src = stack_base[*markstack_ptr];
1731         SvTEMP_off(src);
1732         GvSV(defgv) = src;
1733
1734         RETURNOP(cLOGOP->op_other);
1735     }
1736 }
1737
1738 PP(pp_leavesub)
1739 {
1740     dSP;
1741     SV **mark;
1742     SV **newsp;
1743     PMOP *newpm;
1744     I32 gimme;
1745     register CONTEXT *cx;
1746     struct block_sub cxsub;
1747
1748     POPBLOCK(cx,newpm);
1749     POPSUB1(cx);        /* Delay POPSUB2 until stack values are safe */
1750
1751     TAINT_NOT;
1752     if (gimme == G_SCALAR) {
1753         MARK = newsp + 1;
1754         if (MARK <= SP)
1755             *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
1756         else {
1757             MEXTEND(MARK, 0);
1758             *MARK = &sv_undef;
1759         }
1760         SP = MARK;
1761     }
1762     else if (gimme == G_ARRAY) {
1763         for (MARK = newsp + 1; MARK <= SP; MARK++) {
1764             if (!SvTEMP(*MARK)) {
1765                 *MARK = sv_mortalcopy(*MARK);
1766                 TAINT_NOT;      /* Each item is independent */
1767             }
1768         }
1769     }
1770     PUTBACK;
1771
1772     POPSUB2();          /* Stack values are safe: release CV and @_ ... */
1773     curpm = newpm;      /* ... and pop $1 et al */
1774
1775     LEAVE;
1776     return pop_return();
1777 }
1778
1779 PP(pp_entersub)
1780 {
1781     dSP; dPOPss;
1782     GV *gv;
1783     HV *stash;
1784     register CV *cv;
1785     register CONTEXT *cx;
1786     I32 gimme;
1787     bool hasargs = (op->op_flags & OPf_STACKED) != 0;
1788
1789     if (!sv)
1790         DIE("Not a CODE reference");
1791     switch (SvTYPE(sv)) {
1792     default:
1793         if (!SvROK(sv)) {
1794             char *sym;
1795
1796             if (sv == &sv_yes)          /* unfound import, ignore */
1797                 RETURN;
1798             if (SvGMAGICAL(sv)) {
1799                 mg_get(sv);
1800                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
1801             }
1802             else
1803                 sym = SvPV(sv, na);
1804             if (!sym)
1805                 DIE(no_usym, "a subroutine");
1806             if (op->op_private & HINT_STRICT_REFS)
1807                 DIE(no_symref, sym, "a subroutine");
1808             cv = perl_get_cv(sym, TRUE);
1809             break;
1810         }
1811         cv = (CV*)SvRV(sv);
1812         if (SvTYPE(cv) == SVt_PVCV)
1813             break;
1814         /* FALL THROUGH */
1815     case SVt_PVHV:
1816     case SVt_PVAV:
1817         DIE("Not a CODE reference");
1818     case SVt_PVCV:
1819         cv = (CV*)sv;
1820         break;
1821     case SVt_PVGV:
1822         if (!(cv = GvCVu((GV*)sv)))
1823             cv = sv_2cv(sv, &stash, &gv, TRUE);
1824         break;
1825     }
1826
1827     ENTER;
1828     SAVETMPS;
1829
1830   retry:
1831     if (!cv)
1832         DIE("Not a CODE reference");
1833
1834     if (!CvROOT(cv) && !CvXSUB(cv)) {
1835         GV* autogv;
1836         SV* subname;
1837
1838         /* anonymous or undef'd function leaves us no recourse */
1839         if (CvANON(cv) || !(gv = CvGV(cv)))
1840             DIE("Undefined subroutine called");
1841         /* autoloaded stub? */
1842         if (cv != GvCV(gv)) {
1843             cv = GvCV(gv);
1844             goto retry;
1845         }
1846         /* should call AUTOLOAD now? */
1847         if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1848                                    FALSE)))
1849         {
1850             cv = GvCV(autogv);
1851             goto retry;
1852         }
1853         /* sorry */
1854         subname = sv_newmortal();
1855         gv_efullname3(subname, gv, Nullch);
1856         DIE("Undefined subroutine &%s called", SvPVX(subname));
1857     }
1858
1859     gimme = GIMME_V;
1860     if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) {
1861         SV *oldsv = sv;
1862         sv = GvSV(DBsub);
1863         save_item(sv);
1864         gv = CvGV(cv);
1865         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1866              || strEQ(GvNAME(gv), "END")
1867              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
1868                  !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
1869                     && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */
1870             /* GV is potentially non-unique, or contain different CV. */
1871             sv_setsv(sv, newRV((SV*)cv));
1872         }
1873         else {
1874             gv_efullname3(sv, gv, Nullch);
1875         }
1876         cv = GvCV(DBsub);
1877         if (CvXSUB(cv)) curcopdb = curcop;
1878         if (!cv)
1879             DIE("No DBsub routine");
1880     }
1881
1882 #ifdef USE_THREADS
1883     MUTEX_LOCK(CvMUTEXP(cv));
1884     if (CvFLAGS(cv) & CVf_LOCKED) {
1885         MAGIC *mg;
1886         if (CvFLAGS(cv) & CVf_METHOD) {
1887             if (SP > stack_base + TOPMARK)
1888                 sv = *(stack_base + TOPMARK + 1);
1889             else {
1890                 MUTEX_UNLOCK(CvMUTEXP(cv));
1891                 croak("no argument for locked method call");
1892             }
1893             if (SvROK(sv))
1894                 sv = SvRV(sv);
1895         }
1896         else {
1897             sv = (SV*)cv;
1898         }
1899         MUTEX_UNLOCK(CvMUTEXP(cv));
1900         mg = condpair_magic(sv);
1901         MUTEX_LOCK(MgMUTEXP(mg));
1902         if (MgOWNER(mg) == thr)
1903             MUTEX_UNLOCK(MgMUTEXP(mg));
1904         else {
1905             while (MgOWNER(mg))
1906                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
1907             MgOWNER(mg) = thr;
1908             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1909                                   "0x%lx: pp_entersub lock 0x%lx\n",
1910                                   (unsigned long)thr, (unsigned long)sv);)
1911             MUTEX_UNLOCK(MgMUTEXP(mg));
1912             save_destructor(unlock_condpair, sv);
1913         }
1914         MUTEX_LOCK(CvMUTEXP(cv));
1915         assert(CvOWNER(cv) == 0);
1916         CvOWNER(cv) = thr;      /* Assert ownership */
1917         SvREFCNT_inc(cv);
1918         MUTEX_UNLOCK(CvMUTEXP(cv));
1919         if (CvDEPTH(cv) == 0)
1920             SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1921     }
1922     else {
1923         /*
1924          * It's an ordinary unsynchronised CV so we must distinguish
1925          * three cases. (1) It's ours already (and we're recursing);
1926          * (2) it's free (but we may already be using a cached clone);
1927          * (3) another thread owns it. Case (1) is easy: we just use it.
1928          * Case (2) means we look for a clone--if we have one, use it
1929          * otherwise grab ownership of cv. Case (3) means look we for a
1930          * clone and have to create one if we don't already have one.
1931          * Why look for a clone in case (2) when we could just grab
1932          * ownership of cv straight away? Well, we could be recursing,
1933          * i.e. we originally tried to enter cv while another thread
1934          * owned it (hence we used a clone) but it has been freed up
1935          * and we're now recursing into it. It may or may not be "better"
1936          * to use the clone but at least CvDEPTH can be trusted.
1937          */
1938         if (CvOWNER(cv) == thr)
1939             MUTEX_UNLOCK(CvMUTEXP(cv));
1940         else {
1941             /* Case (2) or (3) */
1942             SV **svp;
1943
1944             /*
1945              * XXX Might it be better to release CvMUTEXP(cv) while we
1946              * do the hv_fetch? We might find someone has pinched it
1947              * when we look again, in which case we would be in case
1948              * (3) instead of (2) so we'd have to clone. Would the fact
1949              * that we released the mutex more quickly make up for this?
1950              */
1951             svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
1952             if (svp) {
1953                 /* We already have a clone to use */
1954                 MUTEX_UNLOCK(CvMUTEXP(cv));
1955                 cv = *(CV**)svp;
1956                 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1957                                 "entersub: 0x%lx already has clone 0x%lx:%s\n",
1958                                 (unsigned long) thr, (unsigned long) cv,
1959                                 SvPEEK((SV*)cv)));
1960                 CvOWNER(cv) = thr;
1961                 SvREFCNT_inc(cv);
1962                 if (CvDEPTH(cv) == 0)
1963                     SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1964             }
1965             else {
1966                 /* (2) => grab ownership of cv. (3) => make clone */
1967                 if (!CvOWNER(cv)) {
1968                     CvOWNER(cv) = thr;
1969                     SvREFCNT_inc(cv);
1970                     MUTEX_UNLOCK(CvMUTEXP(cv));
1971                     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1972                                     "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n",
1973                                     (unsigned long) thr, (unsigned long) cv,
1974                                     SvPEEK((SV*)cv), CvSTASH(cv) ?
1975                                         HvNAME(CvSTASH(cv)) : "(none)"));
1976                 } else {
1977                     /* Make a new clone. */
1978                     CV *clonecv;
1979                     SvREFCNT_inc(cv); /* don't let it vanish from under us */
1980                     MUTEX_UNLOCK(CvMUTEXP(cv));
1981                     DEBUG_L((PerlIO_printf(PerlIO_stderr(),
1982                                      "entersub: 0x%lx cloning 0x%lx:%s\n",
1983                                      (unsigned long) thr, (unsigned long) cv,
1984                                      SvPEEK((SV*)cv))));
1985                     /*
1986                      * We're creating a new clone so there's no race
1987                      * between the original MUTEX_UNLOCK and the
1988                      * SvREFCNT_inc since no one will be trying to undef
1989                      * it out from underneath us. At least, I don't think
1990                      * there's a race...
1991                      */
1992                     clonecv = cv_clone(cv);
1993                     SvREFCNT_dec(cv); /* finished with this */
1994                     hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
1995                     CvOWNER(clonecv) = thr;
1996                     cv = clonecv;
1997                     SvREFCNT_inc(cv);
1998                 }
1999                 DEBUG_L(if (CvDEPTH(cv) != 0)
2000                             PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
2001                                           CvDEPTH(cv)););
2002                 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
2003             }
2004         }
2005     }
2006 #endif /* USE_THREADS */
2007
2008     gimme = GIMME;
2009
2010     if (CvXSUB(cv)) {
2011         if (CvOLDSTYLE(cv)) {
2012             I32 (*fp3)_((int,int,int));
2013             dMARK;
2014             register I32 items = SP - MARK;
2015                                         /* We dont worry to copy from @_. */
2016             while (sp > mark) {
2017                 sp[1] = sp[0];
2018                 sp--;
2019             }
2020             stack_sp = mark + 1;
2021             fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2022             items = (*fp3)(CvXSUBANY(cv).any_i32,
2023                            MARK - stack_base + 1,
2024                            items);
2025             stack_sp = stack_base + items;
2026         }
2027         else {
2028             I32 markix = TOPMARK;
2029
2030             PUTBACK;
2031
2032             if (!hasargs) {
2033                 /* Need to copy @_ to stack. Alternative may be to
2034                  * switch stack to @_, and copy return values
2035                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2036                 AV* av;
2037                 I32 items;
2038 #ifdef USE_THREADS
2039                 av = (AV*)curpad[0];
2040 #else
2041                 av = GvAV(defgv);
2042 #endif /* USE_THREADS */
2043                 items = AvFILL(av) + 1;
2044
2045                 if (items) {
2046                     /* Mark is at the end of the stack. */
2047                     EXTEND(sp, items);
2048                     Copy(AvARRAY(av), sp + 1, items, SV*);
2049                     sp += items;
2050                     PUTBACK ;
2051                 }
2052             }
2053             if (curcopdb) {             /* We assume that the first
2054                                            XSUB in &DB::sub is the
2055                                            called one. */
2056                 SAVESPTR(curcop);
2057                 curcop = curcopdb;
2058                 curcopdb = NULL;
2059             }
2060             /* Do we need to open block here? XXXX */
2061             (void)(*CvXSUB(cv))(cv);
2062
2063             /* Enforce some sanity in scalar context. */
2064             if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
2065                 if (markix > stack_sp - stack_base)
2066                     *(stack_base + markix) = &sv_undef;
2067                 else
2068                     *(stack_base + markix) = *stack_sp;
2069                 stack_sp = stack_base + markix;
2070             }
2071         }
2072         LEAVE;
2073         return NORMAL;
2074     }
2075     else {
2076         dMARK;
2077         register I32 items = SP - MARK;
2078         AV* padlist = CvPADLIST(cv);
2079         SV** svp = AvARRAY(padlist);
2080         push_return(op->op_next);
2081         PUSHBLOCK(cx, CXt_SUB, MARK);
2082         PUSHSUB(cx);
2083         CvDEPTH(cv)++;
2084         if (CvDEPTH(cv) < 2)
2085             (void)SvREFCNT_inc(cv);
2086         else {  /* save temporaries on recursion? */
2087             if (CvDEPTH(cv) == 100 && dowarn
2088                   && !(perldb && cv == GvCV(DBsub)))
2089                 sub_crush_depth(cv);
2090             if (CvDEPTH(cv) > AvFILL(padlist)) {
2091                 AV *av;
2092                 AV *newpad = newAV();
2093                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2094                 I32 ix = AvFILL((AV*)svp[1]);
2095                 svp = AvARRAY(svp[0]);
2096                 for ( ;ix > 0; ix--) {
2097                     if (svp[ix] != &sv_undef) {
2098                         char *name = SvPVX(svp[ix]);
2099                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2100                             || *name == '&')              /* anonymous code? */
2101                         {
2102                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2103                         }
2104                         else {                          /* our own lexical */
2105                             if (*name == '@')
2106                                 av_store(newpad, ix, sv = (SV*)newAV());
2107                             else if (*name == '%')
2108                                 av_store(newpad, ix, sv = (SV*)newHV());
2109                             else
2110                                 av_store(newpad, ix, sv = NEWSV(0,0));
2111                             SvPADMY_on(sv);
2112                         }
2113                     }
2114                     else {
2115                         av_store(newpad, ix, sv = NEWSV(0,0));
2116                         SvPADTMP_on(sv);
2117                     }
2118                 }
2119                 av = newAV();           /* will be @_ */
2120                 av_extend(av, 0);
2121                 av_store(newpad, 0, (SV*)av);
2122                 AvFLAGS(av) = AVf_REIFY;
2123                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2124                 AvFILL(padlist) = CvDEPTH(cv);
2125                 svp = AvARRAY(padlist);
2126             }
2127         }
2128 #ifdef USE_THREADS
2129         if (!hasargs) {
2130             AV* av = (AV*)curpad[0];
2131
2132             items = AvFILL(av) + 1;
2133             if (items) {
2134                 /* Mark is at the end of the stack. */
2135                 EXTEND(sp, items);
2136                 Copy(AvARRAY(av), sp + 1, items, SV*);
2137                 sp += items;
2138                 PUTBACK ;
2139             }
2140         }
2141 #endif /* USE_THREADS */
2142         SAVESPTR(curpad);
2143         curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2144 #ifndef USE_THREADS
2145         if (hasargs)
2146 #endif /* USE_THREADS */
2147         {
2148             AV* av;
2149             SV** ary;
2150
2151 #if 0
2152             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
2153                                   "%p entersub preparing @_\n", thr));
2154 #endif
2155             av = (AV*)curpad[0];
2156             if (AvREAL(av)) {
2157                 av_clear(av);
2158                 AvREAL_off(av);
2159             }
2160 #ifndef USE_THREADS
2161             cx->blk_sub.savearray = GvAV(defgv);
2162             GvAV(defgv) = (AV*)SvREFCNT_inc(av);
2163 #endif /* USE_THREADS */
2164             cx->blk_sub.argarray = av;
2165             ++MARK;
2166
2167             if (items > AvMAX(av) + 1) {
2168                 ary = AvALLOC(av);
2169                 if (AvARRAY(av) != ary) {
2170                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2171                     SvPVX(av) = (char*)ary;
2172                 }
2173                 if (items > AvMAX(av) + 1) {
2174                     AvMAX(av) = items - 1;
2175                     Renew(ary,items,SV*);
2176                     AvALLOC(av) = ary;
2177                     SvPVX(av) = (char*)ary;
2178                 }
2179             }
2180             Copy(MARK,AvARRAY(av),items,SV*);
2181             AvFILL(av) = items - 1;
2182
2183             while (items--) {
2184                 if (*MARK)
2185                     SvTEMP_off(*MARK);
2186                 MARK++;
2187             }
2188         }
2189 #if 0
2190         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
2191                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2192 #endif
2193         RETURNOP(CvSTART(cv));
2194     }
2195 }
2196
2197 void
2198 sub_crush_depth(cv)
2199 CV* cv;
2200 {
2201     if (CvANON(cv))
2202         warn("Deep recursion on anonymous subroutine");
2203     else {
2204         SV* tmpstr = sv_newmortal();
2205         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2206         warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
2207     }
2208 }
2209
2210 PP(pp_aelem)
2211 {
2212     dSP;
2213     SV** svp;
2214     I32 elem = POPi;
2215     AV* av = (AV*)POPs;
2216     U32 lval = op->op_flags & OPf_MOD;
2217     U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2218
2219     if (elem > 0)
2220         elem -= curcop->cop_arybase;
2221     if (SvTYPE(av) != SVt_PVAV)
2222         RETPUSHUNDEF;
2223     svp = av_fetch(av, elem, lval && !defer);
2224     if (lval) {
2225         if (!svp || *svp == &sv_undef) {
2226             SV* lv;
2227             if (!defer)
2228                 DIE(no_aelem, elem);
2229             lv = sv_newmortal();
2230             sv_upgrade(lv, SVt_PVLV);
2231             LvTYPE(lv) = 'y';
2232             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2233             LvTARG(lv) = SvREFCNT_inc(av);
2234             LvTARGOFF(lv) = elem;
2235             LvTARGLEN(lv) = 1;
2236             PUSHs(lv);
2237             RETURN;
2238         }
2239         if (op->op_private & OPpLVAL_INTRO)
2240             save_svref(svp);
2241         else if (op->op_private & OPpDEREF)
2242             vivify_ref(*svp, op->op_private & OPpDEREF);
2243     }
2244     PUSHs(svp ? *svp : &sv_undef);
2245     RETURN;
2246 }
2247
2248 void
2249 vivify_ref(sv, to_what)
2250 SV* sv;
2251 U32 to_what;
2252 {
2253     if (SvGMAGICAL(sv))
2254         mg_get(sv);
2255     if (!SvOK(sv)) {
2256         if (SvREADONLY(sv))
2257             croak(no_modify);
2258         if (SvTYPE(sv) < SVt_RV)
2259             sv_upgrade(sv, SVt_RV);
2260         else if (SvTYPE(sv) >= SVt_PV) {
2261             (void)SvOOK_off(sv);
2262             Safefree(SvPVX(sv));
2263             SvLEN(sv) = SvCUR(sv) = 0;
2264         }
2265         switch (to_what) {
2266         case OPpDEREF_SV:
2267             SvRV(sv) = newSV(0);
2268             break;
2269         case OPpDEREF_AV:
2270             SvRV(sv) = (SV*)newAV();
2271             break;
2272         case OPpDEREF_HV:
2273             SvRV(sv) = (SV*)newHV();
2274             break;
2275         }
2276         SvROK_on(sv);
2277         SvSETMAGIC(sv);
2278     }
2279 }
2280
2281 PP(pp_method)
2282 {
2283     dSP;
2284     SV* sv;
2285     SV* ob;
2286     GV* gv;
2287     HV* stash;
2288     char* name;
2289     char* packname;
2290     STRLEN packlen;
2291
2292     name = SvPV(TOPs, na);
2293     sv = *(stack_base + TOPMARK + 1);
2294
2295     if (SvGMAGICAL(sv))
2296         mg_get(sv);
2297     if (SvROK(sv))
2298         ob = (SV*)SvRV(sv);
2299     else {
2300         GV* iogv;
2301
2302         packname = Nullch;
2303         if (!SvOK(sv) ||
2304             !(packname = SvPV(sv, packlen)) ||
2305             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2306             !(ob=(SV*)GvIO(iogv)))
2307         {
2308             if (!packname || !isIDFIRST(*packname))
2309   DIE("Can't call method \"%s\" without a package or object reference", name);
2310             stash = gv_stashpvn(packname, packlen, TRUE);
2311             goto fetch;
2312         }
2313         *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2314     }
2315
2316     if (!ob || !SvOBJECT(ob))
2317         DIE("Can't call method \"%s\" on unblessed reference", name);
2318
2319     stash = SvSTASH(ob);
2320
2321   fetch:
2322     gv = gv_fetchmethod(stash, name);
2323     if (!gv) {
2324         char* leaf = name;
2325         char* sep = Nullch;
2326         char* p;
2327
2328         for (p = name; *p; p++) {
2329             if (*p == '\'')
2330                 sep = p, leaf = p + 1;
2331             else if (*p == ':' && *(p + 1) == ':')
2332                 sep = p, leaf = p + 2;
2333         }
2334         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2335             packname = HvNAME(sep ? curcop->cop_stash : stash);
2336             packlen = strlen(packname);
2337         }
2338         else {
2339             packname = name;
2340             packlen = sep - name;
2341         }
2342         DIE("Can't locate object method \"%s\" via package \"%.*s\"",
2343             leaf, (int)packlen, packname);
2344     }
2345     SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
2346     RETURN;
2347 }