X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=c721680e212e831b09dcb1689a2d022cd267550b;hb=970d0ca27a2290119cbaa2df59b308a84a879664;hp=b71299e7cd9a034e30484c22d1f2a8b590b882a4;hpb=4e35701fd273ba8d0093a29660dee38a92408e9b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index b71299e..c721680 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -65,7 +65,7 @@ PP(pp_nextstate) PP(pp_gvsv) { djSP; - EXTEND(sp,1); + EXTEND(SP,1); if (op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP->op_gv)); else @@ -183,8 +183,11 @@ PP(pp_padsv) 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; } @@ -247,8 +250,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 = op->op_flags & OPf_MOD; + SV** svp = av_fetch(av, op->op_private, lval); + SV *sv = (svp ? *svp : &sv_undef); + EXTEND(SP, 1); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -295,9 +303,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; @@ -443,8 +454,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 { @@ -524,7 +544,8 @@ PP(pp_rv2hv) } 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); @@ -610,7 +631,6 @@ PP(pp_aassign) hv_clear(hash); while (relem < lastrelem) { /* gobble up all the rest */ - STRLEN len; HE *didstore; if (*relem) sv = *(relem++); @@ -629,14 +649,36 @@ 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 (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"); + } + 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) + if (!SvIMMORTAL(sv)) DIE(no_modify); if (relem <= lastrelem) relem++; @@ -678,12 +720,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 @@ -707,12 +749,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)); } @@ -738,6 +780,16 @@ PP(pp_aassign) 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; @@ -749,25 +801,31 @@ PP(pp_match) I32 safebase; char *truebase; register REGEXP *rx = pm->op_pmregexp; + bool rxtainted; I32 gimme = GIMME; STRLEN len; 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"); + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (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; @@ -777,6 +835,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; @@ -793,6 +857,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; @@ -806,47 +871,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, 0))) 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 < s - t) { + ++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 (CALLREGEXEC(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 @@ -854,7 +928,9 @@ play_it_again: /*NOTREACHED*/ gotcha: - TAINT_IF(rx->exec_tainted); + if (rxtainted) + RX_MATCH_TAINTED_on(rx); + TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; @@ -863,6 +939,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++) { @@ -878,6 +955,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); @@ -904,19 +982,21 @@ play_it_again: RETPUSHYES; } -yup: - TAINT_IF(rx->exec_tainted); - ++BmUSEFUL(pm->op_pmshort); +yup: /* Confirmed by check_substr */ + if (rxtainted) + RX_MATCH_TAINTED_on(rx); + 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) { @@ -926,14 +1006,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)) { @@ -962,7 +1042,7 @@ do_readline(void) 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; @@ -983,8 +1063,11 @@ do_readline(void) 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); + do_open(last_in_gv,"-",1,FALSE,0,0,Nullfp); + sv_setpvn(GvSV(last_in_gv), "-", 1); + SvSETMAGIC(GvSV(last_in_gv)); + fp = IoIFP(io); + goto have_fp; } } fp = nextargv(last_in_gv); @@ -1023,7 +1106,7 @@ do_readline(void) ((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; @@ -1041,7 +1124,10 @@ do_readline(void) } } 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)) { @@ -1085,9 +1171,14 @@ do_readline(void) 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) @@ -1124,6 +1215,7 @@ do_readline(void) } RETURN; } + have_fp: if (gimme == G_SCALAR) { sv = TARG; if (SvROK(sv)) @@ -1183,7 +1275,7 @@ do_readline(void) 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; } @@ -1211,7 +1303,7 @@ do_readline(void) PP(pp_enter) { djSP; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(op, -1); if (gimme == -1) { @@ -1224,7 +1316,7 @@ PP(pp_enter) ENTER; SAVETMPS; - PUSHBLOCK(cx, CXt_BLOCK, sp); + PUSHBLOCK(cx, CXt_BLOCK, SP); RETURN; } @@ -1238,6 +1330,7 @@ PP(pp_helem) HV *hv = (HV*)POPs; U32 lval = op->op_flags & OPf_MOD; U32 defer = op->op_private & OPpLVAL_DEFER; + SV *sv; if (SvTYPE(hv) == SVt_PVHV) { he = hv_fetch_ent(hv, keysv, lval && !defer, 0); @@ -1269,19 +1362,28 @@ 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); } - PUSHs(svp ? *svp : &sv_undef); + sv = (svp ? *svp : &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; } PP(pp_leave) { djSP; - register CONTEXT *cx; + register PERL_CONTEXT *cx; register SV **mark; SV **newsp; PMOP *newpm; @@ -1337,22 +1439,58 @@ PP(pp_leave) PP(pp_iter) { djSP; - register CONTEXT *cx; + 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"); av = cx->blk_loop.iterary; + 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) { + /* 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; + + /* 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 == curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; 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; @@ -1403,22 +1541,30 @@ 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 = ((pm->op_pmdynflags & PMdf_TAINTED) || + (tainted && (pm->op_pmflags & PMf_RETAINT))); + if (tainted) + rxtainted |= 2; TAINT_NOT; force_it: @@ -1432,41 +1578,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, 0))) 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; } } @@ -1477,9 +1634,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 (!CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1493,9 +1651,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) { @@ -1529,15 +1692,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) { @@ -1550,43 +1713,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 (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); - 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 (CALLREGEXEC(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; @@ -1601,11 +1770,9 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase)); + } while (CALLREGEXEC(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); @@ -1614,19 +1781,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; @@ -1642,7 +1814,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; @@ -1667,7 +1839,7 @@ PP(pp_grepwhile) src = stack_base[*markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -1680,7 +1852,7 @@ PP(pp_leavesub) SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_sub cxsub; POPBLOCK(cx,newpm); @@ -1689,9 +1861,19 @@ 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; } @@ -1714,31 +1896,39 @@ PP(pp_leavesub) return pop_return(); } -static CV * +STATIC CV * get_db_sub(SV **svp, CV *cv) { dTHR; - SV *oldsv = *svp; - GV *gv; + SV *dbsv = GvSV(DBsub); - *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)); + 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(*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; + cv = GvCV(DBsub); return cv; } @@ -1748,7 +1938,7 @@ PP(pp_entersub) 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 +1992,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,9 +2010,9 @@ 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; @@ -1834,9 +2024,10 @@ PP(pp_entersub) #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 +2041,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 +2097,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 +2138,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 +2151,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 +2184,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 +2202,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 +2231,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 +2265,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 +2273,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 +2322,7 @@ PP(pp_entersub) } } Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*MARK) @@ -2163,6 +2358,7 @@ PP(pp_aelem) AV* av = (AV*)POPs; U32 lval = op->op_flags & OPf_MOD; U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + SV *sv; if (elem > 0) elem -= curcop->cop_arybase; @@ -2185,11 +2381,14 @@ 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); } - PUSHs(svp ? *svp : &sv_undef); + sv = (svp ? *svp : &sv_undef); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -2210,7 +2409,7 @@ vivify_ref(SV *sv, 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(); @@ -2260,7 +2459,9 @@ PP(pp_method) !(ob=(SV*)GvIO(iogv))) { if (!packname || !isIDFIRST(*packname)) - DIE("Can't call method \"%s\" without a package or object reference", name); + 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; } @@ -2299,3 +2500,4 @@ PP(pp_method) SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } +