X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1956d76f752a9797ecccbce754f10d4693593ef9;hb=ef0a8c2a9e34cffb618d4fd6e7676362dedc9421;hp=bb7b6a6e6c35fd048a294449309406dc3ed1cffc;hpb=236988e4d25eed85df605c5aa84163a8cd5d390d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index bb7b6a6..1956d76 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-1999, 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. @@ -16,31 +16,48 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_HOT_C #include "perl.h" +#ifdef I_UNISTD +#include +#endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + +#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) + /* Hot code. */ +#ifdef USE_THREADS +static void unset_cvowner(pTHXo_ void *cvarg); +#endif /* USE_THREADS */ + PP(pp_const) { - dSP; + djSP; XPUSHs(cSVOP->op_sv); RETURN; } PP(pp_nextstate) { - curcop = (COP*)op; + PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; return NORMAL; } PP(pp_gvsv) { - dSP; - EXTEND(sp,1); - if (op->op_private & OPpLVAL_INTRO) + djSP; + EXTEND(SP,1); + if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP->op_gv)); else PUSHs(GvSV(cGVOP->op_gv)); @@ -52,15 +69,21 @@ PP(pp_null) return NORMAL; } +PP(pp_setstate) +{ + PL_curcop = (COP*)PL_op; + return NORMAL; +} + PP(pp_pushmark) { - PUSHMARK(stack_sp); + PUSHMARK(PL_stack_sp); return NORMAL; } PP(pp_stringify) { - dSP; dTARGET; + djSP; dTARGET; STRLEN len; char *s; s = SvPV(TOPs,len); @@ -71,72 +94,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")) - 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 '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 { @@ -147,57 +112,43 @@ PP(pp_and) PP(pp_sassign) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; MAGIC *mg; - if (op->op_private & OPpASSIGN_BACKWARDS) { + if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; temp = left; left = right; right = temp; } - if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || - !((mg = mg_find(left, 't')) && mg->mg_len & 1))) - { + if (PL_tainting && PL_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); + RETURNOP(cLOGOP->op_other); else - RETURNOP(cCONDOP->op_false); + RETURNOP(cLOGOP->op_next); } PP(pp_unstack) { I32 oldsave; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); return NORMAL; } -PP(pp_seq) -{ - dSP; tryAMAGICbinSET(seq,0); - { - dPOPTOPssrl; - SETs( sv_eq(left, right) ? &sv_yes : &sv_no ); - RETURN; - } -} - PP(pp_concat) { - dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; STRLEN len; @@ -208,12 +159,15 @@ PP(pp_concat) } else if (SvGMAGICAL(TARG)) mg_get(TARG); - else if (!SvOK(TARG)) { - s = SvPV_force(TARG, len); + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ + 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; } @@ -221,44 +175,58 @@ 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_HV|OPpDEREF_AV)) - provide_ref(op, curpad[op->op_targ]); + if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(PL_curpad[PL_op->op_targ]); + else if (PL_op->op_private & OPpDEREF) { + PUTBACK; + vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF); + SPAGAIN; + } } RETURN; } PP(pp_readline) { - last_in_gv = (GV*)(*stack_sp--); + tryAMAGICunTARGET(iter, 0); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) + PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); + else { + dSP; + XPUSHs((SV*)PL_last_in_gv); + PUTBACK; + pp_rv2gv(); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + } + } return do_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; - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == PERL_LONG_MAX) { - sv_setnv(TOPs, (double)(SvIVX(TOPs)) + 1.0 ); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + djSP; + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + Perl_croak(aTHX_ PL_no_modify); + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -268,7 +236,7 @@ PP(pp_preinc) PP(pp_or) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else { @@ -279,9 +247,9 @@ PP(pp_or) PP(pp_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPnnrl; + dPOPTOPnnrl_ul; SETn( left + right ); RETURN; } @@ -289,16 +257,21 @@ 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); - PUSHs(svp ? *svp : &sv_undef); + U32 lval = PL_op->op_flags & OPf_MOD; + SV** svp = av_fetch(av, PL_op->op_private, lval); + SV *sv = (svp ? *svp : &PL_sv_undef); + EXTEND(SP, 1); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } PP(pp_join) { - dSP; dMARK; dTARGET; + djSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -308,8 +281,20 @@ PP(pp_join) PP(pp_pushre) { - dSP; - XPUSHs((SV*)op); + 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(&PL_op, &LvTARGOFF(sv), 1, OP*); + XPUSHs(sv); +#else + XPUSHs((SV*)PL_op); +#endif RETURN; } @@ -317,61 +302,73 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; MAGIC *mg; + STRLEN n_a; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else - gv = defoutgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { - SV *sv; - - PUSHMARK(MARK-1); - *MARK = mg->mg_obj; + gv = PL_defoutgv; + if (mg = SvTIED_mg((SV*)gv, 'q')) { + if (MARK == ORIGMARK) { + /* If using default handle then we need to make space to + * pass object as 1st arg, so move other args up ... + */ + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + PUSHMARK(MARK - 1); + *MARK = SvTIED_obj((SV*)gv, mg); + PUTBACK; ENTER; - perl_call_method("PRINT", G_SCALAR); + 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))) { - if (dowarn) { + if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); - gv_fullname(sv,gv); - warn("Filehandle %s never opened", SvPV(sv,na)); + gv_efullname3(sv, gv, Nullch); + Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", + SvPV(sv,n_a)); } - SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (dowarn) { + if (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); - gv_fullname(sv,gv); + gv_efullname3(sv, gv, Nullch); if (IoIFP(io)) - warn("Filehandle %s opened only for input", SvPV(sv,na)); - else - warn("print on closed filehandle %s", SvPV(sv,na)); + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", + SvPV(sv,n_a)); + else if (ckWARN(WARN_CLOSED)) + Perl_warner(aTHX_ WARN_CLOSED, + "print on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; } else { MARK++; - if (ofslen) { + if (PL_ofslen) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) { + if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { MARK--; break; } @@ -388,8 +385,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (orslen) - if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp)) + if (PL_orslen) + if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -398,38 +395,37 @@ PP(pp_print) } } SP = ORIGMARK; - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); RETURN; just_say_no: SP = ORIGMARK; - PUSHs(&sv_undef); + PUSHs(&PL_sv_undef); RETURN; } PP(pp_rv2av) { - dSP; dPOPss; - + djSP; dTOPss; AV *av; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_av); + av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) - DIE("Not an ARRAY reference"); - if (op->op_private & OPpLVAL_INTRO) - av = (AV*)save_svref((SV**)sv); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + DIE(aTHX_ "Not an ARRAY reference"); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } else { if (SvTYPE(sv) == SVt_PVAV) { av = (AV*)sv; - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -438,6 +434,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -445,25 +442,39 @@ PP(pp_rv2av) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "an ARRAY"); - if (GIMME == G_ARRAY) + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_usym, "an ARRAY"); + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + if (GIMME == G_ARRAY) { + (void)POPs; RETURN; - RETPUSHUNDEF; + } + RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "an ARRAY"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); - } else { + sym = SvPV(sv,n_a); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); + if (!gv) + RETSETUNDEF; + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); + gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); + } + } + else { gv = (GV*)sv; } av = GvAVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) av = save_ary(gv); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -471,41 +482,49 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; - EXTEND(SP, maxarg); - Copy(AvARRAY(av), SP+1, maxarg, SV*); + (void)POPs; /* XXXX May be optimized away? */ + EXTEND(SP, maxarg); + if (SvRMAGICAL(av)) { + U32 i; + for (i=0; i < maxarg; i++) { + SV **svp = av_fetch(av, i, FALSE); + SP[i+1] = (svp) ? *svp : &PL_sv_undef; + } + } + else { + Copy(AvARRAY(av), SP+1, maxarg, SV*); + } SP += maxarg; } else { dTARGET; I32 maxarg = AvFILL(av) + 1; - PUSHi(maxarg); + SETi(maxarg); } RETURN; } PP(pp_rv2hv) { - - dSP; dTOPss; - + djSP; dTOPss; HV *hv; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_hv); + hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) - DIE("Not a HASH reference"); - if (op->op_private & OPpLVAL_INTRO) - hv = (HV*)save_svref((SV**)sv); - if (op->op_flags & OPf_REF) { + if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) + DIE(aTHX_ "Not a HASH reference"); + if (PL_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) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -515,6 +534,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -522,26 +542,38 @@ PP(pp_rv2hv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a HASH"); + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_usym, "a HASH"); + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a HASH"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); - } else { + sym = SvPV(sv,n_a); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); + if (!gv) + RETSETUNDEF; + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "a HASH"); + gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); + } + } + else { gv = (GV*)sv; } hv = GvHVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) hv = save_hash(gv); - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -549,17 +581,19 @@ PP(pp_rv2hv) } if (GIMME == G_ARRAY) { /* array wanted */ - *stack_sp = (SV*)hv; - return do_kv(ARGS); + *PL_stack_sp = (SV*)hv; + return do_kv(); } else { dTARGET; - if (HvFILL(hv)) { - sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1); - sv_setpv(TARG, buf); - } + if (SvTYPE(hv) == SVt_PVAV) + hv = avhv_keys((AV*)hv); + if (HvFILL(hv)) + Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld", + (long)HvFILL(hv), (long)HvMAX(hv) + 1); else sv_setiv(TARG, 0); + SETTARG; RETURN; } @@ -567,10 +601,10 @@ PP(pp_rv2hv) PP(pp_aassign) { - dSP; - SV **lastlelem = stack_sp; - SV **lastrelem = stack_base + POPMARK; - SV **firstrelem = stack_base + POPMARK + 1; + djSP; + SV **lastlelem = PL_stack_sp; + SV **lastrelem = PL_stack_base + POPMARK; + SV **firstrelem = PL_stack_base + POPMARK + 1; SV **firstlelem = lastrelem + 1; register SV **relem; @@ -579,21 +613,25 @@ PP(pp_aassign) register SV *sv; register AV *ary; + I32 gimme; HV *hash; I32 i; int magic; - delaymagic = DM_DELAY; /* catch simultaneous items */ + PL_delaymagic = DM_DELAY; /* catch simultaneous items */ /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (op->op_private & OPpASSIGN_COMMON) { + if (PL_op->op_private & OPpASSIGN_COMMON) { + EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { /*SUPPRESS 560*/ - if (sv = *relem) + if (sv = *relem) { + TAINT_NOT; /* Each item is independent */ *relem = sv_mortalcopy(sv); + } } } @@ -602,7 +640,7 @@ PP(pp_aassign) ary = Null(AV*); hash = Null(HV*); while (lelem <= lastlelem) { - tainted = 0; /* Each item stands on its own, taintwise. */ + TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; switch (SvTYPE(sv)) { case SVt_PVAV: @@ -610,16 +648,22 @@ 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); - tainted = 0; + didstore = av_store(ary,i++,sv); + if (magic) { + if (SvSMAGICAL(sv)) + mg_set(sv); + if (!didstore) + sv_2mortal(sv); + } + TAINT_NOT; } break; case SVt_PVHV: { @@ -630,233 +674,261 @@ PP(pp_aassign) hv_clear(hash); while (relem < lastrelem) { /* gobble up all the rest */ - STRLEN len; + HE *didstore; if (*relem) sv = *(relem++); else - sv = &sv_no, relem++; + sv = &PL_sv_no, relem++; tmpstr = NEWSV(29,0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; - (void)hv_store_ent(hash,sv,tmpstr,0); - if (magic) - mg_set(tmpstr); - tainted = 0; + didstore = hv_store_ent(hash,sv,tmpstr,0); + if (magic) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + TAINT_NOT; + } + if (relem == lastrelem) { + if (*relem) { + HE *didstore; + if (ckWARN(WARN_UNSAFE)) { + if (relem == firstrelem && + SvROK(*relem) && + ( SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) + Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected"); + else + Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); + } + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (magic) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + TAINT_NOT; + } + relem++; } - if (relem == lastrelem) - warn("Odd number of elements in hash list"); } break; default: - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) { - if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no) - DIE(no_modify); - if (relem <= lastrelem) - relem++; - break; - } - if (SvROK(sv)) - sv_unref(sv); + if (SvIMMORTAL(sv)) { + if (relem <= lastrelem) + relem++; + break; } if (relem <= lastrelem) { sv_setsv(sv, *relem); *(relem++) = sv; } else - sv_setsv(sv, &sv_undef); + sv_setsv(sv, &PL_sv_undef); SvSETMAGIC(sv); break; } } - if (delaymagic & ~DM_DELAY) { - if (delaymagic & DM_UID) { + if (PL_delaymagic & ~DM_DELAY) { + if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid(uid,euid,(Uid_t)-1); + (void)setresuid(PL_uid,PL_euid,(Uid_t)-1); #else # ifdef HAS_SETREUID - (void)setreuid(uid,euid); + (void)setreuid(PL_uid,PL_euid); # else # ifdef HAS_SETRUID - if ((delaymagic & DM_UID) == DM_RUID) { - (void)setruid(uid); - delaymagic &= ~DM_RUID; + if ((PL_delaymagic & DM_UID) == DM_RUID) { + (void)setruid(PL_uid); + PL_delaymagic &= ~DM_RUID; } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID - if ((delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(uid); - delaymagic &= ~DM_EUID; + if ((PL_delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(PL_uid); + PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ - if (delaymagic & DM_UID) { - if (uid != euid) - DIE("No setreuid available"); - (void)setuid(uid); + if (PL_delaymagic & DM_UID) { + if (PL_uid != PL_euid) + DIE(aTHX_ "No setreuid available"); + (void)PerlProc_setuid(PL_uid); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ - uid = (int)getuid(); - euid = (int)geteuid(); + PL_uid = (int)PerlProc_getuid(); + PL_euid = (int)PerlProc_geteuid(); } - if (delaymagic & DM_GID) { + if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid(gid,egid,(Gid_t)-1); + (void)setresgid(PL_gid,PL_egid,(Gid_t)-1); #else # ifdef HAS_SETREGID - (void)setregid(gid,egid); + (void)setregid(PL_gid,PL_egid); # else # ifdef HAS_SETRGID - if ((delaymagic & DM_GID) == DM_RGID) { - (void)setrgid(gid); - delaymagic &= ~DM_RGID; + if ((PL_delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(PL_gid); + PL_delaymagic &= ~DM_RGID; } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID - if ((delaymagic & DM_GID) == DM_EGID) { - (void)setegid(gid); - delaymagic &= ~DM_EGID; + if ((PL_delaymagic & DM_GID) == DM_EGID) { + (void)setegid(PL_gid); + PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ - if (delaymagic & DM_GID) { - if (gid != egid) - DIE("No setregid available"); - (void)setgid(gid); + if (PL_delaymagic & DM_GID) { + if (PL_gid != PL_egid) + DIE(aTHX_ "No setregid available"); + (void)PerlProc_setgid(PL_gid); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ - gid = (int)getgid(); - egid = (int)getegid(); + PL_gid = (int)PerlProc_getgid(); + PL_egid = (int)PerlProc_getegid(); } - tainting |= (uid && (euid != uid || egid != gid)); + PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } - delaymagic = 0; - if (GIMME == G_ARRAY) { + PL_delaymagic = 0; + + 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 SP = firstrelem + (lastlelem - firstlelem); - RETURN; - } - else { - dTARGET; - SP = firstrelem; - - SETi(lastrelem - firstrelem + 1); - RETURN; + lelem = firstlelem + (relem - firstrelem); + while (relem <= SP) + *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } + RETURN; +} + +PP(pp_qr) +{ + djSP; + register PMOP *pm = cPMOP; + SV *rv = sv_newmortal(); + SV *sv = newSVrv(rv, "Regexp"); + sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); + RETURNX(PUSHs(rv)); } PP(pp_match) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; char *strend; I32 global; - I32 safebase; - char *truebase; + I32 r_flags = REXEC_CHECKED; + char *truebase; /* Start of string */ register REGEXP *rx = pm->op_pmregexp; + bool rxtainted; I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; + I32 update_minmatch = 1; + I32 had_zerolen = 0; - if (op->op_flags & OPf_STACKED) + if (PL_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"); + DIE(aTHX_ "panic: do_match"); + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { + failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; } - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } + if (rx->minlen > len) goto failure; + truebase = t = s; + + /* XXXX What part of this is needed with true \G-support? */ if (global = pm->op_pmflags & PMf_GLOBAL) { - rx->startp[0] = 0; + rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg && mg->mg_len >= 0) { - rx->endp[0] = rx->startp[0] = s + mg->mg_len; + if (!(rx->reganch & ROPT_GPOS_SEEN)) + rx->endp[0] = rx->startp[0] = mg->mg_len; + else if (rx->reganch & ROPT_ANCH_GPOS) { + r_flags |= REXEC_IGNOREPOS; + rx->endp[0] = rx->startp[0] = 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; + if ((gimme != G_ARRAY && !global && rx->nparens) + || SvTEMP(TARG) || PL_sawampersand) + r_flags |= REXEC_COPY_STR; + if (SvSCREAM(TARG)) + r_flags |= REXEC_SCREAM; + if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } play_it_again: - if (global && rx->startp[0]) { - t = s = rx->endp[0]; - if (s > strend) + if (global && rx->startp[0] != -1) { + t = s = rx->endp[0] + truebase; + if ((s + rx->minlen) > strend) goto nope; - 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) - goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) - goto nope; - else if (pm->op_pmflags & PMf_ALL) - goto yup; - } - else if (!(s = fbm_instr((unsigned char*)s, - (unsigned char*)strend, pm->op_pmshort))) - goto nope; - else if (pm->op_pmflags & PMf_ALL) - goto yup; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < t) - s = t; - } - else - s = t; - } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - memcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; - } - } - if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ - } + if (update_minmatch++) + minmatch = had_zerolen; } - if (pregexec(rx, s, strend, truebase, minmatch, - SvSCREAM(TARG) ? TARG : Nullsv, - safebase)) { - curpm = pm; + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; + } + if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) + { + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -864,6 +936,9 @@ play_it_again: /*NOTREACHED*/ gotcha: + if (rxtainted) + RX_MATCH_TAINTED_on(rx); + TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; @@ -872,21 +947,27 @@ 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++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ - if ((s = rx->startp[i]) && rx->endp[i] ) { - len = rx->endp[i] - s; + if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { + len = rx->endp[i] - rx->startp[i]; + s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); } } if (global) { - truebase = rx->subbeg; - if (rx->startp[0] && rx->startp[0] == rx->endp[0]) - ++rx->endp[0]; + had_zerolen = (rx->startp[0] != -1 + && rx->startp[0] == rx->endp[0]); + PUTBACK; /* EVAL blocks may use stack */ + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } + else if (!iters) + XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; } @@ -899,52 +980,55 @@ play_it_again: sv_magic(TARG, (SV*)0, 'g', Nullch, 0); mg = mg_find(TARG, 'g'); } - if (rx->startp[0]) { - mg->mg_len = rx->endp[0] - truebase; + if (rx->startp[0] != -1) { + mg->mg_len = rx->endp[0]; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } - else - mg->mg_len = -1; } LEAVE_SCOPE(oldsave); RETPUSHYES; } -yup: - ++BmUSEFUL(pm->op_pmshort); - curpm = pm; +yup: /* Confirmed by INTUIT */ + if (rxtainted) + RX_MATCH_TAINTED_on(rx); + TAINT_IF(RX_MATCH_TAINTED(rx)); + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; + if (RX_MATCH_COPIED(rx)) + Safefree(rx->subbeg); + RX_MATCH_COPIED_off(rx); + rx->subbeg = Nullch; if (global) { rx->subbeg = truebase; - rx->subend = strend; - rx->startp[0] = s; - rx->endp[0] = s + SvCUR(pm->op_pmshort); + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; + rx->sublen = strend - truebase; goto gotcha; - } - if (sawampersand) { - char *tmps; + } + if (PL_sawampersand) { + I32 off; - if (rx->subbase) - Safefree(rx->subbase); - tmps = rx->subbase = savepvn(t, strend-t); - rx->subbeg = tmps; - rx->subend = tmps + (strend-t); - tmps = rx->startp[0] = tmps + (s - t); - rx->endp[0] = tmps + SvCUR(pm->op_pmshort); + rx->subbeg = savepvn(t, strend - t); + rx->sublen = strend - t; + RX_MATCH_COPIED_on(rx); + off = rx->startp[0] = s - t; + rx->endp[0] = off + rx->minlen; + } + else { /* startp/endp are used by @- @+. */ + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; } LEAVE_SCOPE(oldsave); RETPUSHYES; nope: - if (pm->op_pmshort) - ++BmUSEFUL(pm->op_pmshort); - ret_no: - if (global) { + if (global && !(pm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg) @@ -958,16 +1042,30 @@ ret_no: } OP * -do_readline() +Perl_do_readline(pTHX) { dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; - register IO *io = GvIO(last_in_gv); - register I32 type = op->op_type; + register IO *io = GvIO(PL_last_in_gv); + register I32 type = PL_op->op_type; + I32 gimme = GIMME_V; + MAGIC *mg; + if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); + PUTBACK; + ENTER; + call_method("READLINE", gimme); + LEAVE; + SPAGAIN; + if (gimme == G_SCALAR) + SvSetMagicSV_nosteal(TARG, TOPs); + RETURN; + } fp = Nullfp; if (io) { fp = IoIFP(io); @@ -976,14 +1074,17 @@ do_readline() if (IoFLAGS(io) & IOf_START) { IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; - if (av_len(GvAVn(last_in_gv)) < 0) { - SV *tmpstr = newSVpv("-", 1); /* assume stdin */ - av_push(GvAVn(last_in_gv), tmpstr); + if (av_len(GvAVn(PL_last_in_gv)) < 0) { + do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); + sv_setpvn(GvSV(PL_last_in_gv), "-", 1); + SvSETMAGIC(GvSV(PL_last_in_gv)); + fp = IoIFP(io); + goto have_fp; } } - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(last_in_gv, FALSE); /* now it does*/ + (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ IoFLAGS(io) |= IOf_START; } } @@ -1017,7 +1118,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; @@ -1035,7 +1136,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)) { @@ -1044,7 +1148,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 { @@ -1068,6 +1172,7 @@ do_readline() PerlIO_rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ } } } @@ -1078,13 +1183,18 @@ 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) - sv_setpvn(tmpcmd, cshname, cshlen); + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, "' 2>/dev/null |"); @@ -1098,8 +1208,8 @@ do_readline() #endif #endif /* !CSH */ #endif /* !DOSISH */ - (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, 0, 0, Nullfp); + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); #endif /* !VMS */ LEAVE; @@ -1107,22 +1217,41 @@ do_readline() } else if (type == OP_GLOB) SP--; + else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ + && (IoTYPE(io) == '>' || fp == PerlIO_stdout() + || fp == PerlIO_stderr())) + { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", + SvPV_nolen(sv)); + } } if (!fp) { - if (dowarn && io && !(IoFLAGS(io) & IOf_START)) - warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); - if (GIMME == G_SCALAR) { + if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (type == OP_GLOB) + Perl_warner(aTHX_ WARN_CLOSED, + "glob failed (can't start child: %s)", + Strerror(errno)); + else { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_CLOSED, + "Read on closed filehandle %s", + SvPV_nolen(sv)); + } + } + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } - if (GIMME == G_ARRAY) { - sv = sv_2mortal(NEWSV(57, 80)); - offset = 0; - } - else { + have_fp: + 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) @@ -1132,37 +1261,58 @@ do_readline() else offset = 0; } + else { + sv = sv_2mortal(NEWSV(57, 80)); + offset = 0; + } + +/* flip-flop EOF state for a snarfed empty file */ +#define SNARF_EOF(gimme,rs,io,sv) \ + ((gimme != G_SCALAR || SvCUR(sv) \ + || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \ + ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \ + : ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + for (;;) { - if (!sv_gets(sv, fp, offset)) { + if (!sv_gets(sv, fp, offset) + && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) + { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (fp) continue; - (void)do_close(last_in_gv, FALSE); + (void)do_close(PL_last_in_gv, FALSE); IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - (void)do_close(last_in_gv, FALSE); + if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { + Perl_warner(aTHX_ WARN_CLOSED, + "glob failed (child exited with status %d%s)", + STATUS_CURRENT >> 8, + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } } - if (GIMME == G_SCALAR) { + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } + /* This should not be marked tainted if the fp is marked clean */ + if (!(IoFLAGS(io) & IOf_UNTAINT)) { + TAINT; + SvTAINTED_on(sv); + } IoLINES(io)++; + SvSETMAGIC(sv); XPUSHs(sv); - if (tainting) { - tainted = TRUE; - SvTAINT(sv); /* Anything from the outside world...*/ - } if (type == OP_GLOB) { char *tmps; - if (SvCUR(sv) > 0 && SvCUR(rs) > 0) { + if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX(rs)) { + if (*tmps == *SvPVX(PL_rs)) { *tmps = '\0'; SvCUR(sv)--; } @@ -1171,12 +1321,12 @@ do_readline() if (!isALPHA(*tmps) && !isDIGIT(*tmps) && strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) break; - if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) { + if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_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); @@ -1184,7 +1334,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); @@ -1198,101 +1348,138 @@ do_readline() PP(pp_enter) { - dSP; - register CONTEXT *cx; - I32 gimme; + djSP; + register PERL_CONTEXT *cx; + I32 gimme = OP_GIMME(PL_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; - SV** svp; + djSP; HE* he; + SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - I32 lval = op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD; + U32 defer = PL_op->op_private & OPpLVAL_DEFER; + SV *sv; - 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) { + if (PL_op->op_private & OPpLVAL_INTRO) + DIE(aTHX_ "Can't localize pseudo-hash element"); + 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 (op->op_private & OPpLVAL_INTRO) - save_svref(&HeVAL(he)); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, HeVAL(he)); - } - PUSHs(he ? HeVAL(he) : &sv_undef); + if (!svp || *svp == &PL_sv_undef) { + SV* lv; + SV* key2; + if (!defer) { + STRLEN n_a; + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + } + 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 (PL_op->op_private & OPpLVAL_INTRO) { + if (HvNAME(hv) && isGV(*svp)) + save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); + else + save_helem(hv, keysv, svp); + } + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); + } + sv = (svp ? *svp : &PL_sv_undef); + /* This makes C possible. + * Pushing the magical RHS on to the stack is useless, since + * that magic is soon destined to be misled by the local(), + * and thus the later pp_sassign() will fail to mg_get() the + * old value. This should also cure problems with delayed + * mg_get()s. GSAR 98-07-03 */ + if (!lval && SvGMAGICAL(sv)) + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } PP(pp_leave) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = curpm; /* fake block should preserve $1 et al */ + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ } POPBLOCK(cx,newpm); - 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(PL_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 = &PL_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 */ + PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; @@ -1301,35 +1488,111 @@ PP(pp_leave) PP(pp_iter) { - dSP; - register CONTEXT *cx; - SV *sv; + 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"); + if (CxTYPE(cx) != CXt_LOOP) + DIE(aTHX_ "panic: pp_iter"); + av = cx->blk_loop.iterary; - if (av == curstack && cx->blk_loop.iterix >= cx->blk_oldsp) - RETPUSHNO; + if (SvTYPE(av) != SVt_PVAV) { + /* iterate ($min .. $max) */ + if (cx->blk_loop.iterlval) { + /* string increment */ + register SV* cur = cx->blk_loop.iterlval; + STRLEN maxlen; + char *max = SvPV((SV*)av, maxlen); + if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { + /* safe to reuse old SV */ + sv_setsv(*cx->blk_loop.itervar, cur); + } + else +#endif + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as + * they used to */ + SvREFCNT_dec(*cx->blk_loop.itervar); + *cx->blk_loop.itervar = newSVsv(cur); + } + if (strEQ(SvPVX(cur), max)) + sv_setiv(cur, 0); /* terminate next time */ + else + sv_inc(cur); + RETPUSHYES; + } + RETPUSHNO; + } + /* integer increment */ + if (cx->blk_loop.iterix > cx->blk_loop.itermax) + RETPUSHNO; + +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { + /* safe to reuse old SV */ + sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); + } + else +#endif + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as they + * used to */ + SvREFCNT_dec(*cx->blk_loop.itervar); + *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++); + } + RETPUSHYES; + } - if (cx->blk_loop.iterix >= AvFILL(av)) + /* iterate array */ + if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) { + SvREFCNT_dec(*cx->blk_loop.itervar); + + if (sv = (SvMAGICAL(av)) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + : AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); - *cx->blk_loop.itervar = sv; - } else - *cx->blk_loop.itervar = &sv_undef; + sv = &PL_sv_undef; + if (av != PL_curstack && SvIMMORTAL(sv)) { + SV *lv = cx->blk_loop.iterlval; + if (lv && SvREFCNT(lv) > 1) { + SvREFCNT_dec(lv); + lv = Nullsv; + } + if (lv) + SvREFCNT_dec(LvTARG(lv)); + else { + lv = cx->blk_loop.iterlval = NEWSV(26, 0); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, Nullsv, 'y', Nullch, 0); + } + LvTARG(lv) = SvREFCNT_inc(av); + LvTARGOFF(lv) = cx->blk_loop.iterix; + LvTARGLEN(lv) = (UV) -1; + sv = (SV*)lv; + } + *cx->blk_loop.itervar = SvREFCNT_inc(sv); RETPUSHYES; } PP(pp_subst) { - dSP; dTARG; + djSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1343,223 +1606,221 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; + bool rxtainted; char *orig; - I32 safebase; + I32 r_flags; register REGEXP *rx = pm->op_pmregexp; STRLEN len; int force_on_match = 0; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; + I32 update_minmatch = 1; - if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ - dstr = POPs; - if (op->op_flags & OPf_STACKED) + /* known replacement string? */ + dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; + if (PL_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)))) + Perl_croak(aTHX_ PL_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 = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + if (PL_tainted) + rxtainted |= 2; + TAINT_NOT; force_it: if (!pm || !s) - DIE("panic: do_subst"); + DIE(aTHX_ "panic: do_subst"); strend = s + len; - maxiters = (strend - s) + 10; + maxiters = 2*(strend - s) + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } - safebase = ((!rx || !rx->nparens) && !sawampersand); + r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; + if (SvSCREAM(TARG)) + r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } orig = m = s; - if (pm->op_pmshort) { - if (pm->op_pmflags & PMf_SCANFIRST) { - if (SvSCREAM(TARG)) { - if (screamfirst[BmRARE(pm->op_pmshort)] < 0) - goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) - goto nope; + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + /* How to do it in subst? */ +/* if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; +*/ + } + + /* only replace once? */ + once = !(rpm->op_pmflags & PMf_GLOBAL); + + /* known replacement string? */ + c = dstr ? SvPV(dstr, clen) : Nullch; + + /* can do inplace substitution? */ + if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) + && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { + if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { + SPAGAIN; + PUSHs(&PL_sv_no); + LEAVE_SCOPE(oldsave); + RETURN; + } + if (force_on_match) { + force_on_match = 0; + s = SvPV_force(TARG, len); + goto force_it; + } + d = s; + PL_curpm = pm; + SvSCREAM_off(TARG); /* disable possible screamer */ + if (once) { + rxtainted |= RX_MATCH_TAINTED(rx); + m = orig + rx->startp[0]; + d = orig + rx->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + SvCUR_set(TARG, m - s); + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + sv_chop(TARG, d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); } - else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend, - pm->op_pmshort))) - goto nope; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < m) - s = m; + else if (clen) { + d -= clen; + sv_chop(TARG, d); + Copy(c, d, clen, char); } - else - s = m; - } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - memcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; + else { + sv_chop(TARG, d); } + TAINT_IF(rxtainted & 1); + SPAGAIN; + PUSHs(&PL_sv_yes); } - if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ - } - } - once = !(rpm->op_pmflags & PMf_GLOBAL); - if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */ - c = SvPV(dstr, clen); - if (clen <= rx->minlen) { - /* can do inplace substitution */ - if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - if (force_on_match) { - force_on_match = 0; - 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) { - m = rx->startp[0]; - d = rx->endp[0]; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ - d -= clen; - m = d; - sv_chop(TARG, d-i); - s += i; - while (i--) - *--d = *--s; - if (clen) - Copy(c, m, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else if (clen) { - d -= clen; - sv_chop(TARG, d); - Copy(c, d, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else { - sv_chop(TARG, d); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /* NOTREACHED */ + else { + do { + if (iters++ > maxiters) + DIE(aTHX_ "Substitution loop"); + rxtainted |= RX_MATCH_TAINTED(rx); + m = rx->startp[0] + orig; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s, d, i, char); + d += i; } - do { - if (iters++ > maxiters) - DIE("Substitution loop"); - m = rx->startp[0]; - /*SUPPRESS 560*/ - if (i = m - s) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = rx->endp[0]; - } while (pregexec(rx, s, strend, orig, s == m, - Nullsv, TRUE)); /* (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 Null */ + if (clen) { + Copy(c, d, clen, char); + d += clen; } - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); - LEAVE_SCOPE(oldsave); - RETURN; + s = rx->endp[0] + orig; + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, + /* don't match same null twice */ + REXEC_NOT_FIRST|REXEC_IGNOREPOS)); + if (s != d) { + i = strend - s; + SvCUR_set(TARG, d - SvPVX(TARG) + i); + Move(s, d, i+1, char); /* include the NUL */ } - PUSHs(&sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + TAINT_IF(rxtainted & 1); + SPAGAIN; + PUSHs(sv_2mortal(newSViv((I32)iters))); } + (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); + if (SvSMAGICAL(TARG)) { + PUTBACK; + mg_set(TARG); + SPAGAIN; + } + SvTAINT(TARG); + LEAVE_SCOPE(oldsave); + RETURN; } - else - c = Nullch; - if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - long_way: + + if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); goto force_it; } - dstr = NEWSV(25, sv_len(TARG)); + rxtainted |= RX_MATCH_TAINTED(rx); + dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); - curpm = pm; + PL_curpm = pm; if (!c) { - register CONTEXT *cx; + register PERL_CONTEXT *cx; + SPAGAIN; PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; do { if (iters++ > maxiters) - DIE("Substitution loop"); - if (rx->subbase && rx->subbase != orig) { + DIE(aTHX_ "Substitution loop"); + rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - orig = rx->subbase; + orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0]; + m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); - s = rx->endp[0]; + s = rx->endp[0] + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) break; - } while (pregexec(rx, s, strend, orig, s == m, Nullsv, - safebase)); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -1570,58 +1831,63 @@ 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); - 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); - PUSHs(&sv_no); +ret_no: + SPAGAIN; + PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } PP(pp_grepwhile) { - dSP; + djSP; if (SvTRUEx(POPs)) - stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; - ++*markstack_ptr; + PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; + ++*PL_markstack_ptr; LEAVE; /* exit inner scope */ /* All done yet? */ - if (stack_base + *markstack_ptr > sp) { + if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; + I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ - items = --*markstack_ptr - markstack_ptr[-1]; + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ - SP = stack_base + POPMARK; /* pop original mark */ - if (GIMME != G_ARRAY) { + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); - RETURN; } - SP += items; + else if (gimme == G_ARRAY) + SP += items; RETURN; } else { SV *src; ENTER; /* enter inner scope */ - SAVESPTR(curpm); + SAVESPTR(PL_curpm); - src = stack_base[*markstack_ptr]; + src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -1629,89 +1895,149 @@ 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); - else { - MEXTEND(mark,0); - *MARK = &sv_undef; + 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 = &PL_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 @_ ... */ + PL_curpm = newpm; /* ... and pop $1 et al */ - if (cx->blk_sub.hasargs) { /* You don't exist; go away. */ - AV* av = cx->blk_sub.argarray; + LEAVE; + return pop_return(); +} - av_clear(av); - AvREAL_off(av); +STATIC CV * +S_get_db_sub(pTHX_ SV **svp, CV *cv) +{ + dTHR; + SV *dbsv = GvSV(PL_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 { + 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)) + PL_curcopdb = PL_curcop; + cv = GvCV(PL_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; - I32 hasargs = (op->op_flags & OPf_STACKED) != 0; + bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); switch (SvTYPE(sv)) { default: if (!SvROK(sv)) { char *sym; + STRLEN n_a; - if (sv == &sv_yes) /* unfound import, ignore */ + if (sv == &PL_sv_yes) { /* unfound import, ignore */ + if (hasargs) + SP = PL_stack_base + POPMARK; RETURN; - if (!SvOK(sv)) - 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); + } + if (SvGMAGICAL(sv)) { + mg_get(sv); + sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; + } + else + sym = SvPV(sv, n_a); + if (!sym) + DIE(aTHX_ PL_no_usym, "a subroutine"); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "a subroutine"); + cv = get_cv(sym, TRUE); break; } + { + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); case SVt_PVCV: cv = (CV*)sv; break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); + if (!(cv = GvCVu((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, FALSE); + if (!cv) { + ENTER; + SAVETMPS; + goto try_autoload; + } break; } @@ -1719,74 +2045,199 @@ PP(pp_entersub) SAVETMPS; 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(aTHX_ "Undefined subroutine called"); + + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + } + /* should call AUTOLOAD now? */ + else { +try_autoload: + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + FALSE))) + { + cv = GvCV(autogv); } - tmpstr = sv_newmortal(); - gv_efullname(tmpstr, gv); - 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 */ - if (tainting) - sv_unmagic(GvSV(CvGV(cv)), 't'); - goto retry; + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name)); } - else - DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); } - DIE("Undefined subroutine called"); + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; } - gimme = GIMME; - if ((op->op_private & OPpENTERSUB_DB)) { - sv = GvSV(DBsub); - save_item(sv); - gv = CvGV(cv); - if ( CvFLAGS(cv) & (CVf_ANON | CVf_CLONED) - || strEQ(GvNAME(gv), "END") ) { - /* GV is potentially non-unique */ - sv_setsv(sv, newRV((SV*)cv)); + gimme = GIMME_V; + if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { + cv = get_db_sub(&sv, cv); + if (!cv) + DIE(aTHX_ "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 > PL_stack_base + TOPMARK) + sv = *(PL_stack_base + TOPMARK + 1); + else { + AV *av = (AV*)PL_curpad[0]; + if (hasargs || !av || AvFILLp(av) < 0 + || !(sv = AvARRAY(av)[0])) + { + MUTEX_UNLOCK(CvMUTEXP(cv)); + Perl_croak(aTHX_ "no argument for locked method call"); + } + } + if (SvROK(sv)) + sv = SvRV(sv); + else { + STRLEN len; + char *stashname = SvPV(sv, len); + sv = (SV*)gv_stashpvn(stashname, len, TRUE); + } } else { - gv_efullname(sv,gv); + sv = (SV*)cv; } - cv = GvCV(DBsub); - if (CvXSUB(cv)) curcopdb = curcop; - if (!cv) - DIE("No DBsub routine"); + 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_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", + thr, sv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); + SAVEDESTRUCTOR(Perl_unlock_condpair, sv); + } + MUTEX_LOCK(CvMUTEXP(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 ((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_S(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 { + /* (2) => grab ownership of cv. (3) => make clone */ + if (!CvOWNER(cv)) { + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), + "entersub: %p grabbing %p:%s in stash %s\n", + thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? + HvNAME(CvSTASH(cv)) : "(none)")); + } else { + /* Make a new clone. */ + CV *clonecv; + SvREFCNT_inc(cv); /* don't let it vanish from under us */ + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_S((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_S(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + } + } +#endif /* USE_THREADS */ if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { - I32 (*fp3)_((int,int,int)); + 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); + PL_stack_sp = mark + 1; + fp3 = (I32(*)(int,int,int)))CvXSUB(cv; items = (*fp3)(CvXSUBANY(cv).any_i32, - MARK - stack_base + 1, + MARK - PL_stack_base + 1, items); - stack_sp = stack_base + items; + PL_stack_sp = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { I32 markix = TOPMARK; PUTBACK; @@ -1795,34 +2246,39 @@ 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*)PL_curpad[0]; +#else + av = GvAV(PL_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 ; } } - if (curcopdb) { /* We assume that the first - XSUB in &DB::sub is the - called one. */ - SAVESPTR(curcop); - curcop = curcopdb; - curcopdb = NULL; + /* We assume first XSUB in &DB::sub is the called one. */ + if (PL_curcopdb) { + SAVESPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(cv); + (void)(*CvXSUB(cv))(aTHXo_ cv); /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) { - if (markix > stack_sp - stack_base) - *(stack_base + markix) = &sv_undef; + if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { + if (markix > PL_stack_sp - PL_stack_base) + *(PL_stack_base + markix) = &PL_sv_undef; else - *(stack_base + markix) = *stack_sp; - stack_sp = stack_base + markix; + *(PL_stack_base + markix) = *PL_stack_sp; + PL_stack_sp = PL_stack_base + markix; } } LEAVE; @@ -1833,27 +2289,31 @@ PP(pp_entersub) register I32 items = SP - MARK; AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); - push_return(op->op_next); + push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); CvDEPTH(cv)++; + /* XXX This would be a natural place to set C so + * that eval'' ops within this sub know the correct lexical space. + * Owing the speed considerations, we choose to search for the cv + * in doeval() instead. + */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(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) { + if (svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */ - av_store(newpad, ix, - SvREFCNT_inc(oldpad[ix]) ); + if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ + || *name == '&') /* anonymous code? */ + { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); } else { /* our own lexical */ if (*name == '@') @@ -1875,23 +2335,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) { - AV* av = (AV*)curpad[0]; +#ifdef USE_THREADS + if (!hasargs) { + AV* av = (AV*)PL_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(PL_curpad); + PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); +#ifndef USE_THREADS + if (hasargs) +#endif /* USE_THREADS */ + { + AV* av; SV** ary; +#if 0 + DEBUG_S(PerlIO_printf(PerlIO_stderr(), + "%p entersub preparing @_\n", thr)); +#endif + av = (AV*)PL_curpad[0]; if (AvREAL(av)) { av_clear(av); AvREAL_off(av); } - cx->blk_sub.savearray = GvAV(defgv); +#ifndef USE_THREADS + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; ++MARK; if (items > AvMAX(av) + 1) { @@ -1908,7 +2392,7 @@ PP(pp_entersub) } } Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*MARK) @@ -1916,48 +2400,102 @@ PP(pp_entersub) MARK++; } } + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) + && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + sub_crush_depth(cv); +#if 0 + DEBUG_S(PerlIO_printf(PerlIO_stderr(), + "%p entersub returning %p\n", thr, CvSTART(cv))); +#endif RETURNOP(CvSTART(cv)); } } +void +Perl_sub_crush_depth(pTHX_ CV *cv) +{ + if (CvANON(cv)) + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine"); + else { + SV* tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), Nullch); + Perl_warner(aTHX_ WARN_RECURSION, "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 = PL_op->op_flags & OPf_MOD; + U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + SV *sv; if (elem > 0) - elem -= curcop->cop_arybase; + elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; - svp = av_fetch(av, elem, lval); + svp = av_fetch(av, elem, lval && !defer); if (lval) { - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); - if (op->op_private & OPpLVAL_INTRO) - save_svref(svp); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, *svp); - } - PUSHs(svp ? *svp : &sv_undef); + if (!svp || *svp == &PL_sv_undef) { + SV* lv; + if (!defer) + DIE(aTHX_ PL_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 (PL_op->op_private & OPpLVAL_INTRO) + save_aelem(av, elem, svp); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); + } + sv = (svp ? *svp : &PL_sv_undef); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } void -provide_ref(op, sv) -OP* op; -SV* sv; +Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { if (SvGMAGICAL(sv)) mg_get(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) - croak(no_modify); - (void)SvUPGRADE(sv, SVt_RV); - SvRV(sv) = (op->op_private & OPpDEREF_HV ? - (SV*)newHV() : (SV*)newAV()); + Perl_croak(aTHX_ PL_no_modify); + if (SvTYPE(sv) < SVt_RV) + sv_upgrade(sv, SVt_RV); + else if (SvTYPE(sv) >= SVt_PV) { + (void)SvOOK_off(sv); + Safefree(SvPVX(sv)); + SvLEN(sv) = SvCUR(sv) = 0; + } + switch (to_what) { + case OPpDEREF_SV: + SvRV(sv) = NEWSV(355,0); + break; + case OPpDEREF_AV: + SvRV(sv) = (SV*)newAV(); + break; + case OPpDEREF_HV: + SvRV(sv) = (SV*)newHV(); + break; + } SvROK_on(sv); SvSETMAGIC(sv); } @@ -1965,65 +2503,139 @@ SV* sv; PP(pp_method) { - dSP; + djSP; + SV* sv = TOPs; + + if (SvROK(sv)) { + SV* rsv = SvRV(sv); + if (SvTYPE(rsv) == SVt_PVCV) { + SETs(rsv); + RETURN; + } + } + + SETs(method_common(sv, Null(U32*))); + RETURN; +} + +PP(pp_method_named) +{ + djSP; + SV* sv = cSVOP->op_sv; + U32 hash = SvUVX(sv); + + XPUSHs(method_common(sv, &hash)); + RETURN; +} + +STATIC SV * +S_method_common(pTHX_ SV* meth, U32* hashp) +{ + djSP; SV* sv; SV* ob; GV* gv; - SV* nm; + HV* stash; + char* name; + STRLEN namelen; + char* packname; + STRLEN packlen; + + name = SvPV(meth, namelen); + sv = *(PL_stack_base + TOPMARK + 1); - nm = TOPs; - 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); + if (!packname || + ((*(U8*)packname >= 0xc0 && IN_UTF8) + ? !isIDFIRST_utf8((U8*)packname) + : !isIDFIRST(*packname) + )) + { + Perl_croak(aTHX_ "Can't call method \"%s\" %s", name, + SvOK(sv) ? "without a package or object reference" + : "on an undefined value"); } - gv = gv_fetchmethod(stash,name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, packname); - SETs((SV*)gv); - RETURN; + stash = gv_stashpvn(packname, packlen, TRUE); + goto fetch; } - *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) { - char *name = SvPV(nm, na); - DIE("Can't call method \"%s\" on unblessed reference", name); - } + if (!ob || !SvOBJECT(ob)) + Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", + name); + + stash = SvSTASH(ob); - 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))); + fetch: + /* shortcut for simple names */ + if (hashp) { + HE* he = hv_fetch_ent(stash, meth, 0, *hashp); + if (he) { + gv = (GV*)HeVAL(he); + if (isGV(gv) && GvCV(gv) && + (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) + return (SV*)GvCV(gv); + } } - SETs((SV*)gv); - RETURN; + gv = gv_fetchmethod(stash, name); + if (!gv) { + char* leaf = name; + char* sep = Nullch; + char* p; + + 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 ? PL_curcop->cop_stash : stash); + packlen = strlen(packname); + } + else { + packname = name; + packlen = sep - name; + } + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"", + leaf, packname); + } + return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } +#ifdef USE_THREADS +static void +unset_cvowner(pTHXo_ void *cvarg) +{ + register CV* cv = (CV *) cvarg; +#ifdef DEBUGGING + dTHR; +#endif /* DEBUGGING */ + + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", + thr, cv, SvPEEK((SV*)cv)))); + MUTEX_LOCK(CvMUTEXP(cv)); + DEBUG_S(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 */