X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=98763b8b97588552ce5a0b41bb958f3137cedee3;hb=02d96c6bd98c3f4ff97ac30a1c08e75df907d694;hp=1d8ef684ce582e96efe508056c75017a0ff8bd95;hpb=c6ed36e16dcdd4c25349e4f9d5c84061095ccffb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 1d8ef68..98763b8 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -21,6 +21,14 @@ #ifdef I_UNISTD #include #endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + +#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) /* Hot code. */ @@ -33,10 +41,10 @@ unset_cvowner(void *cvarg) dTHR; #endif /* DEBUGGING */ - DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); MUTEX_LOCK(CvMUTEXP(cv)); - DEBUG_L(if (CvDEPTH(cv) != 0) + DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", CvDEPTH(cv));); assert(thr == CvOWNER(cv)); @@ -55,9 +63,9 @@ PP(pp_const) PP(pp_nextstate) { - curcop = (COP*)op; + PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; return NORMAL; } @@ -66,7 +74,7 @@ PP(pp_gvsv) { djSP; EXTEND(SP,1); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP->op_gv)); else PUSHs(GvSV(cGVOP->op_gv)); @@ -80,7 +88,7 @@ PP(pp_null) PP(pp_pushmark) { - PUSHMARK(stack_sp); + PUSHMARK(PL_stack_sp); return NORMAL; } @@ -118,11 +126,11 @@ PP(pp_sassign) djSP; dPOPTOPssrl; MAGIC *mg; - if (op->op_private & OPpASSIGN_BACKWARDS) { + if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; temp = left; left = right; right = temp; } - if (tainting && tainted && !SvTAINTED(left)) + if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; SvSetMagicSV(right, left); SETs(right); @@ -142,9 +150,9 @@ PP(pp_unstack) { I32 oldsave; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); return NORMAL; } @@ -180,12 +188,12 @@ PP(pp_padsv) { djSP; dTARGET; XPUSHs(TARG); - if (op->op_flags & OPf_MOD) { - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(curpad[op->op_targ]); - else if (op->op_private & OPpDEREF) { + if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(PL_curpad[PL_op->op_targ]); + else if (PL_op->op_private & OPpDEREF) { PUTBACK; - vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); + vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF); SPAGAIN; } } @@ -194,7 +202,23 @@ PP(pp_padsv) PP(pp_readline) { - last_in_gv = (GV*)(*stack_sp--); + tryAMAGICunTARGET(iter, 0); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */ + if (SvROK(PL_last_in_gv)) { + if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV) + goto hard_way; + PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); + } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + hard_way: { + dSP; + XPUSHs((SV*)PL_last_in_gv); + PUTBACK; + pp_rv2gv(ARGS); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + } + } + } return do_readline(); } @@ -212,7 +236,7 @@ PP(pp_preinc) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); + croak(PL_no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { @@ -250,8 +274,13 @@ PP(pp_aelemfast) { djSP; AV *av = GvAV((GV*)cSVOP->op_sv); - SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); - PUSHs(svp ? *svp : &sv_undef); + U32 lval = PL_op->op_flags & OPf_MOD; + SV** svp = av_fetch(av, PL_op->op_private, lval); + SV *sv = (svp ? *svp : &PL_sv_undef); + EXTEND(SP, 1); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -276,10 +305,10 @@ PP(pp_pushre) SV* sv = sv_newmortal(); sv_upgrade(sv, SVt_PVLV); LvTYPE(sv) = '/'; - Copy(&op, &LvTARGOFF(sv), 1, OP*); + Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); XPUSHs(sv); #else - XPUSHs((SV*)op); + XPUSHs((SV*)PL_op); #endif RETURN; } @@ -293,12 +322,13 @@ PP(pp_print) IO *io; register PerlIO *fp; MAGIC *mg; + STRLEN n_a; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else - gv = defoutgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + gv = PL_defoutgv; + if (mg = SvTIED_mg((SV*)gv, 'q')) { if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -309,7 +339,7 @@ PP(pp_print) ++SP; } PUSHMARK(MARK - 1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; perl_call_method("PRINT", G_SCALAR); @@ -321,36 +351,38 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (dowarn) { + if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - warn("Filehandle %s never opened", SvPV(sv,na)); + warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (dowarn) { + if (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) - warn("Filehandle %s opened only for input", SvPV(sv,na)); - else - warn("print on closed filehandle %s", SvPV(sv,na)); + warner(WARN_IO, "Filehandle %s opened only for input", + SvPV(sv,n_a)); + else if (ckWARN(WARN_CLOSED)) + warner(WARN_CLOSED, "print on closed filehandle %s", + SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; } else { MARK++; - if (ofslen) { + if (PL_ofslen) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) { + if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { MARK--; break; } @@ -367,8 +399,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (orslen) - if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp)) + if (PL_orslen) + if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -377,35 +409,37 @@ PP(pp_print) } } SP = ORIGMARK; - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); RETURN; just_say_no: SP = ORIGMARK; - PUSHs(&sv_undef); + PUSHs(&PL_sv_undef); RETURN; } PP(pp_rv2av) { - djSP; dPOPss; + djSP; dTOPss; AV *av; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_av); + av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) DIE("Not an ARRAY reference"); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } else { if (SvTYPE(sv) == SVt_PVAV) { av = (AV*)sv; - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -414,6 +448,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -421,27 +456,29 @@ PP(pp_rv2av) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "an ARRAY"); - if (dowarn) - warn(warn_uninit); - if (GIMME == G_ARRAY) + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_usym, "an ARRAY"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); + if (GIMME == G_ARRAY) { + (void)POPs; RETURN; - RETPUSHUNDEF; + } + RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "an ARRAY"); + sym = SvPV(sv,n_a); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_symref, sym, "an ARRAY"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); } else { gv = (GV*)sv; } av = GvAVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) av = save_ary(gv); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -449,12 +486,13 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; + (void)POPs; /* XXXX May be optimized away? */ EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); - SP[i+1] = (svp) ? *svp : &sv_undef; + SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { @@ -465,7 +503,7 @@ PP(pp_rv2av) else { dTARGET; I32 maxarg = AvFILL(av) + 1; - PUSHi(maxarg); + SETi(maxarg); } RETURN; } @@ -477,10 +515,12 @@ PP(pp_rv2hv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_hv); + hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) DIE("Not a HASH reference"); - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -488,7 +528,7 @@ PP(pp_rv2hv) else { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { hv = (HV*)sv; - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -498,6 +538,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -505,28 +546,28 @@ PP(pp_rv2hv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a HASH"); - if (dowarn) - warn(warn_uninit); + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_usym, "a HASH"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a HASH"); + sym = SvPV(sv,n_a); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_symref, sym, "a HASH"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); } else { gv = (GV*)sv; } hv = GvHVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) hv = save_hash(gv); - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -534,12 +575,13 @@ PP(pp_rv2hv) } if (GIMME == G_ARRAY) { /* array wanted */ - *stack_sp = (SV*)hv; + *PL_stack_sp = (SV*)hv; return do_kv(ARGS); } else { dTARGET; - /* This bit is OK even when hv is really an AV */ + if (SvTYPE(hv) == SVt_PVAV) + hv = avhv_keys((AV*)hv); if (HvFILL(hv)) sv_setpvf(TARG, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); @@ -554,9 +596,9 @@ PP(pp_rv2hv) PP(pp_aassign) { djSP; - SV **lastlelem = stack_sp; - SV **lastrelem = stack_base + POPMARK; - SV **firstrelem = stack_base + POPMARK + 1; + SV **lastlelem = PL_stack_sp; + SV **lastrelem = PL_stack_base + POPMARK; + SV **firstrelem = PL_stack_base + POPMARK + 1; SV **firstlelem = lastrelem + 1; register SV **relem; @@ -570,13 +612,14 @@ PP(pp_aassign) I32 i; int magic; - delaymagic = DM_DELAY; /* catch simultaneous items */ + PL_delaymagic = DM_DELAY; /* catch simultaneous items */ /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (op->op_private & OPpASSIGN_COMMON) { + if (PL_op->op_private & OPpASSIGN_COMMON) { + EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { /*SUPPRESS 560*/ if (sv = *relem) { @@ -625,12 +668,11 @@ PP(pp_aassign) hv_clear(hash); while (relem < lastrelem) { /* gobble up all the rest */ - STRLEN len; HE *didstore; if (*relem) sv = *(relem++); else - sv = &sv_no, relem++; + sv = &PL_sv_no, relem++; tmpstr = NEWSV(29,0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ @@ -644,15 +686,37 @@ PP(pp_aassign) } TAINT_NOT; } - if (relem == lastrelem && dowarn) - warn("Odd number of elements in hash list"); + if (relem == lastrelem) { + if (*relem) { + HE *didstore; + if (ckWARN(WARN_UNSAFE)) { + if (relem == firstrelem && + SvROK(*relem) && + ( SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) + warner(WARN_UNSAFE, "Reference found where even-sized list expected"); + else + warner(WARN_UNSAFE, "Odd number of elements in hash assignment"); + } + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (magic) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + SvREFCNT_dec(tmpstr); + } + TAINT_NOT; + } + relem++; + } } break; default: if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) { - if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no) - DIE(no_modify); + if (SvREADONLY(sv) && PL_curcop != &PL_compiling) { + if (!SvIMMORTAL(sv)) + DIE(PL_no_modify); if (relem <= lastrelem) relem++; break; @@ -665,73 +729,73 @@ PP(pp_aassign) *(relem++) = sv; } else - sv_setsv(sv, &sv_undef); + sv_setsv(sv, &PL_sv_undef); SvSETMAGIC(sv); break; } } - if (delaymagic & ~DM_DELAY) { - if (delaymagic & DM_UID) { + if (PL_delaymagic & ~DM_DELAY) { + if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid(uid,euid,(Uid_t)-1); + (void)setresuid(PL_uid,PL_euid,(Uid_t)-1); #else # ifdef HAS_SETREUID - (void)setreuid(uid,euid); + (void)setreuid(PL_uid,PL_euid); # else # ifdef HAS_SETRUID - if ((delaymagic & DM_UID) == DM_RUID) { - (void)setruid(uid); - delaymagic &= ~DM_RUID; + if ((PL_delaymagic & DM_UID) == DM_RUID) { + (void)setruid(PL_uid); + PL_delaymagic &= ~DM_RUID; } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID - if ((delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(uid); - delaymagic &= ~DM_EUID; + if ((PL_delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(PL_uid); + PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ - if (delaymagic & DM_UID) { - if (uid != euid) + if (PL_delaymagic & DM_UID) { + if (PL_uid != PL_euid) DIE("No setreuid available"); - (void)setuid(uid); + (void)PerlProc_setuid(PL_uid); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ - uid = (int)getuid(); - euid = (int)geteuid(); + PL_uid = (int)PerlProc_getuid(); + PL_euid = (int)PerlProc_geteuid(); } - if (delaymagic & DM_GID) { + if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid(gid,egid,(Gid_t)-1); + (void)setresgid(PL_gid,PL_egid,(Gid_t)-1); #else # ifdef HAS_SETREGID - (void)setregid(gid,egid); + (void)setregid(PL_gid,PL_egid); # else # ifdef HAS_SETRGID - if ((delaymagic & DM_GID) == DM_RGID) { - (void)setrgid(gid); - delaymagic &= ~DM_RGID; + if ((PL_delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(PL_gid); + PL_delaymagic &= ~DM_RGID; } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID - if ((delaymagic & DM_GID) == DM_EGID) { - (void)setegid(gid); - delaymagic &= ~DM_EGID; + if ((PL_delaymagic & DM_GID) == DM_EGID) { + (void)setegid(PL_gid); + PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ - if (delaymagic & DM_GID) { - if (gid != egid) + if (PL_delaymagic & DM_GID) { + if (PL_gid != PL_egid) DIE("No setregid available"); - (void)setgid(gid); + (void)PerlProc_setgid(PL_gid); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ - gid = (int)getgid(); - egid = (int)getegid(); + PL_gid = (int)PerlProc_getgid(); + PL_egid = (int)PerlProc_getegid(); } - tainting |= (uid && (euid != uid || egid != gid)); + PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } - delaymagic = 0; + PL_delaymagic = 0; gimme = GIMME_V; if (gimme == G_VOID) @@ -748,11 +812,21 @@ PP(pp_aassign) SP = firstrelem + (lastlelem - firstlelem); lelem = firstlelem + (relem - firstrelem); while (relem <= SP) - *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef; + *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } RETURN; } +PP(pp_qr) +{ + djSP; + register PMOP *pm = cPMOP; + SV *rv = sv_newmortal(); + SV *sv = newSVrv(rv, "Regexp"); + sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); + RETURNX(PUSHs(rv)); +} + PP(pp_match) { djSP; dTARG; @@ -761,17 +835,18 @@ PP(pp_match) register char *s; char *strend; I32 global; - I32 safebase; + I32 r_flags; char *truebase; register REGEXP *rx = pm->op_pmregexp; + bool rxtainted; I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; I32 update_minmatch = 1; - SV *screamer; + I32 had_zerolen = 0; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = DEFSV; @@ -782,45 +857,49 @@ PP(pp_match) strend = s + len; if (!s) DIE("panic: do_match"); + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; } - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } if (rx->minlen > len) goto failure; - screamer = ( (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) - ? TARG : Nullsv); truebase = t = s; + + /* XXXX What part of this is needed with true \G-support? */ if (global = pm->op_pmflags & PMf_GLOBAL) { rx->startp[0] = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg && mg->mg_len >= 0) { - rx->endp[0] = rx->startp[0] = s + mg->mg_len; + if (!(rx->reganch & ROPT_GPOS_SEEN)) + rx->endp[0] = rx->startp[0] = s + mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; } } } - if (!rx->nparens && !global) - gimme = G_SCALAR; /* accidental array context? */ - safebase = (((gimme == G_ARRAY) || global || !rx->nparens) - && !sawampersand); - safebase = safebase ? 0 : REXEC_COPY_STR ; + r_flags = ((gimme != G_ARRAY && !global && rx->nparens) + || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; + if (SvSCREAM(TARG) && rx->check_substr + && SvTYPE(rx->check_substr) == SVt_PVBM + && SvVALID(rx->check_substr)) + r_flags |= REXEC_SCREAM; + if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } play_it_again: @@ -829,58 +908,60 @@ play_it_again: if ((s + rx->minlen) > strend) goto nope; if (update_minmatch++) - minmatch = (s == rx->startp[0]); + minmatch = had_zerolen; } if (rx->check_substr) { if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */ - if ( screamer ) { + if (r_flags & REXEC_SCREAM) { I32 p = -1; + char *b; - if (screamfirst[BmRARE(rx->check_substr)] < 0) + if (PL_screamfirst[BmRARE(rx->check_substr)] < 0) goto nope; - else if (!(s = screaminstr(TARG, rx->check_substr, - rx->check_offset_min, 0, &p, 0))) + + b = (char*)HOP((U8*)s, rx->check_offset_min); + if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0))) goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) - && !sawampersand && !SvTAIL(rx->check_substr)) + + if ((rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand && !SvTAIL(rx->check_substr)) goto yup; } - else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, + else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), (unsigned char*)strend, - rx->check_substr))) + rx->check_substr, 0))) goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) && !sawampersand) + else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand) goto yup; - if (s && rx->check_offset_max < t - s) { + if (s && rx->check_offset_max < s - t) { ++BmUSEFUL(rx->check_substr); - s -= rx->check_offset_max; + s = (char*)HOP((U8*)s, -rx->check_offset_max); } else s = t; } /* Now checkstring is fixed, i.e. at fixed offset from the beginning of match, and the match is anchored at s. */ - else if (!multiline) { /* Anchored near beginning of string. */ + else if (!PL_multiline) { /* Anchored near beginning of string. */ I32 slen; - if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] + char *b = (char*)HOP((U8*)s, rx->check_offset_min); + if (*SvPVX(rx->check_substr) != *b || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), - s + rx->check_offset_min, slen))) + && memNE(SvPVX(rx->check_substr), b, slen))) goto nope; } - if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0 + if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0 && rx->check_substr == rx->float_substr) { SvREFCNT_dec(rx->check_substr); rx->check_substr = Nullsv; /* opt is being useless */ rx->float_substr = Nullsv; } } - if (regexec_flags(rx, s, strend, truebase, minmatch, - screamer, NULL, safebase)) + if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { - curpm = pm; + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -888,6 +969,8 @@ play_it_again: /*NOTREACHED*/ gotcha: + if (rxtainted) + RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; @@ -911,11 +994,13 @@ play_it_again: if (global) { truebase = rx->subbeg; strend = rx->subend; - if (rx->startp[0] && rx->startp[0] == rx->endp[0]) - ++rx->endp[0]; + had_zerolen = (rx->startp[0] && rx->startp[0] == rx->endp[0]); PUTBACK; /* EVAL blocks may use stack */ + r_flags |= REXEC_IGNOREPOS; goto play_it_again; } + else if (!iters) + XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; } @@ -941,11 +1026,13 @@ play_it_again: } yup: /* Confirmed by check_substr */ + if (rxtainted) + RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); ++BmUSEFUL(rx->check_substr); - curpm = pm; + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; Safefree(rx->subbase); rx->subbase = Nullch; if (global) { @@ -955,7 +1042,7 @@ yup: /* Confirmed by check_substr */ rx->endp[0] = s + SvCUR(rx->check_substr); goto gotcha; } - if (sawampersand) { + if (PL_sawampersand) { char *tmps; tmps = rx->subbase = savepvn(t, strend-t); @@ -993,14 +1080,14 @@ do_readline(void) STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; - register IO *io = GvIO(last_in_gv); - register I32 type = op->op_type; + register IO *io = GvIO(PL_last_in_gv); + register I32 type = PL_op->op_type; I32 gimme = GIMME_V; MAGIC *mg; - if (SvRMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { + if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; ENTER; perl_call_method("READLINE", gimme); @@ -1018,14 +1105,17 @@ do_readline(void) if (IoFLAGS(io) & IOf_START) { IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; - if (av_len(GvAVn(last_in_gv)) < 0) { - SV *tmpstr = newSVpv("-", 1); /* assume stdin */ - av_push(GvAVn(last_in_gv), tmpstr); + if (av_len(GvAVn(PL_last_in_gv)) < 0) { + do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); + sv_setpvn(GvSV(PL_last_in_gv), "-", 1); + SvSETMAGIC(GvSV(PL_last_in_gv)); + fp = IoIFP(io); + goto have_fp; } } - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(last_in_gv, FALSE); /* now it does*/ + (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ IoFLAGS(io) |= IOf_START; } } @@ -1135,7 +1225,7 @@ do_readline(void) #endif /* !OS2 */ #else /* !DOSISH */ #if defined(CSH) - sv_setpvn(tmpcmd, cshname, cshlen); + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, "' 2>/dev/null |"); @@ -1149,8 +1239,8 @@ do_readline(void) #endif #endif /* !CSH */ #endif /* !DOSISH */ - (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, 0, 0, Nullfp); + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); #endif /* !VMS */ LEAVE; @@ -1160,14 +1250,16 @@ do_readline(void) SP--; } if (!fp) { - if (dowarn && io && !(IoFLAGS(io) & IOf_START)) - warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); + if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) + warner(WARN_CLOSED, + "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv)); if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } + have_fp: if (gimme == G_SCALAR) { sv = TARG; if (SvROK(sv)) @@ -1189,15 +1281,19 @@ do_readline(void) if (!sv_gets(sv, fp, offset)) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (fp) continue; - (void)do_close(last_in_gv, FALSE); + (void)do_close(PL_last_in_gv, FALSE); IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - if (do_close(last_in_gv, FALSE) & ~0xFF) - warn("internal error: glob failed"); + if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { + warner(WARN_CLOSED, + "glob failed (child exited with status %d%s)", + STATUS_CURRENT >> 8, + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1216,9 +1312,9 @@ do_readline(void) if (type == OP_GLOB) { char *tmps; - if (SvCUR(sv) > 0 && SvCUR(rs) > 0) { + if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX(rs)) { + if (*tmps == *SvPVX(PL_rs)) { *tmps = '\0'; SvCUR(sv)--; } @@ -1227,7 +1323,7 @@ do_readline(void) if (!isALPHA(*tmps) && !isDIGIT(*tmps) && strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) break; - if (*tmps && PerlLIO_stat(SvPVX(sv), &statbuf) < 0) { + if (*tmps && PerlLIO_stat(SvPVX(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -1256,7 +1352,7 @@ PP(pp_enter) { djSP; register PERL_CONTEXT *cx; - I32 gimme = OP_GIMME(op, -1); + I32 gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { if (cxstack_ix >= 0) @@ -1280,25 +1376,30 @@ PP(pp_helem) SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = op->op_flags & OPf_MOD; - U32 defer = op->op_private & OPpLVAL_DEFER; + U32 lval = PL_op->op_flags & OPf_MOD; + U32 defer = PL_op->op_private & OPpLVAL_DEFER; + SV *sv; if (SvTYPE(hv) == SVt_PVHV) { he = hv_fetch_ent(hv, keysv, lval && !defer, 0); svp = he ? &HeVAL(he) : 0; } else if (SvTYPE(hv) == SVt_PVAV) { + if (PL_op->op_private & OPpLVAL_INTRO) + DIE("Can't localize pseudo-hash element"); svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); } else { RETPUSHUNDEF; } if (lval) { - if (!svp || *svp == &sv_undef) { + if (!svp || *svp == &PL_sv_undef) { SV* lv; SV* key2; - if (!defer) - DIE(no_helem, SvPV(keysv, na)); + if (!defer) { + STRLEN n_a; + DIE(PL_no_helem, SvPV(keysv, n_a)); + } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -1309,16 +1410,25 @@ PP(pp_helem) PUSHs(lv); RETURN; } - if (op->op_private & OPpLVAL_INTRO) { + if (PL_op->op_private & OPpLVAL_INTRO) { if (HvNAME(hv) && isGV(*svp)) - save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL)); + save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); else save_helem(hv, keysv, svp); } - else if (op->op_private & OPpDEREF) - vivify_ref(*svp, op->op_private & OPpDEREF); - } - PUSHs(svp ? *svp : &sv_undef); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); + } + sv = (svp ? *svp : &PL_sv_undef); + /* This makes C possible. + * Pushing the magical RHS on to the stack is useless, since + * that magic is soon destined to be misled by the local(), + * and thus the later pp_sassign() will fail to mg_get() the + * old value. This should also cure problems with delayed + * mg_get()s. GSAR 98-07-03 */ + if (!lval && SvGMAGICAL(sv)) + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -1331,14 +1441,14 @@ PP(pp_leave) PMOP *newpm; I32 gimme; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = curpm; /* fake block should preserve $1 et al */ + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ } POPBLOCK(cx,newpm); - gimme = OP_GIMME(op, -1); + gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { if (cxstack_ix >= 0) gimme = cxstack[cxstack_ix].blk_gimme; @@ -1358,7 +1468,7 @@ PP(pp_leave) *MARK = sv_mortalcopy(TOPs); else { MEXTEND(mark,0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; } @@ -1371,7 +1481,7 @@ PP(pp_leave) } } } - curpm = newpm; /* Don't pop $1 et al till now */ + PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; @@ -1387,11 +1497,67 @@ PP(pp_iter) EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; - if (cx->cx_type != CXt_LOOP) + if (CxTYPE(cx) != CXt_LOOP) DIE("panic: pp_iter"); av = cx->blk_loop.iterary; - if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av))) + if (SvTYPE(av) != SVt_PVAV) { + /* iterate ($min .. $max) */ + if (cx->blk_loop.iterlval) { + /* string increment */ + register SV* cur = cx->blk_loop.iterlval; + STRLEN maxlen; + char *max = SvPV((SV*)av, maxlen); + if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { + /* safe to reuse old SV */ + sv_setsv(*cx->blk_loop.itervar, cur); + } + else +#endif + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as + * they used to */ + SvREFCNT_dec(*cx->blk_loop.itervar); + *cx->blk_loop.itervar = newSVsv(cur); + } + if (strEQ(SvPVX(cur), max)) + sv_setiv(cur, 0); /* terminate next time */ + else + sv_inc(cur); + RETPUSHYES; + } + RETPUSHNO; + } + /* integer increment */ + if (cx->blk_loop.iterix > cx->blk_loop.itermax) + RETPUSHNO; + +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { + /* safe to reuse old SV */ + sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); + } + else +#endif + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as they + * used to */ + SvREFCNT_dec(*cx->blk_loop.itervar); + *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++); + } + RETPUSHYES; + } + + /* iterate array */ + if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; SvREFCNT_dec(*cx->blk_loop.itervar); @@ -1401,8 +1567,8 @@ PP(pp_iter) : AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); else - sv = &sv_undef; - if (av != curstack && SvIMMORTAL(sv)) { + sv = &PL_sv_undef; + if (av != PL_curstack && SvIMMORTAL(sv)) { SV *lv = cx->blk_loop.iterlval; if (lv && SvREFCNT(lv) > 1) { SvREFCNT_dec(lv); @@ -1444,17 +1610,16 @@ PP(pp_subst) bool once; bool rxtainted; char *orig; - I32 safebase; + I32 r_flags; register REGEXP *rx = pm->op_pmregexp; STRLEN len; int force_on_match = 0; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; I32 update_minmatch = 1; - SV *screamer; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = DEFSV; @@ -1463,12 +1628,16 @@ PP(pp_subst) if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) - croak(no_modify); + croak(PL_no_modify); PUTBACK; s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + if (PL_tainted) + rxtainted |= 2; TAINT_NOT; force_it: @@ -1476,54 +1645,60 @@ PP(pp_subst) DIE("panic: do_subst"); strend = s + len; - maxiters = (strend - s) + 10; + maxiters = 2*(strend - s) + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } - screamer = ( (SvSCREAM(TARG) && rx->check_substr + r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; + if (SvSCREAM(TARG) && rx->check_substr && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) - ? TARG : Nullsv); - safebase = (!rx->nparens && !sawampersand) ? 0 : REXEC_COPY_STR; + && SvVALID(rx->check_substr)) + r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } orig = m = s; if (rx->check_substr) { if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */ - if (screamer) { + if (r_flags & REXEC_SCREAM) { I32 p = -1; + char *b; - if (screamfirst[BmRARE(rx->check_substr)] < 0) + if (PL_screamfirst[BmRARE(rx->check_substr)] < 0) goto nope; - else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0))) + + b = (char*)HOP((U8*)s, rx->check_offset_min); + if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0))) goto nope; } - else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, + else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), (unsigned char*)strend, - rx->check_substr))) + rx->check_substr, 0))) goto nope; if (s && rx->check_offset_max < s - m) { ++BmUSEFUL(rx->check_substr); - s -= rx->check_offset_max; + s = (char*)HOP((U8*)s, -rx->check_offset_max); } else s = m; } /* Now checkstring is fixed, i.e. at fixed offset from the beginning of match, and the match is anchored at s. */ - else if (!multiline) { /* Anchored at beginning of string. */ + else if (!PL_multiline) { /* Anchored at beginning of string. */ I32 slen; - if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] + char *b = (char*)HOP((U8*)s, rx->check_offset_min); + if (*SvPVX(rx->check_substr) != *b || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), - s + rx->check_offset_min, slen))) + && memNE(SvPVX(rx->check_substr), b, slen))) goto nope; } - if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0 + if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0 && rx->check_substr == rx->float_substr) { SvREFCNT_dec(rx->check_substr); rx->check_substr = Nullsv; /* opt is being useless */ @@ -1538,11 +1713,11 @@ PP(pp_subst) c = dstr ? SvPV(dstr, clen) : Nullch; /* can do inplace substitution? */ - if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR)) + if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { - if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) { SPAGAIN; - PUSHs(&sv_no); + PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } @@ -1552,10 +1727,10 @@ PP(pp_subst) goto force_it; } d = s; - curpm = pm; + PL_curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); if (rx->subbase) { m = orig + (rx->startp[0] - rx->subbase); d = orig + (rx->endp[0] - rx->subbase); @@ -1596,12 +1771,11 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); } else { - rxtainted = 0; do { if (iters++ > maxiters) DIE("Substitution loop"); @@ -1618,18 +1792,19 @@ PP(pp_subst) d += clen; } s = rx->endp[0]; - } while (regexec_flags(rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, 0)); /* don't match same null twice */ if (s != d) { i = strend - s; SvCUR_set(TARG, d - SvPVX(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; mg_set(TARG); @@ -1640,22 +1815,23 @@ PP(pp_subst) RETURN; } - if (regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); goto force_it; } - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); - curpm = pm; + PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; SPAGAIN; PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } + r_flags |= REXEC_IGNOREPOS; do { if (iters++ > maxiters) DIE("Substitution loop"); @@ -1674,11 +1850,9 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase)); + } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); - TAINT_IF(rxtainted); - (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); @@ -1687,11 +1861,14 @@ PP(pp_subst) SvPVX(dstr) = 0; sv_free(dstr); + TAINT_IF(rxtainted & 1); + SPAGAIN; + PUSHs(sv_2mortal(newSViv((I32)iters))); + (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); - SPAGAIN; - PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; } @@ -1702,7 +1879,7 @@ nope: ret_no: SPAGAIN; - PUSHs(&sv_no); + PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } @@ -1712,20 +1889,20 @@ PP(pp_grepwhile) djSP; if (SvTRUEx(POPs)) - stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; - ++*markstack_ptr; + PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; + ++*PL_markstack_ptr; LEAVE; /* exit inner scope */ /* All done yet? */ - if (stack_base + *markstack_ptr > SP) { + if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ - items = --*markstack_ptr - markstack_ptr[-1]; + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ - SP = stack_base + POPMARK; /* pop original mark */ + SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); @@ -1738,9 +1915,9 @@ PP(pp_grepwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(curpm); + SAVESPTR(PL_curpm); - src = stack_base[*markstack_ptr]; + src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); DEFSV = src; @@ -1764,11 +1941,21 @@ PP(pp_leavesub) TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; - if (MARK <= SP) - *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); - else { + if (MARK <= SP) { + if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) { + if (SvTEMP(TOPs)) { + *MARK = SvREFCNT_inc(TOPs); + FREETMPS; + sv_2mortal(*MARK); + } else { + FREETMPS; + *MARK = sv_mortalcopy(TOPs); + } + } else + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + } else { MEXTEND(MARK, 0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; } @@ -1783,37 +1970,45 @@ PP(pp_leavesub) PUTBACK; POPSUB2(); /* Stack values are safe: release CV and @_ ... */ - curpm = newpm; /* ... and pop $1 et al */ + PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; return pop_return(); } -static CV * +STATIC CV * get_db_sub(SV **svp, CV *cv) { dTHR; - SV *oldsv = *svp; - GV *gv; + SV *dbsv = GvSV(PL_DBsub); + + if (!PERLDB_SUB_NN) { + GV *gv = CvGV(cv); - *svp = GvSV(DBsub); - save_item(*svp); - gv = CvGV(cv); - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) - && (gv = (GV*)oldsv) ))) { - /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(*svp, newRV((SV*)cv)); + save_item(dbsv); + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) + && (gv = (GV*)*svp) ))) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + sv_setsv(dbsv, newRV((SV*)cv)); + } + else { + gv_efullname3(dbsv, gv, Nullch); + } } else { - gv_efullname3(*svp, gv, Nullch); + SvUPGRADE(dbsv, SVt_PVIV); + SvIOK_on(dbsv); + SAVEIV(SvIVX(dbsv)); + SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */ } - cv = GvCV(DBsub); + if (CvXSUB(cv)) - curcopdb = curcop; + PL_curcopdb = PL_curcop; + cv = GvCV(PL_DBsub); return cv; } @@ -1825,7 +2020,7 @@ PP(pp_entersub) register CV *cv; register PERL_CONTEXT *cx; I32 gimme; - bool hasargs = (op->op_flags & OPf_STACKED) != 0; + bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) DIE("Not a CODE reference"); @@ -1833,10 +2028,11 @@ PP(pp_entersub) default: if (!SvROK(sv)) { char *sym; + STRLEN n_a; - if (sv == &sv_yes) { /* unfound import, ignore */ + if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) - SP = stack_base + POPMARK; + SP = PL_stack_base + POPMARK; RETURN; } if (SvGMAGICAL(sv)) { @@ -1844,14 +2040,18 @@ PP(pp_entersub) sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else - sym = SvPV(sv, na); + sym = SvPV(sv, n_a); if (!sym) - DIE(no_usym, "a subroutine"); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a subroutine"); + DIE(PL_no_usym, "a subroutine"); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_symref, sym, "a subroutine"); cv = perl_get_cv(sym, TRUE); break; } + { + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; @@ -1901,7 +2101,7 @@ PP(pp_entersub) } gimme = GIMME_V; - if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) + if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) cv = get_db_sub(&sv, cv); if (!cv) DIE("No DBsub routine"); @@ -1918,8 +2118,8 @@ PP(pp_entersub) if (CvFLAGS(cv) & CVf_LOCKED) { MAGIC *mg; if (CvFLAGS(cv) & CVf_METHOD) { - if (SP > stack_base + TOPMARK) - sv = *(stack_base + TOPMARK + 1); + if (SP > PL_stack_base + TOPMARK) + sv = *(PL_stack_base + TOPMARK + 1); else { MUTEX_UNLOCK(CvMUTEXP(cv)); croak("no argument for locked method call"); @@ -1944,10 +2144,9 @@ PP(pp_entersub) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */ save_destructor(unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); @@ -1982,12 +2181,12 @@ PP(pp_entersub) * (3) instead of (2) so we'd have to clone. Would the fact * that we released the mutex more quickly make up for this? */ - svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE); - if (svp) { + if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "entersub: %p already has clone %p:%s\n", thr, cv, SvPEEK((SV*)cv))); CvOWNER(cv) = thr; @@ -2001,7 +2200,7 @@ PP(pp_entersub) CvOWNER(cv) = thr; SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "entersub: %p grabbing %p:%s in stash %s\n", thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? HvNAME(CvSTASH(cv)) : "(none)")); @@ -2010,7 +2209,7 @@ PP(pp_entersub) CV *clonecv; SvREFCNT_inc(cv); /* don't let it vanish from under us */ MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_L((PerlIO_printf(PerlIO_stderr(), + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "entersub: %p cloning %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); /* @@ -2027,7 +2226,7 @@ PP(pp_entersub) cv = clonecv; SvREFCNT_inc(cv); } - DEBUG_L(if (CvDEPTH(cv) != 0) + DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", CvDEPTH(cv));); SAVEDESTRUCTOR(unset_cvowner, (void*) cv); @@ -2045,12 +2244,12 @@ PP(pp_entersub) SP[1] = SP[0]; SP--; } - stack_sp = mark + 1; + PL_stack_sp = mark + 1; fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, - MARK - stack_base + 1, + MARK - PL_stack_base + 1, items); - stack_sp = stack_base + items; + PL_stack_sp = PL_stack_base + items; } else { I32 markix = TOPMARK; @@ -2064,9 +2263,9 @@ PP(pp_entersub) AV* av; I32 items; #ifdef USE_THREADS - av = (AV*)curpad[0]; + av = (AV*)PL_curpad[0]; #else - av = GvAV(defgv); + av = GvAV(PL_defgv); #endif /* USE_THREADS */ items = AvFILLp(av) + 1; /* @_ is not tieable */ @@ -2078,23 +2277,23 @@ PP(pp_entersub) PUTBACK ; } } - if (curcopdb) { /* We assume that the first + if (PL_curcopdb) { /* We assume that the first XSUB in &DB::sub is the called one. */ - SAVESPTR(curcop); - curcop = curcopdb; - curcopdb = NULL; + SAVESPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(cv); + (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS); /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) { - if (markix > stack_sp - stack_base) - *(stack_base + markix) = &sv_undef; + if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { + if (markix > PL_stack_sp - PL_stack_base) + *(PL_stack_base + markix) = &PL_sv_undef; else - *(stack_base + markix) = *stack_sp; - stack_sp = stack_base + markix; + *(PL_stack_base + markix) = *PL_stack_sp; + PL_stack_sp = PL_stack_base + markix; } } LEAVE; @@ -2105,16 +2304,18 @@ PP(pp_entersub) register I32 items = SP - MARK; AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); - push_return(op->op_next); + push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); CvDEPTH(cv)++; + /* XXX This would be a natural place to set C so + * that eval'' ops within this sub know the correct lexical space. + * Owing the speed considerations, we choose to search for the cv + * in doeval() instead. + */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn - && !(PERLDB_SUB && cv == GvCV(DBsub))) - sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *av; AV *newpad = newAV(); @@ -2122,7 +2323,7 @@ PP(pp_entersub) I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &sv_undef) { + if (svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ || *name == '&') /* anonymous code? */ @@ -2155,7 +2356,7 @@ PP(pp_entersub) } #ifdef USE_THREADS if (!hasargs) { - AV* av = (AV*)curpad[0]; + AV* av = (AV*)PL_curpad[0]; items = AvFILLp(av) + 1; if (items) { @@ -2167,8 +2368,8 @@ PP(pp_entersub) } } #endif /* USE_THREADS */ - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); + SAVESPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (hasargs) #endif /* USE_THREADS */ @@ -2177,17 +2378,17 @@ PP(pp_entersub) SV** ary; #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p entersub preparing @_\n", thr)); #endif - av = (AV*)curpad[0]; + av = (AV*)PL_curpad[0]; if (AvREAL(av)) { av_clear(av); AvREAL_off(av); } #ifndef USE_THREADS - cx->blk_sub.savearray = GvAV(defgv); - GvAV(defgv) = (AV*)SvREFCNT_inc(av); + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ cx->blk_sub.argarray = av; ++MARK; @@ -2214,8 +2415,15 @@ PP(pp_entersub) MARK++; } } + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) + && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + sub_crush_depth(cv); #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p entersub returning %p\n", thr, CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); @@ -2226,11 +2434,12 @@ void sub_crush_depth(CV *cv) { if (CvANON(cv)) - warn("Deep recursion on anonymous subroutine"); + warner(WARN_RECURSION, "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); + warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + SvPVX(tmpstr)); } } @@ -2240,19 +2449,20 @@ PP(pp_aelem) SV** svp; I32 elem = POPi; AV* av = (AV*)POPs; - U32 lval = op->op_flags & OPf_MOD; - U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + U32 lval = PL_op->op_flags & OPf_MOD; + U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + SV *sv; if (elem > 0) - elem -= curcop->cop_arybase; + elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; svp = av_fetch(av, elem, lval && !defer); if (lval) { - if (!svp || *svp == &sv_undef) { + if (!svp || *svp == &PL_sv_undef) { SV* lv; if (!defer) - DIE(no_aelem, elem); + DIE(PL_no_aelem, elem); lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -2263,12 +2473,15 @@ PP(pp_aelem) PUSHs(lv); RETURN; } - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); - else if (op->op_private & OPpDEREF) - vivify_ref(*svp, op->op_private & OPpDEREF); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); } - PUSHs(svp ? *svp : &sv_undef); + sv = (svp ? *svp : &PL_sv_undef); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -2279,7 +2492,7 @@ vivify_ref(SV *sv, U32 to_what) mg_get(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) - croak(no_modify); + croak(PL_no_modify); if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); else if (SvTYPE(sv) >= SVt_PV) { @@ -2322,8 +2535,8 @@ PP(pp_method) } } - name = SvPV(TOPs, na); - sv = *(stack_base + TOPMARK + 1); + name = SvPV(TOPs, packlen); + sv = *(PL_stack_base + TOPMARK + 1); if (SvGMAGICAL(sv)) mg_get(sv); @@ -2338,12 +2551,20 @@ PP(pp_method) !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || !isIDFIRST(*packname)) - DIE("Can't call method \"%s\" without a package or object reference", name); + if (!packname || + ((*(U8*)packname >= 0xc0 && IN_UTF8) + ? !isIDFIRST_utf8((U8*)packname) + : !isIDFIRST(*packname) + )) + { + DIE("Can't call method \"%s\" %s", name, + SvOK(sv)? "without a package or object reference" + : "on an undefined value"); + } stash = gv_stashpvn(packname, packlen, TRUE); goto fetch; } - *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } if (!ob || !SvOBJECT(ob)) @@ -2365,7 +2586,7 @@ PP(pp_method) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = HvNAME(sep ? curcop->cop_stash : stash); + packname = HvNAME(sep ? PL_curcop->cop_stash : stash); packlen = strlen(packname); } else {