X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0c8c7a0553bc4fb5d18712a0ed968981d85f1767..f9277f475182e73cbf77386678e16ed5037ab2bb:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index f957deb..9fbd176 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -18,11 +18,37 @@ #include "EXTERN.h" #include "perl.h" +#ifdef I_UNISTD +#include +#endif + /* Hot code. */ +#ifdef USE_THREADS +static void +unset_cvowner(void *cvarg) +{ + register CV* cv = (CV *) cvarg; +#ifdef DEBUGGING + dTHR; +#endif /* DEBUGGING */ + + DEBUG_L((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) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + assert(thr == CvOWNER(cv)); + CvOWNER(cv) = 0; + MUTEX_UNLOCK(CvMUTEXP(cv)); + SvREFCNT_dec(cv); +} +#endif /* USE_THREADS */ + PP(pp_const) { - dSP; + djSP; XPUSHs(cSVOP->op_sv); RETURN; } @@ -38,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 @@ -60,7 +86,7 @@ PP(pp_pushmark) PP(pp_stringify) { - dSP; dTARGET; + djSP; dTARGET; STRLEN len; char *s; s = SvPV(TOPs,len); @@ -71,76 +97,14 @@ PP(pp_stringify) PP(pp_gv) { - dSP; + djSP; XPUSHs((SV*)cGVOP->op_gv); RETURN; } -PP(pp_gelem) -{ - GV *gv; - SV *sv; - SV *ref; - char *elem; - dSP; - - sv = POPs; - elem = SvPV(sv, na); - gv = (GV*)POPs; - ref = Nullsv; - sv = Nullsv; - switch (elem ? *elem : '\0') - { - case 'A': - if (strEQ(elem, "ARRAY")) - ref = (SV*)GvAV(gv); - break; - case 'C': - if (strEQ(elem, "CODE")) - ref = (SV*)GvCV(gv); - break; - case 'F': - if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ - ref = (SV*)GvIOp(gv); - break; - case 'G': - if (strEQ(elem, "GLOB")) - ref = (SV*)gv; - break; - case 'H': - if (strEQ(elem, "HASH")) - ref = (SV*)GvHV(gv); - break; - case 'I': - if (strEQ(elem, "IO")) - ref = (SV*)GvIOp(gv); - break; - case 'N': - if (strEQ(elem, "NAME")) - sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); - break; - case 'P': - if (strEQ(elem, "PACKAGE")) - sv = newSVpv(HvNAME(GvSTASH(gv)), 0); - break; - case 'S': - if (strEQ(elem, "SCALAR")) - ref = GvSV(gv); - break; - } - if (ref) - sv = newRV(ref); - if (sv) - sv_2mortal(sv); - else - sv = &sv_undef; - XPUSHs(sv); - RETURN; -} - PP(pp_and) { - dSP; + djSP; if (!SvTRUE(TOPs)) RETURN; else { @@ -151,7 +115,7 @@ PP(pp_and) PP(pp_sassign) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; MAGIC *mg; if (op->op_private & OPpASSIGN_BACKWARDS) { @@ -160,15 +124,14 @@ PP(pp_sassign) } if (tainting && tainted && !SvTAINTED(left)) TAINT_NOT; - SvSetSV(right, left); - SvSETMAGIC(right); + SvSetMagicSV(right, left); SETs(right); RETURN; } PP(pp_cond_expr) { - dSP; + djSP; if (SvTRUEx(POPs)) RETURNOP(cCONDOP->op_true); else @@ -188,7 +151,7 @@ PP(pp_unstack) PP(pp_concat) { - dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; STRLEN len; @@ -204,7 +167,10 @@ PP(pp_concat) s = SvPV_force(TARG, len); } s = SvPV(right,len); - sv_catpvn(TARG,s,len); + if (SvOK(TARG)) + sv_catpvn(TARG,s,len); + else + sv_setpvn(TARG,s,len); /* suppress warning */ SETTARG; RETURN; } @@ -212,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) - provide_ref(op, curpad[op->op_targ]); + else if (op->op_private & OPpDEREF) { + PUTBACK; + vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); + SPAGAIN; + } } RETURN; } @@ -231,17 +200,19 @@ PP(pp_readline) PP(pp_eq) { - dSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPnv; - SETs((TOPn == value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn == value)); RETURN; } } PP(pp_preinc) { - dSP; + djSP; + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + croak(no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { @@ -256,7 +227,7 @@ PP(pp_preinc) PP(pp_or) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else { @@ -267,7 +238,7 @@ PP(pp_or) PP(pp_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -277,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; @@ -296,8 +268,20 @@ PP(pp_join) PP(pp_pushre) { - dSP; + djSP; +#ifdef DEBUGGING + /* + * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs + * will be enough to hold an OP*. + */ + SV* sv = sv_newmortal(); + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = '/'; + Copy(&op, &LvTARGOFF(sv), 1, OP*); + XPUSHs(sv); +#else XPUSHs((SV*)op); +#endif RETURN; } @@ -305,7 +289,7 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; @@ -315,18 +299,26 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = defoutgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { - SV *sv; - - PUSHMARK(MARK-1); + if (SvRMAGICAL(gv) && (mg = mg_find((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 ... + */ + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + PUSHMARK(MARK - 1); *MARK = mg->mg_obj; + PUTBACK; ENTER; perl_call_method("PRINT", G_SCALAR); LEAVE; SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); + MARK = ORIGMARK + 1; + *MARK = *SP; + SP = MARK; RETURN; } if (!(io = GvIO(gv))) { @@ -397,8 +389,7 @@ PP(pp_print) PP(pp_rv2av) { - dSP; dPOPss; - + djSP; dPOPss; AV *av; if (SvROK(sv)) { @@ -406,8 +397,6 @@ PP(pp_rv2av) av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) DIE("Not an ARRAY reference"); - if (op->op_private & OPpLVAL_INTRO) - av = (AV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { PUSHs((SV*)av); RETURN; @@ -436,6 +425,8 @@ PP(pp_rv2av) 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) RETURN; RETPUSHUNDEF; @@ -459,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 { @@ -473,25 +473,21 @@ PP(pp_rv2av) PP(pp_rv2hv) { - - dSP; dTOPss; - + djSP; dTOPss; HV *hv; if (SvROK(sv)) { wasref: hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) + if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) DIE("Not a HASH reference"); - if (op->op_private & OPpLVAL_INTRO) - hv = (HV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } } else { - if (SvTYPE(sv) == SVt_PVHV) { + if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { hv = (HV*)sv; if (op->op_flags & OPf_REF) { SETs((SV*)hv); @@ -513,6 +509,8 @@ PP(pp_rv2hv) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); + if (dowarn) + warn(warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; @@ -542,12 +540,13 @@ PP(pp_rv2hv) } else { dTARGET; - if (HvFILL(hv)) { - sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1); - sv_setpv(TARG, buf); - } + /* This bit is OK even when hv is really an AV */ + if (HvFILL(hv)) + sv_setpvf(TARG, "%ld/%ld", + (long)HvFILL(hv), (long)HvMAX(hv) + 1); else sv_setiv(TARG, 0); + SETTARG; RETURN; } @@ -555,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; @@ -567,6 +566,7 @@ PP(pp_aassign) register SV *sv; register AV *ary; + I32 gimme; HV *hash; I32 i; int magic; @@ -580,8 +580,10 @@ PP(pp_aassign) if (op->op_private & OPpASSIGN_COMMON) { for (relem = firstrelem; relem <= lastrelem; relem++) { /*SUPPRESS 560*/ - if (sv = *relem) + if (sv = *relem) { + TAINT_NOT; /* Each item is independent */ *relem = sv_mortalcopy(sv); + } } } @@ -598,15 +600,21 @@ PP(pp_aassign) magic = SvMAGICAL(ary) != 0; av_clear(ary); + av_extend(ary, lastrelem - relem); i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ + SV **didstore; sv = NEWSV(28,0); assert(*relem); sv_setsv(sv,*relem); *(relem++) = sv; - (void)av_store(ary,i++,sv); - if (magic) - mg_set(sv); + didstore = av_store(ary,i++,sv); + if (magic) { + if (SvSMAGICAL(sv)) + mg_set(sv); + if (!didstore) + SvREFCNT_dec(sv); + } TAINT_NOT; } break; @@ -619,6 +627,7 @@ PP(pp_aassign) while (relem < lastrelem) { /* gobble up all the rest */ STRLEN len; + HE *didstore; if (*relem) sv = *(relem++); else @@ -627,13 +636,24 @@ PP(pp_aassign) if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; - (void)hv_store_ent(hash,sv,tmpstr,0); - if (magic) - mg_set(tmpstr); + didstore = hv_store_ent(hash,sv,tmpstr,0); + if (magic) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + SvREFCNT_dec(tmpstr); + } TAINT_NOT; } - if (relem == lastrelem) - 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: @@ -681,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 @@ -710,17 +730,26 @@ 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)); } delaymagic = 0; - if (GIMME == G_ARRAY) { + + gimme = GIMME_V; + if (gimme == G_VOID) + SP = firstrelem - 1; + else if (gimme == G_SCALAR) { + dTARGET; + SP = firstrelem; + SETi(lastrelem - firstrelem + 1); + } + else { if (ary || hash) SP = lastrelem; else @@ -728,20 +757,13 @@ PP(pp_aassign) lelem = firstlelem + (relem - firstrelem); while (relem <= SP) *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef; - RETURN; - } - else { - dTARGET; - SP = firstrelem; - - SETi(lastrelem - firstrelem + 1); - RETURN; } + RETURN; } PP(pp_match) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; @@ -754,19 +776,24 @@ PP(pp_match) 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"); + TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { + failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; @@ -776,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; @@ -784,12 +817,15 @@ PP(pp_match) if (mg && mg->mg_len >= 0) { 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) && !sawampersand); + 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; @@ -798,51 +834,61 @@ PP(pp_match) play_it_again: if (global && rx->startp[0]) { t = s = rx->endp[0]; - if (s >= strend) + if ((s + rx->minlen) > strend) goto nope; - minmatch = (s == rx->startp[0]); + 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 @@ -850,15 +896,16 @@ play_it_again: /*NOTREACHED*/ gotcha: + TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; - TAINT_IF(rx->exec_tainted); iters = rx->nparens; if (global && !iters) 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++) { @@ -874,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); @@ -900,18 +948,19 @@ play_it_again: RETPUSHYES; } -yup: - ++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) { @@ -921,16 +970,23 @@ 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)) { + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { + MAGIC* mg = mg_find(TARG, 'g'); + if (mg) + mg->mg_len = -1; + } + } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) RETURN; @@ -938,7 +994,7 @@ ret_no: } OP * -do_readline() +do_readline(void) { dSP; dTARGETSTACKED; register SV *sv; @@ -947,17 +1003,19 @@ do_readline() PerlIO *fp; register IO *io = GvIO(last_in_gv); register I32 type = op->op_type; + 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; ENTER; - perl_call_method("READLINE", GIMME); + perl_call_method("READLINE", gimme); LEAVE; SPAGAIN; - if (GIMME == G_SCALAR) sv_setsv(TARG, TOPs); + if (gimme == G_SCALAR) + SvSetMagicSV_nosteal(TARG, TOPs); RETURN; } fp = Nullfp; @@ -1009,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; @@ -1027,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)) { @@ -1036,7 +1097,7 @@ do_readline() *(end++) = '\n'; *end = '\0'; for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob)); + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); begin = rstr; } else { @@ -1060,6 +1121,7 @@ do_readline() PerlIO_rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ } } } @@ -1070,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) @@ -1103,18 +1170,16 @@ do_readline() if (!fp) { if (dowarn && io && !(IoFLAGS(io) & IOf_START)) warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); - if (GIMME == G_SCALAR) { + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } - if (GIMME == G_ARRAY) { - sv = sv_2mortal(NEWSV(57, 80)); - offset = 0; - } - else { + if (gimme == G_SCALAR) { sv = TARG; + if (SvROK(sv)) + sv_unref(sv); (void)SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen) @@ -1124,6 +1189,10 @@ do_readline() else offset = 0; } + else { + sv = sv_2mortal(NEWSV(57, 80)); + offset = 0; + } for (;;) { if (!sv_gets(sv, fp, offset)) { PerlIO_clearerr(fp); @@ -1135,9 +1204,10 @@ do_readline() IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - (void)do_close(last_in_gv, FALSE); + if (do_close(last_in_gv, FALSE) & ~0xFF) + warn("internal error: glob failed"); } - if (GIMME == G_SCALAR) { + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } @@ -1165,12 +1235,12 @@ 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; } } - if (GIMME == G_ARRAY) { + if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { SvLEN_set(sv, SvCUR(sv)+1); Renew(SvPVX(sv), SvLEN(sv), char); @@ -1178,7 +1248,7 @@ do_readline() sv = sv_2mortal(NEWSV(58, 80)); continue; } - else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ if (SvCUR(sv) < 60) SvLEN_set(sv, 80); @@ -1192,61 +1262,78 @@ do_readline() PP(pp_enter) { - dSP; - register CONTEXT *cx; - I32 gimme; + djSP; + register PERL_CONTEXT *cx; + I32 gimme = OP_GIMME(op, -1); - /* - * We don't just use the GIMME macro here because it assumes there's - * already a context, which ain't necessarily so at initial startup. - */ - - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; + if (gimme == -1) { + if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + } 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; HV *hv = (HV*)POPs; - I32 lval = op->op_flags & OPf_MOD; + U32 lval = op->op_flags & OPf_MOD; + U32 defer = op->op_private & OPpLVAL_DEFER; - if (SvTYPE(hv) != SVt_PVHV) + 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) { + svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); + } + else { RETPUSHUNDEF; - he = hv_fetch_ent(hv, keysv, lval, 0); + } if (lval) { - if (!he || HeVAL(he) == &sv_undef) - DIE(no_helem, SvPV(keysv, na)); + if (!svp || *svp == &sv_undef) { + SV* lv; + SV* key2; + if (!defer) + DIE(no_helem, SvPV(keysv, na)); + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0); + SvREFCNT_dec(key2); /* sv_magic() increments refcount */ + LvTARG(lv) = SvREFCNT_inc(hv); + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } if (op->op_private & OPpLVAL_INTRO) { - if (HvNAME(hv) && isGV(HeVAL(he))) - save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL)); + if (HvNAME(hv) && isGV(*svp)) + save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL)); else - save_svref(&HeVAL(he)); + save_helem(hv, keysv, svp); } else if (op->op_private & OPpDEREF) - provide_ref(op, HeVAL(he)); + vivify_ref(*svp, op->op_private & OPpDEREF); } - PUSHs(he ? HeVAL(he) : &sv_undef); + PUSHs(svp ? *svp : &sv_undef); RETURN; } PP(pp_leave) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; register SV **mark; SV **newsp; PMOP *newpm; @@ -1259,35 +1346,38 @@ PP(pp_leave) POPBLOCK(cx,newpm); - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; + gimme = OP_GIMME(op, -1); + if (gimme == -1) { + if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + } - if (gimme == G_SCALAR) { - if (op->op_private & OPpLEAVE_VOID) - SP = newsp; + TAINT_NOT; + if (gimme == G_VOID) + SP = newsp; + else if (gimme == G_SCALAR) { + MARK = newsp + 1; + if (MARK <= SP) + if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); else { - MARK = newsp + 1; - if (MARK <= SP) - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; + MEXTEND(mark,0); + *MARK = &sv_undef; } + SP = MARK; } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) + else if (gimme == G_ARRAY) { + /* in case LEAVE wipes old return values */ + for (mark = newsp + 1; mark <= SP; mark++) { + if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ + TAINT_NOT; /* Each item is independent */ + } + } } curpm = newpm; /* Don't pop $1 et al till now */ @@ -1298,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"); @@ -1314,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; @@ -1327,14 +1419,14 @@ PP(pp_iter) if (lv) SvREFCNT_dec(LvTARG(lv)); else { - lv = cx->blk_loop.iterlval = newSVsv(sv); + lv = cx->blk_loop.iterlval = NEWSV(26, 0); sv_upgrade(lv, SVt_PVLV); - sv_magic(lv, Nullsv, 'y', Nullch, 0); LvTYPE(lv) = 'y'; + sv_magic(lv, Nullsv, 'y', Nullch, 0); } LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = cx->blk_loop.iterix; - LvTARGLEN(lv) = 1; + LvTARGLEN(lv) = (UV) -1; sv = (SV*)lv; } @@ -1344,7 +1436,7 @@ PP(pp_iter) PP(pp_subst) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1365,18 +1457,28 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = savestack_ix; + I32 update_minmatch = 1; + SV *screamer; - if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ - dstr = POPs; + /* 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) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV)) + if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + rxtainted = tainted << 1; + TAINT_NOT; force_it: if (!pm || !s) @@ -1389,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; } } @@ -1431,12 +1544,13 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* known replacement string? */ - c = (rpm->op_pmflags & PMf_CONST) ? SvPV(dstr, clen) : Nullch; + c = dstr ? SvPV(dstr, clen) : Nullch; /* can do inplace substitution? */ - if (c && clen <= rx->minlen) { - 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; @@ -1446,15 +1560,18 @@ PP(pp_subst) s = SvPV_force(TARG, len); goto force_it; } - if (rx->subbase) /* oops, no we can't */ - goto long_way; d = s; 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) { @@ -1488,14 +1605,15 @@ PP(pp_subst) else { sv_chop(TARG, d); } + 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) { @@ -1508,44 +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 & 1); + SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - if (rxtainted) - SvTAINTED_on(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)) { - long_way: + 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; @@ -1560,7 +1683,7 @@ 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); (void)SvOOK_off(TARG); @@ -1571,20 +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); - if (rxtainted) - SvTAINTED_on(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); + SvTAINT(TARG); LEAVE_SCOPE(oldsave); RETURN; } - PUSHs(&sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + goto ret_no; nope: - ++BmUSEFUL(pm->op_pmshort); + ++BmUSEFUL(rx->check_substr); + +ret_no: + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1592,7 +1719,7 @@ nope: PP(pp_grepwhile) { - dSP; + djSP; if (SvTRUEx(POPs)) stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; @@ -1600,20 +1727,21 @@ 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; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*markstack_ptr - markstack_ptr[-1]; (void)POPMARK; /* pop dst */ SP = stack_base + POPMARK; /* pop original mark */ - if (GIMME != G_ARRAY) { + if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); - RETURN; } - SP += items; + else if (gimme == G_ARRAY) + SP += items; RETURN; } else { @@ -1624,7 +1752,7 @@ PP(pp_grepwhile) src = stack_base[*markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -1632,59 +1760,90 @@ 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); - POPSUB(cx); - + POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ + + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; if (MARK <= SP) - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); else { - MEXTEND(mark,0); + MEXTEND(MARK, 0); *MARK = &sv_undef; } SP = MARK; } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & SVs_TEMP)) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ + else if (gimme == G_ARRAY) { + for (MARK = newsp + 1; MARK <= SP; MARK++) { + if (!SvTEMP(*MARK)) { + *MARK = sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } + } } + PUTBACK; + + POPSUB2(); /* Stack values are safe: release CV and @_ ... */ + curpm = newpm; /* ... and pop $1 et al */ + + LEAVE; + return pop_return(); +} + +STATIC CV * +get_db_sub(SV **svp, CV *cv) +{ + dTHR; + SV *dbsv = GvSV(DBsub); - if (cx->blk_sub.hasargs) { /* You don't exist; go away. */ - AV* av = cx->blk_sub.argarray; + if (!PERLDB_SUB_NN) { + GV *gv = CvGV(cv); - av_clear(av); - AvREAL_off(av); + 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 { + SvUPGRADE(dbsv, SVt_PVIV); + SvIOK_on(dbsv); + SAVEIV(SvIVX(dbsv)); + SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */ } - curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; - PUTBACK; - return pop_return(); + 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; - bool may_clone = TRUE; if (!sv) DIE("Not a CODE reference"); @@ -1693,31 +1852,36 @@ PP(pp_entersub) if (!SvROK(sv)) { char *sym; - if (sv == &sv_yes) /* unfound import, ignore */ + if (sv == &sv_yes) { /* unfound import, ignore */ + if (hasargs) + SP = stack_base + POPMARK; RETURN; - if (!SvOK(sv)) + } + if (SvGMAGICAL(sv)) { + mg_get(sv); + sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; + } + else + sym = SvPV(sv, na); + if (!sym) DIE(no_usym, "a subroutine"); - sym = SvPV(sv,na); if (op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a subroutine"); cv = perl_get_cv(sym, TRUE); break; } cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) { - may_clone = FALSE; + if (SvTYPE(cv) == SVt_PVCV) break; - } /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: DIE("Not a CODE reference"); case SVt_PVCV: cv = (CV*)sv; - may_clone = FALSE; break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) + if (!(cv = GvCVu((GV*)sv))) cv = sv_2cv(sv, &stash, &gv, TRUE); break; } @@ -1725,62 +1889,170 @@ PP(pp_entersub) ENTER; SAVETMPS; - if (may_clone && cv && CvCLONE(cv)) - cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - retry: if (!cv) DIE("Not a CODE reference"); if (!CvROOT(cv) && !CvXSUB(cv)) { - if (gv = CvGV(cv)) { - SV *tmpstr; - GV *ngv; - if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */ - cv = GvCV(gv); - if (SvTYPE(sv) == SVt_PVGV) { - SvREFCNT_dec(GvCV((GV*)sv)); - GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv); - } - goto retry; + GV* autogv; + SV* sub_name; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvANON(cv) || !(gv = CvGV(cv))) + DIE("Undefined subroutine called"); + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + goto retry; + } + /* should call AUTOLOAD now? */ + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + FALSE))) + { + cv = GvCV(autogv); + goto retry; + } + /* sorry */ + 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); + 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, 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) { + MAGIC *mg; + if (CvFLAGS(cv) & CVf_METHOD) { + if (SP > stack_base + TOPMARK) + sv = *(stack_base + TOPMARK + 1); + else { + MUTEX_UNLOCK(CvMUTEXP(cv)); + croak("no argument for locked method call"); } - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, Nullch); - ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); - if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ - gv = ngv; - sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */ - SvTAINTED_off(GvSV(CvGV(cv))); - goto retry; + if (SvROK(sv)) + sv = SvRV(sv); + else { + STRLEN len; + char *stashname = SvPV(sv, len); + sv = (SV*)gv_stashpvn(stashname, len, TRUE); } - else - DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); } - DIE("Undefined subroutine called"); + else { + sv = (SV*)cv; + } + MUTEX_UNLOCK(CvMUTEXP(cv)); + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_L(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)); } - - gimme = GIMME; - if ((op->op_private & OPpENTERSUB_DB)) { - SV *oldsv = sv; - 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)); + /* + * Now we have permission to enter the sub, we must distinguish + * four cases. (0) It's an XSUB (in which case we don't care + * about ownership); (1) it's ours already (and we're recursing); + * (2) it's free (but we may already be using a cached clone); + * (3) another thread owns it. Case (1) is easy: we just use it. + * Case (2) means we look for a clone--if we have one, use it + * otherwise grab ownership of cv. Case (3) means we look for a + * clone (for non-XSUBs) and have to create one if we don't + * already have one. + * Why look for a clone in case (2) when we could just grab + * ownership of cv straight away? Well, we could be recursing, + * i.e. we originally tried to enter cv while another thread + * owned it (hence we used a clone) but it has been freed up + * and we're now recursing into it. It may or may not be "better" + * to use the clone but at least CvDEPTH can be trusted. + */ + if (CvOWNER(cv) == thr || CvXSUB(cv)) + MUTEX_UNLOCK(CvMUTEXP(cv)); + else { + /* Case (2) or (3) */ + SV **svp; + + /* + * XXX Might it be better to release CvMUTEXP(cv) while we + * do the hv_fetch? We might find someone has pinched it + * when we look again, in which case we would be in case + * (3) instead of (2) so we'd have to clone. Would the fact + * that we released the mutex more quickly make up for this? + */ + 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; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "entersub: %p already has clone %p:%s\n", + thr, cv, SvPEEK((SV*)cv))); + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); + if (CvDEPTH(cv) == 0) + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } else { - gv_efullname3(sv, gv, Nullch); + /* (2) => grab ownership of cv. (3) => make clone */ + if (!CvOWNER(cv)) { + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "entersub: %p grabbing %p:%s in stash %s\n", + thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? + HvNAME(CvSTASH(cv)) : "(none)")); + } else { + /* Make a new clone. */ + CV *clonecv; + SvREFCNT_inc(cv); /* don't let it vanish from under us */ + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_L((PerlIO_printf(PerlIO_stderr(), + "entersub: %p cloning %p:%s\n", + thr, cv, SvPEEK((SV*)cv)))); + /* + * We're creating a new clone so there's no race + * between the original MUTEX_UNLOCK and the + * SvREFCNT_inc since no one will be trying to undef + * it out from underneath us. At least, I don't think + * there's a race... + */ + clonecv = cv_clone(cv); + SvREFCNT_dec(cv); /* finished with this */ + hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); + CvOWNER(clonecv) = thr; + cv = clonecv; + SvREFCNT_inc(cv); + } + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } - cv = GvCV(DBsub); - if (CvXSUB(cv)) curcopdb = curcop; - if (!cv) - DIE("No DBsub routine"); } +#endif /* USE_THREADS */ if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { @@ -1788,9 +2060,9 @@ PP(pp_entersub) 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); @@ -1808,14 +2080,20 @@ PP(pp_entersub) /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV* av = GvAV(defgv); - I32 items = AvFILL(av) + 1; + AV* av; + I32 items; +#ifdef USE_THREADS + av = (AV*)curpad[0]; +#else + av = GvAV(defgv); +#endif /* USE_THREADS */ + 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 ; } } @@ -1827,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 ) { @@ -1854,13 +2132,13 @@ PP(pp_entersub) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn - && !(perldb && cv == GvCV(DBsub))) - warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv))); - if (CvDEPTH(cv) > AvFILL(padlist)) { + && !(PERLDB_SUB && cv == GvCV(DBsub))) + sub_crush_depth(cv); + 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) { @@ -1890,23 +2168,47 @@ 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); } } - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (hasargs) { +#ifdef USE_THREADS + if (!hasargs) { AV* av = (AV*)curpad[0]; + + 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; + PUTBACK ; + } + } +#endif /* USE_THREADS */ + SAVESPTR(curpad); + curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); +#ifndef USE_THREADS + if (hasargs) +#endif /* USE_THREADS */ + { + AV* av; SV** ary; +#if 0 + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p entersub preparing @_\n", thr)); +#endif + av = (AV*)curpad[0]; if (AvREAL(av)) { av_clear(av); AvREAL_off(av); } +#ifndef USE_THREADS cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; GvAV(defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; ++MARK; if (items > AvMAX(av) + 1) { @@ -1923,7 +2225,7 @@ PP(pp_entersub) } } Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*MARK) @@ -1931,39 +2233,66 @@ PP(pp_entersub) MARK++; } } +#if 0 + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p entersub returning %p\n", thr, CvSTART(cv))); +#endif RETURNOP(CvSTART(cv)); } } +void +sub_crush_depth(CV *cv) +{ + if (CvANON(cv)) + warn("Deep recursion on anonymous subroutine"); + else { + SV* tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), Nullch); + warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); + } +} + PP(pp_aelem) { - dSP; + djSP; SV** svp; I32 elem = POPi; - AV *av = (AV*)POPs; - I32 lval = op->op_flags & OPf_MOD; + AV* av = (AV*)POPs; + U32 lval = op->op_flags & OPf_MOD; + U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); if (elem > 0) elem -= curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; - svp = av_fetch(av, elem, lval); + svp = av_fetch(av, elem, lval && !defer); if (lval) { - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); + if (!svp || *svp == &sv_undef) { + SV* lv; + if (!defer) + DIE(no_aelem, elem); + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, Nullsv, 'y', Nullch, 0); + LvTARG(lv) = SvREFCNT_inc(av); + LvTARGOFF(lv) = elem; + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } if (op->op_private & OPpLVAL_INTRO) - save_svref(svp); + save_aelem(av, elem, svp); else if (op->op_private & OPpDEREF) - provide_ref(op, *svp); + vivify_ref(*svp, op->op_private & OPpDEREF); } PUSHs(svp ? *svp : &sv_undef); RETURN; } void -provide_ref(op, sv) -OP* op; -SV* sv; +vivify_ref(SV *sv, U32 to_what) { if (SvGMAGICAL(sv)) mg_get(sv); @@ -1977,10 +2306,9 @@ SV* sv; Safefree(SvPVX(sv)); SvLEN(sv) = SvCUR(sv) = 0; } - switch (op->op_private & OPpDEREF) - { + switch (to_what) { case OPpDEREF_SV: - SvRV(sv) = newSV(0); + SvRV(sv) = NEWSV(355,0); break; case OPpDEREF_AV: SvRV(sv) = (SV*)newAV(); @@ -1996,65 +2324,77 @@ SV* sv; PP(pp_method) { - dSP; + djSP; SV* sv; SV* ob; GV* gv; - SV* nm; + HV* stash; + char* name; + char* packname; + STRLEN packlen; + + if (SvROK(TOPs)) { + sv = SvRV(TOPs); + if (SvTYPE(sv) == SVt_PVCV) { + SETs(sv); + RETURN; + } + } - nm = TOPs; + name = SvPV(TOPs, na); sv = *(stack_base + TOPMARK + 1); - gv = 0; if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; - char* packname = 0; - STRLEN packlen; + packname = Nullch; if (!SvOK(sv) || !(packname = SvPV(sv, packlen)) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - char *name = SvPV(nm, na); - HV *stash; - if (!packname || !isALPHA(*packname)) -DIE("Can't call method \"%s\" without a package or object reference", name); - if (!(stash = gv_stashpvn(packname, packlen, FALSE))) { - if (gv_stashpvn("UNIVERSAL", 9, FALSE)) - stash = gv_stashpvn(packname, packlen, TRUE); - else - DIE("Can't call method \"%s\" in empty package \"%s\"", - name, packname); - } - gv = gv_fetchmethod(stash,name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, packname); - SETs((SV*)gv); - RETURN; + if (!packname || !isIDFIRST(*packname)) + DIE("Can't call method \"%s\" without a package or object reference", name); + stash = gv_stashpvn(packname, packlen, TRUE); + goto fetch; } *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) { - char *name = SvPV(nm, na); + if (!ob || !SvOBJECT(ob)) DIE("Can't call method \"%s\" on unblessed reference", name); - } - if (!gv) { /* nothing cached */ - char *name = SvPV(nm, na); - gv = gv_fetchmethod(SvSTASH(ob),name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, HvNAME(SvSTASH(ob))); - } + stash = SvSTASH(ob); + + fetch: + gv = gv_fetchmethod(stash, name); + if (!gv) { + char* leaf = name; + char* sep = Nullch; + char* p; - SETs((SV*)gv); + for (p = name; *p; p++) { + if (*p == '\'') + sep = p, leaf = p + 1; + else if (*p == ':' && *(p + 1) == ':') + sep = p, leaf = p + 2; + } + if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { + packname = HvNAME(sep ? curcop->cop_stash : stash); + packlen = strlen(packname); + } + else { + packname = name; + packlen = sep - name; + } + DIE("Can't locate object method \"%s\" via package \"%.*s\"", + leaf, (int)packlen, packname); + } + SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; }