pp_hot.c

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