X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e55aaa0ea8ae9df2251fb793d58ce52f2d4ed736..f9277f475182e73cbf77386678e16ed5037ab2bb:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index bc46cca..9fbd176 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -18,12 +18,15 @@ #include "EXTERN.h" #include "perl.h" +#ifdef I_UNISTD +#include +#endif + /* Hot code. */ #ifdef USE_THREADS static void -unset_cvowner(cvarg) -void *cvarg; +unset_cvowner(void *cvarg) { register CV* cv = (CV *) cvarg; #ifdef DEBUGGING @@ -45,7 +48,7 @@ void *cvarg; PP(pp_const) { - dSP; + djSP; XPUSHs(cSVOP->op_sv); RETURN; } @@ -61,8 +64,8 @@ PP(pp_nextstate) PP(pp_gvsv) { - dSP; - EXTEND(sp,1); + djSP; + EXTEND(SP,1); if (op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP->op_gv)); else @@ -83,7 +86,7 @@ PP(pp_pushmark) PP(pp_stringify) { - dSP; dTARGET; + djSP; dTARGET; STRLEN len; char *s; s = SvPV(TOPs,len); @@ -94,14 +97,14 @@ PP(pp_stringify) PP(pp_gv) { - dSP; + djSP; XPUSHs((SV*)cGVOP->op_gv); RETURN; } PP(pp_and) { - dSP; + djSP; if (!SvTRUE(TOPs)) RETURN; else { @@ -112,7 +115,7 @@ PP(pp_and) PP(pp_sassign) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; MAGIC *mg; if (op->op_private & OPpASSIGN_BACKWARDS) { @@ -128,7 +131,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - dSP; + djSP; if (SvTRUEx(POPs)) RETURNOP(cCONDOP->op_true); else @@ -148,7 +151,7 @@ PP(pp_unstack) PP(pp_concat) { - dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; STRLEN len; @@ -175,13 +178,16 @@ PP(pp_concat) PP(pp_padsv) { - dSP; dTARGET; + 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) + else if (op->op_private & OPpDEREF) { + PUTBACK; vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); + SPAGAIN; + } } RETURN; } @@ -194,7 +200,7 @@ PP(pp_readline) PP(pp_eq) { - dSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPnv; SETs(boolSV(TOPn == value)); @@ -204,7 +210,7 @@ PP(pp_eq) PP(pp_preinc) { - dSP; + djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -221,7 +227,7 @@ PP(pp_preinc) PP(pp_or) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else { @@ -232,7 +238,7 @@ PP(pp_or) PP(pp_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -242,16 +248,17 @@ PP(pp_add) PP(pp_aelemfast) { - dSP; + djSP; AV *av = GvAV((GV*)cSVOP->op_sv); SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); + EXTEND(SP, 1); PUSHs(svp ? *svp : &sv_undef); RETURN; } PP(pp_join) { - dSP; dMARK; dTARGET; + djSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -261,7 +268,7 @@ PP(pp_join) PP(pp_pushre) { - dSP; + djSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -282,7 +289,7 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; @@ -292,9 +299,12 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = defoutgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { - EXTEND(SP, 1); + /* If using default handle then we need to make space to + * pass object as 1st arg, so move other args up ... + */ + MEXTEND(SP, 1); ++MARK; Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; @@ -379,7 +389,7 @@ PP(pp_print) PP(pp_rv2av) { - dSP; dPOPss; + djSP; dPOPss; AV *av; if (SvROK(sv)) { @@ -440,8 +450,17 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; - EXTEND(SP, maxarg); - Copy(AvARRAY(av), SP+1, maxarg, SV*); + 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; + } + } + else { + Copy(AvARRAY(av), SP+1, maxarg, SV*); + } SP += maxarg; } else { @@ -454,7 +473,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - dSP; dTOPss; + djSP; dTOPss; HV *hv; if (SvROK(sv)) { @@ -535,7 +554,7 @@ PP(pp_rv2hv) PP(pp_aassign) { - dSP; + djSP; SV **lastlelem = stack_sp; SV **lastrelem = stack_base + POPMARK; SV **firstrelem = stack_base + POPMARK + 1; @@ -626,8 +645,15 @@ PP(pp_aassign) } TAINT_NOT; } - if (relem == lastrelem && dowarn) - warn("Odd number of elements in hash list"); + if (relem == lastrelem && dowarn) { + if (relem == firstrelem && + SvROK(*relem) && + ( SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) + warn("Reference found where even-sized list expected"); + else + warn("Odd number of elements in hash assignment"); + } } break; default: @@ -675,12 +701,12 @@ PP(pp_aassign) if (delaymagic & DM_UID) { if (uid != euid) DIE("No setreuid available"); - (void)setuid(uid); + (void)PerlProc_setuid(uid); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ - uid = (int)getuid(); - euid = (int)geteuid(); + uid = (int)PerlProc_getuid(); + euid = (int)PerlProc_geteuid(); } if (delaymagic & DM_GID) { #ifdef HAS_SETRESGID @@ -704,12 +730,12 @@ PP(pp_aassign) if (delaymagic & DM_GID) { if (gid != egid) DIE("No setregid available"); - (void)setgid(gid); + (void)PerlProc_setgid(gid); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ - gid = (int)getgid(); - egid = (int)getegid(); + gid = (int)PerlProc_getgid(); + egid = (int)PerlProc_getegid(); } tainting |= (uid && (euid != uid || egid != gid)); } @@ -737,7 +763,7 @@ PP(pp_aassign) PP(pp_match) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; @@ -751,20 +777,23 @@ PP(pp_match) I32 minmatch = 0; I32 oldsave = savestack_ix; I32 update_minmatch = 1; + SV *screamer; if (op->op_flags & OPf_STACKED) TARG = POPs; else { - TARG = GvSV(defgv); + TARG = DEFSV; EXTEND(SP,1); } + PUTBACK; /* EVAL blocks need stack_sp. */ s = SvPV(TARG, len); strend = s + len; if (!s) DIE("panic: do_match"); TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { + failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; @@ -774,6 +803,12 @@ PP(pp_match) pm = 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; if (global = pm->op_pmflags & PMf_GLOBAL) { rx->startp[0] = 0; @@ -790,6 +825,7 @@ PP(pp_match) gimme = G_SCALAR; /* accidental array context? */ safebase = (((gimme == G_ARRAY) || global || !rx->nparens) && !sawampersand); + safebase = safebase ? 0 : REXEC_COPY_STR ; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; @@ -803,47 +839,56 @@ play_it_again: if (update_minmatch++) minmatch = (s == rx->startp[0]); } - if (pm->op_pmshort) { - if (pm->op_pmflags & PMf_SCANFIRST) { - if (SvSCREAM(TARG)) { - if (screamfirst[BmRARE(pm->op_pmshort)] < 0) + if (rx->check_substr) { + if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */ + if ( screamer ) { + I32 p = -1; + + if (screamfirst[BmRARE(rx->check_substr)] < 0) goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) + else if (!(s = screaminstr(TARG, rx->check_substr, + rx->check_offset_min, 0, &p, 0))) goto nope; - else if (pm->op_pmflags & PMf_ALL) + else if ((rx->reganch & ROPT_CHECK_ALL) + && !sawampersand && !SvTAIL(rx->check_substr)) goto yup; } - else if (!(s = fbm_instr((unsigned char*)s, - (unsigned char*)strend, pm->op_pmshort))) + else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, + (unsigned char*)strend, + rx->check_substr))) goto nope; - else if (pm->op_pmflags & PMf_ALL) + else if ((rx->reganch & ROPT_CHECK_ALL) && !sawampersand) goto yup; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < t) - s = t; + if (s && rx->check_offset_max < t - s) { + ++BmUSEFUL(rx->check_substr); + s -= rx->check_offset_max; } else s = t; } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s - || (pm->op_pmslen > 1 - && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen))) + /* 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. */ + I32 slen; + if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] + || ((slen = SvCUR(rx->check_substr)) > 1 + && memNE(SvPVX(rx->check_substr), + s + rx->check_offset_min, slen))) goto nope; } - if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ + if (!rx->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 (pregexec(rx, s, strend, truebase, minmatch, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) + if (regexec_flags(rx, s, strend, truebase, minmatch, + screamer, NULL, safebase)) { curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -851,7 +896,7 @@ play_it_again: /*NOTREACHED*/ gotcha: - TAINT_IF(rx->exec_tainted); + TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; @@ -860,6 +905,7 @@ play_it_again: i = 1; else i = 0; + SPAGAIN; /* EVAL blocks could move the stack. */ EXTEND(SP, iters + i); EXTEND_MORTAL(iters + i); for (i = !i; i <= iters; i++) { @@ -875,6 +921,7 @@ play_it_again: strend = rx->subend; if (rx->startp[0] && rx->startp[0] == rx->endp[0]) ++rx->endp[0]; + PUTBACK; /* EVAL blocks may use stack */ goto play_it_again; } LEAVE_SCOPE(oldsave); @@ -901,19 +948,19 @@ play_it_again: RETPUSHYES; } -yup: - TAINT_IF(rx->exec_tainted); - ++BmUSEFUL(pm->op_pmshort); +yup: /* Confirmed by check_substr */ + TAINT_IF(RX_MATCH_TAINTED(rx)); + ++BmUSEFUL(rx->check_substr); 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) { rx->subbeg = truebase; rx->subend = strend; rx->startp[0] = s; - rx->endp[0] = s + SvCUR(pm->op_pmshort); + rx->endp[0] = s + SvCUR(rx->check_substr); goto gotcha; } if (sawampersand) { @@ -923,14 +970,14 @@ yup: rx->subbeg = tmps; rx->subend = tmps + (strend-t); tmps = rx->startp[0] = tmps + (s - t); - rx->endp[0] = tmps + SvCUR(pm->op_pmshort); + rx->endp[0] = tmps + SvCUR(rx->check_substr); } LEAVE_SCOPE(oldsave); RETPUSHYES; nope: - if (pm->op_pmshort) - ++BmUSEFUL(pm->op_pmshort); + if (rx->check_substr) + ++BmUSEFUL(rx->check_substr); ret_no: if (global && !(pm->op_pmflags & PMf_CONTINUE)) { @@ -947,9 +994,8 @@ ret_no: } OP * -do_readline() +do_readline(void) { - dTHR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; @@ -960,7 +1006,7 @@ do_readline() I32 gimme = GIMME_V; MAGIC *mg; - if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { + if (SvRMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; @@ -1021,7 +1067,7 @@ do_readline() ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb but that's unsupported, so I don't want to do it now and have it bite someone in the future. */ - strcat(tmpfnam,tmpnam(NULL)); + strcat(tmpfnam,PerlLIO_tmpnam(NULL)); cp = SvPV(tmpglob,i); for (; i; i--) { if (cp[i] == ';') hasver = 1; @@ -1039,7 +1085,10 @@ do_readline() } } if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { - ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); + Stat_t st; + if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) + ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); + else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, &dfltdsc,NULL,NULL,NULL))&1)) { @@ -1083,9 +1132,14 @@ do_readline() sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); #else +#ifdef DJGPP + sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ + sv_catsv(tmpcmd, tmpglob); +#else sv_setpv(tmpcmd, "perlglob "); sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, " |"); +#endif /* !DJGPP */ #endif /* !OS2 */ #else /* !DOSISH */ #if defined(CSH) @@ -1181,7 +1235,7 @@ do_readline() if (!isALPHA(*tmps) && !isDIGIT(*tmps) && strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) break; - if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) { + if (*tmps && PerlLIO_stat(SvPVX(sv), &statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -1208,8 +1262,8 @@ do_readline() PP(pp_enter) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(op, -1); if (gimme == -1) { @@ -1222,14 +1276,14 @@ PP(pp_enter) ENTER; SAVETMPS; - PUSHBLOCK(cx, CXt_BLOCK, sp); + PUSHBLOCK(cx, CXt_BLOCK, SP); RETURN; } PP(pp_helem) { - dSP; + djSP; HE* he; SV **svp; SV *keysv = POPs; @@ -1267,7 +1321,7 @@ PP(pp_helem) if (HvNAME(hv) && isGV(*svp)) save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL)); else - save_svref(svp); + save_helem(hv, keysv, svp); } else if (op->op_private & OPpDEREF) vivify_ref(*svp, op->op_private & OPpDEREF); @@ -1278,8 +1332,8 @@ PP(pp_helem) PP(pp_leave) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; register SV **mark; SV **newsp; PMOP *newpm; @@ -1334,12 +1388,12 @@ PP(pp_leave) PP(pp_iter) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; SV* sv; AV* av; - EXTEND(sp, 1); + EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; if (cx->cx_type != CXt_LOOP) DIE("panic: pp_iter"); @@ -1350,7 +1404,9 @@ PP(pp_iter) SvREFCNT_dec(*cx->blk_loop.itervar); - if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) + if (sv = (SvMAGICAL(av)) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + : AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); else sv = &sv_undef; @@ -1370,7 +1426,7 @@ PP(pp_iter) } LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = cx->blk_loop.iterix; - LvTARGLEN(lv) = -1; + LvTARGLEN(lv) = (UV) -1; sv = (SV*)lv; } @@ -1380,7 +1436,7 @@ PP(pp_iter) PP(pp_subst) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1401,22 +1457,27 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = 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) TARG = POPs; else { - TARG = GvSV(defgv); + TARG = DEFSV; EXTEND(SP,1); - } + } if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) croak(no_modify); + PUTBACK; + s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + rxtainted = tainted << 1; TAINT_NOT; force_it: @@ -1430,41 +1491,52 @@ PP(pp_subst) pm = curpm; rx = pm->op_pmregexp; } - safebase = (!rx->nparens && !sawampersand); + screamer = ( (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; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; } orig = m = s; - if (pm->op_pmshort) { - if (pm->op_pmflags & PMf_SCANFIRST) { - if (SvSCREAM(TARG)) { - if (screamfirst[BmRARE(pm->op_pmshort)] < 0) + if (rx->check_substr) { + if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */ + if (screamer) { + I32 p = -1; + + if (screamfirst[BmRARE(rx->check_substr)] < 0) goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) + else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0))) goto nope; } - else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend, - pm->op_pmshort))) + else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, + (unsigned char*)strend, + rx->check_substr))) goto nope; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < m) - s = m; + if (s && rx->check_offset_max < s - m) { + ++BmUSEFUL(rx->check_substr); + s -= rx->check_offset_max; } else s = m; } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s - || (pm->op_pmslen > 1 - && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen))) + /* 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. */ + I32 slen; + if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] + || ((slen = SvCUR(rx->check_substr)) > 1 + && memNE(SvPVX(rx->check_substr), + s + rx->check_offset_min, slen))) goto nope; } - if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ + if (!rx->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; } } @@ -1475,9 +1547,10 @@ PP(pp_subst) c = dstr ? SvPV(dstr, clen) : Nullch; /* can do inplace substitution? */ - if (c && clen <= rx->minlen && safebase) { - if (! pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR)) + && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { + if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1491,9 +1564,14 @@ PP(pp_subst) curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted = rx->exec_tainted; - m = rx->startp[0]; - d = rx->endp[0]; + rxtainted |= RX_MATCH_TAINTED(rx); + if (rx->subbase) { + m = orig + (rx->startp[0] - rx->subbase); + d = orig + (rx->endp[0] - rx->subbase); + } else { + m = rx->startp[0]; + d = rx->endp[0]; + } s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -1527,15 +1605,15 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); + SPAGAIN; PUSHs(&sv_yes); } else { - rxtainted = 0; do { if (iters++ > maxiters) DIE("Substitution loop"); - rxtainted |= rx->exec_tainted; + rxtainted |= RX_MATCH_TAINTED(rx); m = rx->startp[0]; /*SUPPRESS 560*/ if (i = m - s) { @@ -1548,43 +1626,49 @@ PP(pp_subst) d += clen; } s = rx->endp[0]; - } while (pregexec(rx, s, strend, orig, s == m, - Nullsv, TRUE)); /* don't match same null twice */ + } while (regexec_flags(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); - SvSETMAGIC(TARG); + TAINT_IF(rxtainted); + if (SvSMAGICAL(TARG)) { + PUTBACK; + mg_set(TARG); + SPAGAIN; + } SvTAINT(TARG); LEAVE_SCOPE(oldsave); RETURN; } - if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + if (regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); goto force_it; } - rxtainted = rx->exec_tainted; - dstr = NEWSV(25, sv_len(TARG)); + rxtainted |= RX_MATCH_TAINTED(rx); + dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); curpm = pm; if (!c) { - register CONTEXT *cx; + register PERL_CONTEXT *cx; + SPAGAIN; PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } do { if (iters++ > maxiters) DIE("Substitution loop"); - rxtainted |= rx->exec_tainted; + rxtainted |= RX_MATCH_TAINTED(rx); if (rx->subbase && rx->subbase != orig) { m = s; s = orig; @@ -1599,11 +1683,9 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase)); + } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase)); sv_catpvn(dstr, s, strend - s); - TAINT_IF(rxtainted); - (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); @@ -1612,19 +1694,24 @@ 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); - PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; } goto ret_no; nope: - ++BmUSEFUL(pm->op_pmshort); + ++BmUSEFUL(rx->check_substr); -ret_no: +ret_no: + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1632,7 +1719,7 @@ ret_no: PP(pp_grepwhile) { - dSP; + djSP; if (SvTRUEx(POPs)) stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; @@ -1640,7 +1727,7 @@ PP(pp_grepwhile) LEAVE; /* exit inner scope */ /* All done yet? */ - if (stack_base + *markstack_ptr > sp) { + if (stack_base + *markstack_ptr > SP) { I32 items; I32 gimme = GIMME_V; @@ -1665,7 +1752,7 @@ PP(pp_grepwhile) src = stack_base[*markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -1673,12 +1760,12 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dSP; + djSP; SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_sub cxsub; POPBLOCK(cx,newpm); @@ -1712,43 +1799,49 @@ PP(pp_leavesub) return pop_return(); } -static CV * -get_db_sub(sv) -SV *sv; +STATIC CV * +get_db_sub(SV **svp, CV *cv) { dTHR; - SV *oldsv = sv; - GV *gv; - CV *cv; - - sv = GvSV(DBsub); - save_item(sv); - 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(sv, newRV((SV*)cv)); + SV *dbsv = GvSV(DBsub); + + if (!PERLDB_SUB_NN) { + GV *gv = CvGV(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(sv, 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; + cv = GvCV(DBsub); return cv; } PP(pp_entersub) { - dSP; dPOPss; + djSP; dPOPss; GV *gv; HV *stash; register CV *cv; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme; bool hasargs = (op->op_flags & OPf_STACKED) != 0; @@ -1802,7 +1895,7 @@ PP(pp_entersub) if (!CvROOT(cv) && !CvXSUB(cv)) { GV* autogv; - SV* subname; + SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ if (CvANON(cv) || !(gv = CvGV(cv))) @@ -1820,23 +1913,24 @@ PP(pp_entersub) goto retry; } /* sorry */ - subname = sv_newmortal(); - gv_efullname3(subname, gv, Nullch); - DIE("Undefined subroutine &%s called", SvPVX(subname)); + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE("Undefined subroutine &%s called", SvPVX(sub_name)); } gimme = GIMME_V; if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) - cv = get_db_sub(sv); + cv = get_db_sub(&sv, cv); if (!cv) DIE("No DBsub routine"); #ifdef USE_THREADS /* * First we need to check if the sub or method requires locking. - * If so, we gain a lock on the CV or the first argument, as - * appropriate. This has to be inline because for FAKE_THREADS, - * COND_WAIT inlines code to reschedule by returning a new op. + * If so, we gain a lock on the CV, the first argument or the + * stash (for static methods), as appropriate. This has to be + * inline because for FAKE_THREADS, COND_WAIT inlines code to + * reschedule by returning a new op. */ MUTEX_LOCK(CvMUTEXP(cv)); if (CvFLAGS(cv) & CVf_LOCKED) { @@ -1850,6 +1944,11 @@ PP(pp_entersub) } if (SvROK(sv)) sv = SvRV(sv); + else { + STRLEN len; + char *stashname = SvPV(sv, len); + sv = (SV*)gv_stashpvn(stashname, len, TRUE); + } } else { sv = (SV*)cv; @@ -1901,8 +2000,9 @@ 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(cvcache, (char *)cv, sizeof(cv), FALSE); - if (svp) { + if (threadnum && + (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; @@ -1941,7 +2041,7 @@ PP(pp_entersub) */ clonecv = cv_clone(cv); SvREFCNT_dec(cv); /* finished with this */ - hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); + hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); CvOWNER(clonecv) = thr; cv = clonecv; SvREFCNT_inc(cv); @@ -1954,17 +2054,15 @@ PP(pp_entersub) } #endif /* USE_THREADS */ - gimme = GIMME; - if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); dMARK; register I32 items = SP - MARK; /* We dont worry to copy from @_. */ - while (sp > mark) { - sp[1] = sp[0]; - sp--; + while (SP > mark) { + SP[1] = SP[0]; + SP--; } stack_sp = mark + 1; fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); @@ -1989,13 +2087,13 @@ PP(pp_entersub) #else av = GvAV(defgv); #endif /* USE_THREADS */ - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { /* Mark is at the end of the stack. */ - EXTEND(sp, items); - Copy(AvARRAY(av), sp + 1, items, SV*); - sp += items; + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; PUTBACK ; } } @@ -2007,7 +2105,7 @@ PP(pp_entersub) 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 ) { @@ -2036,11 +2134,11 @@ PP(pp_entersub) if (CvDEPTH(cv) == 100 && dowarn && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILL(padlist)) { + if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *av; AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILL((AV*)svp[1]); + I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { @@ -2070,7 +2168,7 @@ PP(pp_entersub) av_store(newpad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); + AvFILLp(padlist) = CvDEPTH(cv); svp = AvARRAY(padlist); } } @@ -2078,12 +2176,12 @@ PP(pp_entersub) if (!hasargs) { AV* av = (AV*)curpad[0]; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ - EXTEND(sp, items); - Copy(AvARRAY(av), sp + 1, items, SV*); - sp += items; + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; PUTBACK ; } } @@ -2127,7 +2225,7 @@ PP(pp_entersub) } } Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*MARK) @@ -2144,8 +2242,7 @@ PP(pp_entersub) } void -sub_crush_depth(cv) -CV* cv; +sub_crush_depth(CV *cv) { if (CvANON(cv)) warn("Deep recursion on anonymous subroutine"); @@ -2158,7 +2255,7 @@ CV* cv; PP(pp_aelem) { - dSP; + djSP; SV** svp; I32 elem = POPi; AV* av = (AV*)POPs; @@ -2186,7 +2283,7 @@ PP(pp_aelem) RETURN; } if (op->op_private & OPpLVAL_INTRO) - save_svref(svp); + save_aelem(av, elem, svp); else if (op->op_private & OPpDEREF) vivify_ref(*svp, op->op_private & OPpDEREF); } @@ -2195,9 +2292,7 @@ PP(pp_aelem) } void -vivify_ref(sv, to_what) -SV* sv; -U32 to_what; +vivify_ref(SV *sv, U32 to_what) { if (SvGMAGICAL(sv)) mg_get(sv); @@ -2213,7 +2308,7 @@ U32 to_what; } switch (to_what) { case OPpDEREF_SV: - SvRV(sv) = newSV(0); + SvRV(sv) = NEWSV(355,0); break; case OPpDEREF_AV: SvRV(sv) = (SV*)newAV(); @@ -2229,7 +2324,7 @@ U32 to_what; PP(pp_method) { - dSP; + djSP; SV* sv; SV* ob; GV* gv; @@ -2302,3 +2397,4 @@ PP(pp_method) SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } +