X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=98b9b44d15315bf5667d236013be0d9169a89dbc;hb=de11ba31bba9f0eef0f76239d1d93a010926d6cf;hp=66d22bcc75edc33716a1219147952ae9d49bb6c3;hpb=c2e66d9e68806a7000ee1a4760c35703a0e0ae89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 66d22bc..98b9b44 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -19,19 +19,15 @@ #define PERL_IN_PP_HOT_C #include "perl.h" -#ifdef I_UNISTD -#include -#endif - /* Hot code. */ -#ifdef USE_THREADS -static void unset_cvowner(pTHXo_ void *cvarg); -#endif /* USE_THREADS */ +#ifdef USE_5005THREADS +static void unset_cvowner(pTHX_ void *cvarg); +#endif /* USE_5005THREADS */ PP(pp_const) { - djSP; + dSP; XPUSHs(cSVOP_sv); RETURN; } @@ -47,7 +43,7 @@ PP(pp_nextstate) PP(pp_gvsv) { - djSP; + dSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP_gv)); @@ -75,27 +71,22 @@ PP(pp_pushmark) PP(pp_stringify) { - djSP; dTARGET; - STRLEN len; - char *s; - s = SvPV(TOPs,len); - sv_setpvn(TARG,s,len); - if (SvUTF8(TOPs) && !IN_BYTE) - SvUTF8_on(TARG); + dSP; dTARGET; + sv_copypv(TARG,TOPs); SETTARG; RETURN; } PP(pp_gv) { - djSP; + dSP; XPUSHs((SV*)cGVOP_gv); RETURN; } PP(pp_and) { - djSP; + dSP; if (!SvTRUE(TOPs)) RETURN; else { @@ -106,7 +97,7 @@ PP(pp_and) PP(pp_sassign) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -121,7 +112,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - djSP; + dSP; if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); else @@ -141,61 +132,60 @@ PP(pp_unstack) PP(pp_concat) { - djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN len; - char *s; - bool left_utf = DO_UTF8(left); - bool right_utf = DO_UTF8(right); + STRLEN llen; + char* lpv; + bool lbyte; + STRLEN rlen; + char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ + bool rbyte = !SvUTF8(right); - if (TARG != left) { - if (right_utf && !left_utf) - sv_utf8_upgrade(left); - s = SvPV(left,len); - SvUTF8_off(TARG); - if (TARG == right) { - if (left_utf && !right_utf) - sv_utf8_upgrade(right); - sv_insert(TARG, 0, 0, s, len); - if (left_utf || right_utf) - SvUTF8_on(TARG); - SETs(TARG); - RETURN; - } - sv_setpvn(TARG,s,len); + if (TARG == right && right != left) { + right = sv_2mortal(newSVpvn(rpv, rlen)); + rpv = SvPV(right, rlen); /* no point setting UTF8 here */ } - else if (SvGMAGICAL(TARG)) { - mg_get(TARG); - if (right_utf && !left_utf) - sv_utf8_upgrade(left); + + if (TARG != left) { + lpv = SvPV(left, llen); /* mg_get(left) may happen here */ + lbyte = !SvUTF8(left); + sv_setpvn(TARG, lpv, llen); + if (!lbyte) + SvUTF8_on(TARG); + else + SvUTF8_off(TARG); } - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { - sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV_force(TARG, len); + else { /* TARG == left */ + if (SvGMAGICAL(left)) + mg_get(left); /* or mg_get(left) may happen here */ + if (!SvOK(TARG)) + sv_setpv(left, ""); + lpv = SvPV_nomg(left, llen); + lbyte = !SvUTF8(left); } - if (left_utf && !right_utf) - sv_utf8_upgrade(right); - s = SvPV(right,len); - if (SvOK(TARG)) { + #if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { - STRLEN n; - char *s = SvPV(TARG,n); - if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' - && (n == 2 || !isDIGIT(s[n-3]))) - { - Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } + if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) { + if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' + && (llen == 2 || !isDIGIT(lpv[llen - 3]))) + { + Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s", + "about to append an integer to '19'"); } + } #endif - sv_catpvn(TARG,s,len); + + if (lbyte != rbyte) { + if (lbyte) + sv_utf8_upgrade_nomg(TARG); + else { + sv_utf8_upgrade_nomg(right); + rpv = SvPV(right, rlen); + } } - else - sv_setpvn(TARG,s,len); /* suppress warning */ - if (left_utf || right_utf) - SvUTF8_on(TARG); + sv_catpvn_nomg(TARG, rpv, rlen); + SETTARG; RETURN; } @@ -203,7 +193,7 @@ PP(pp_concat) PP(pp_padsv) { - djSP; dTARGET; + dSP; dTARGET; XPUSHs(TARG); if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) @@ -222,7 +212,7 @@ PP(pp_readline) 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) + 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; @@ -237,7 +227,64 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + dSP; tryAMAGICbinSET(eq,0); +#ifndef NV_PRESERVES_UV + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); + RETURN; + } +#endif +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going + to have to use NV maths. Hence only attempt to coerce the + right argument if we know the left is integer. */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ + /* Casting IV to UV before comparison isn't going to matter + on 2s complement. On 1s complement or sign&magnitude + (if we have any of them) it could to make negative zero + differ from normal zero. As I understand it. (Need to + check - is negative zero implementation defined behaviour + anyway?). NWC */ + UV buv = SvUVX(POPs); + UV auv = SvUVX(TOPs); + + SETs(boolSV(auv == buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + SV *ivp, *uvp; + IV iv; + + /* == is commutative so doesn't matter which is left or right */ + if (auvok) { + /* top of stack (b) is the iv */ + ivp = *SP; + uvp = *--SP; + } else { + uvp = *SP; + ivp = *--SP; + } + iv = SvIVX(ivp); + if (iv < 0) { + /* As uv is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + /* we know iv is >= 0 */ + SETs(boolSV((UV)iv == SvUVX(uvp))); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn == value)); @@ -247,16 +294,16 @@ PP(pp_eq) PP(pp_preinc) { - djSP; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + dSP; + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MAX) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else + else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ sv_inc(TOPs); SvSETMAGIC(TOPs); return NORMAL; @@ -264,7 +311,7 @@ PP(pp_preinc) PP(pp_or) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else { @@ -273,19 +320,207 @@ PP(pp_or) } } +PP(pp_dor) +{ + /* Most of this is lifted straight from pp_defined */ + dSP; + register SV* sv; + + sv = TOPs; + if (!sv || !SvANY(sv)) { + --SP; + RETURNOP(cLOGOP->op_other); + } + + switch (SvTYPE(sv)) { + case SVt_PVAV: + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVHV: + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVCV: + if (CvROOT(sv) || CvXSUB(sv)) + RETURN; + break; + default: + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvOK(sv)) + RETURN; + } + + --SP; + RETURNOP(cLOGOP->op_other); +} + PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. + + How to detect overflow? + + C 99 section 6.2.6.1 says + + The range of nonnegative values of a signed integer type is a subrange + of the corresponding unsigned integer type, and the representation of + the same value in each type is the same. A computation involving + unsigned operands can never overflow, because a result that cannot be + represented by the resulting unsigned integer type is reduced modulo + the number that is one greater than the largest value that can be + represented by the resulting type. + + (the 9th paragraph) + + which I read as "unsigned ints wrap." + + signed integer overflow seems to be classed as "exception condition" + + If an exceptional condition occurs during the evaluation of an + expression (that is, if the result is not mathematically defined or not + in the range of representable values for its type), the behavior is + undefined. + + (6.5, the 5th paragraph) + + I had assumed that on 2s complement machines signed arithmetic would + wrap, hence coded pp_add and pp_subtract on the assumption that + everything perl builds on would be happy. After much wailing and + gnashing of teeth it would seem that irix64 knows its ANSI spec well, + knows that it doesn't need to, and doesn't. Bah. Anyway, the all- + unsigned code below is actually shorter than the old code. :-) + */ + + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + register UV auv = 0; + bool auvok = FALSE; + bool a_valid = 0; + + if (!useleft) { + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. + 0 is identity, + Could SETi or SETu right now, but space optimise by not adding + lots of code to speed up what is probably a rarish case. */ + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + if ((auvok = SvUOK(TOPm1s))) + auv = SvUVX(TOPm1s); + else { + register IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { /* 2s complement assumption for IV_MIN */ + auv = (UV)-aiv; + } + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + register UV buv; + bool buvok = SvUOK(TOPs); + + if (buvok) + buv = SvUVX(TOPs); + else { + register IV biv = SvIVX(TOPs); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else + buv = (UV)-biv; + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independent of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a + b => (a + b) + A + b => -(a - b) + a + B => (a - b) + A + B => -(a + b) + all UV maths. negate result if A negative. + add if signs same, subtract if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; + } + } + } else { + /* Signs same */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) + SETi( -(IV)result ); + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left + right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + TOPn ); + RETURN; } } PP(pp_aelemfast) { - djSP; + dSP; AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); @@ -299,7 +534,7 @@ PP(pp_aelemfast) PP(pp_join) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -309,7 +544,7 @@ PP(pp_join) PP(pp_pushre) { - djSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -330,20 +565,23 @@ PP(pp_pushre) PP(pp_print) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; MAGIC *mg; - STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { + had_magic: if (MARK == ORIGMARK) { - /* If using default handle then we need to make space to + /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... */ MEXTEND(SP, 1); @@ -352,7 +590,7 @@ PP(pp_print) ++SP; } PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); PUTBACK; ENTER; call_method("PRINT", G_SCALAR); @@ -364,39 +602,33 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (ckWARN(WARN_UNOPENED)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", - SvPV(sv,n_a)); - } - SETERRNO(EBADF,RMS$_IFI); + if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv))) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + goto had_magic; + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED, WARN_IO)) { - if (IoIFP(io)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for input", - SvPV(sv,n_a)); - } - else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "print", "filehandle"); + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); + else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); } - SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { MARK++; - if (PL_ofslen) { + if (PL_ofs_sv && SvOK(PL_ofs_sv)) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { + if (!do_print(PL_ofs_sv, fp)) { /* $, */ MARK--; break; } @@ -413,8 +645,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (PL_orslen) - if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) + if (PL_ors_sv && SvOK(PL_ors_sv)) + if (!do_print(PL_ors_sv, fp)) /* $\ */ goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -434,7 +666,7 @@ PP(pp_print) PP(pp_rv2av) { - djSP; dTOPss; + dSP; dTOPss; AV *av; if (SvROK(sv)) { @@ -448,6 +680,12 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + SETs((SV*)av); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVAV) { @@ -456,10 +694,17 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -509,20 +754,27 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; (void)POPs; /* XXXX May be optimized away? */ - EXTEND(SP, maxarg); + EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { - U32 i; - for (i=0; i < maxarg; i++) { + U32 i; + for (i=0; i < (U32)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*); } @@ -538,7 +790,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - djSP; dTOPss; + dSP; dTOPss; HV *hv; if (SvROK(sv)) { @@ -546,24 +798,37 @@ PP(pp_rv2hv) tryAMAGICunDEREF(to_hv); hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) + if (SvTYPE(hv) != SVt_PVHV) DIE(aTHX_ "Not a HASH reference"); if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + SETs((SV*)hv); + RETURN; + } } else { - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { + if (SvTYPE(sv) == SVt_PVHV) { hv = (HV*)sv; if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -613,6 +878,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } } @@ -622,8 +894,6 @@ PP(pp_rv2hv) } else { dTARGET; - if (SvTYPE(hv) == SVt_PVAV) - hv = avhv_keys((AV*)hv); if (HvFILL(hv)) Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); @@ -635,95 +905,42 @@ PP(pp_rv2hv) } } -STATIC int -S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, - SV **lastrelem) -{ - OP *leftop; - I32 i; - - leftop = ((BINOP*)PL_op)->op_last; - assert(leftop); - assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); - leftop = ((LISTOP*)leftop)->op_first; - assert(leftop); - /* Skip PUSHMARK and each element already assigned to. */ - for (i = lelem - firstlelem; i > 0; i--) { - leftop = leftop->op_sibling; - assert(leftop); - } - if (leftop->op_type != OP_RV2HV) - return 0; - - /* pseudohash */ - if (av_len(ary) > 0) - av_fill(ary, 0); /* clear all but the fields hash */ - if (lastrelem >= relem) { - while (relem < lastrelem) { /* gobble up all the rest */ - SV *tmpstr; - assert(relem[0]); - assert(relem[1]); - /* Avoid a memory leak when avhv_store_ent dies. */ - tmpstr = sv_newmortal(); - sv_setsv(tmpstr,relem[1]); /* value */ - relem[1] = tmpstr; - if (avhv_store_ent(ary,relem[0],tmpstr,0)) - (void)SvREFCNT_inc(tmpstr); - if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - relem += 2; - TAINT_NOT; - } - } - if (relem == lastrelem) - return 1; - return 2; -} - STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) { if (*relem) { SV *tmpstr; - if (ckWARN(WARN_MISC)) { + HE *didstore; + + if (ckWARN(WARN_MISC)) { if (relem == firstrelem && SvROK(*relem) && (SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV)) { - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference found where even-sized list expected"); } else - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in hash assignment"); } - if (SvTYPE(hash) == SVt_PVAV) { - /* pseudohash */ - tmpstr = sv_newmortal(); - if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) - (void)SvREFCNT_inc(tmpstr); - if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - } - else { - HE *didstore; - tmpstr = NEWSV(29,0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (SvMAGICAL(hash)) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - } - TAINT_NOT; + + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (SvMAGICAL(hash)) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + TAINT_NOT; } } PP(pp_aassign) { - djSP; + dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -769,19 +986,6 @@ PP(pp_aassign) case SVt_PVAV: ary = (AV*)sv; magic = SvMAGICAL(ary) != 0; - if (PL_op->op_private & OPpASSIGN_HASH) { - switch (do_maybe_phash(ary, lelem, firstlelem, relem, - lastrelem)) - { - case 0: - goto normal_array; - case 1: - do_oddball((HV*)ary, relem, firstrelem); - } - relem = lastrelem + 1; - break; - } - normal_array: av_clear(ary); av_extend(ary, lastrelem - relem); i = 0; @@ -934,25 +1138,28 @@ PP(pp_aassign) PP(pp_qr) { - djSP; + dSP; 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); + if (pm->op_pmdynflags & PMdf_TAINTED) + SvTAINTED_on(rv); + sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); RETURNX(PUSHs(rv)); } PP(pp_match) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; + PMOP *dynpm = pm; register char *t; register char *s; char *strend; I32 global; I32 r_flags = REXEC_CHECKED; char *truebase; /* Start of string */ - register REGEXP *rx = pm->op_pmregexp; + register REGEXP *rx = PM_GETRE(pm); bool rxtainted; I32 gimme = GIMME; STRLEN len; @@ -967,15 +1174,19 @@ PP(pp_match) TARG = DEFSV; EXTEND(SP,1); } + PUTBACK; /* EVAL blocks need stack_sp. */ s = SvPV(TARG, len); strend = s + len; if (!s) - DIE(aTHX_ "panic: do_match"); + DIE(aTHX_ "panic: pp_match"); rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; + PL_reg_match_utf8 = DO_UTF8(TARG); + + /* PMdf_USED is set after a ?? matches once */ if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) @@ -983,35 +1194,38 @@ PP(pp_match) RETPUSHNO; } + /* empty pattern special-cased to use last successful pattern if possible */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; - rx = pm->op_pmregexp; + rx = PM_GETRE(pm); } - if (rx->minlen > len) goto failure; + + if (rx->minlen > (I32)len) + goto failure; truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if ((global = pm->op_pmflags & PMf_GLOBAL)) { + if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); + MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { if (!(rx->reganch & ROPT_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; + 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; + rx->endp[0] = rx->startp[0] = mg->mg_len; } minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; } } } - if ((gimme != G_ARRAY && !global && rx->nparens) + if ((!global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; - if (SvSCREAM(TARG)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -1027,13 +1241,15 @@ play_it_again: if (update_minmatch++) minmatch = had_zerolen; } - if (rx->reganch & RE_USE_INTUIT) { + if (rx->reganch & RE_USE_INTUIT && + DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { + PL_bostr = truebase; s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); if (!s) goto nope; if ( (rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) @@ -1043,8 +1259,8 @@ play_it_again: if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -1056,37 +1272,54 @@ play_it_again: RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { - I32 iters, i, len; + I32 nparens, i, len; - iters = rx->nparens; - if (global && !iters) + nparens = rx->nparens; + if (global && !nparens) 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++) { + EXTEND(SP, nparens + i); + EXTEND_MORTAL(nparens + i); + for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { len = rx->endp[i] - rx->startp[i]; + if (rx->endp[i] < 0 || rx->startp[i] < 0 || + len < 0 || len > strend - s) + DIE(aTHX_ "panic: pp_match start/end pointers"); s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); - if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) SvUTF8_on(*SP); - sv_utf8_downgrade(*SP, TRUE); - } } } if (global) { + if (dynpm->op_pmflags & PMf_CONTINUE) { + MAGIC* mg = 0; + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) + mg = mg_find(TARG, PERL_MAGIC_regex_global); + if (!mg) { + sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(TARG, PERL_MAGIC_regex_global); + } + 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; + } + } 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) + else if (!nparens) XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; @@ -1095,10 +1328,10 @@ play_it_again: if (global) { MAGIC* mg = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, 'g'); + mg = mg_find(TARG, PERL_MAGIC_regex_global); if (!mg) { - sv_magic(TARG, (SV*)0, 'g', Nullch, 0); - mg = mg_find(TARG, 'g'); + sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(TARG, PERL_MAGIC_regex_global); } if (rx->startp[0] != -1) { mg->mg_len = rx->endp[0]; @@ -1117,8 +1350,8 @@ yup: /* Confirmed by INTUIT */ RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; if (RX_MATCH_COPIED(rx)) Safefree(rx->subbeg); RX_MATCH_COPIED_off(rx); @@ -1126,10 +1359,16 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlen; + if (PL_reg_match_utf8) { + char *t = (char*)utf8_hop((U8*)s, rx->minlen); + rx->endp[0] = t - truebase; + } + else { + rx->endp[0] = s - truebase + rx->minlen; + } rx->sublen = strend - truebase; goto gotcha; - } + } if (PL_sawampersand) { I32 off; @@ -1149,9 +1388,9 @@ yup: /* Confirmed by INTUIT */ nope: ret_no: - if (global && !(pm->op_pmflags & PMf_CONTINUE)) { + if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); + MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg) mg->mg_len = -1; } @@ -1175,16 +1414,19 @@ Perl_do_readline(pTHX) I32 gimme = GIMME_V; MAGIC *mg; - if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) { + if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("READLINE", gimme); LEAVE; SPAGAIN; - if (gimme == G_SCALAR) - SvSetMagicSV_nosteal(TARG, TOPs); + if (gimme == G_SCALAR) { + SV* result = POPs; + SvSetSV_nosteal(TARG, result); + PUSHTARG; + } RETURN; } fp = Nullfp; @@ -1208,159 +1450,24 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } - else if (type == OP_GLOB) { - SV *tmpcmd = NEWSV(55, 0); - SV *tmpglob = POPs; - ENTER; - SAVEFREESV(tmpcmd); -#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ - /* since spawning off a process is a real performance hit */ - { -#include -#include -#include -#include - char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; - char vmsspec[NAM$C_MAXRSS+1]; - char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; - char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; - $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); - PerlIO *tmpfp; - STRLEN i; - struct dsc$descriptor_s wilddsc - = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - struct dsc$descriptor_vs rsdsc - = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; - unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; - - /* We could find out if there's an explicit dev/dir or version - by peeking into lib$find_file's internal context at - ((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,PerlLIO_tmpnam(NULL)); - cp = SvPV(tmpglob,i); - for (; i; i--) { - if (cp[i] == ';') hasver = 1; - if (cp[i] == '.') { - if (sts) hasver = 1; - else sts = 1; - } - if (cp[i] == '/') { - hasdir = isunix = 1; - break; - } - if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { - hasdir = 1; - break; - } - } - if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != 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)) { - end = rstr + (unsigned long int) *rslt; - if (!hasver) while (*end != ';') end--; - *(end++) = '\n'; *end = '\0'; - for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); - if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); - begin = rstr; - } - else { - begin = end; - while (*(--begin) != ']' && *begin != '>') ; - ++begin; - } - ok = (PerlIO_puts(tmpfp,begin) != EOF); - } - if (cxt) (void)lib$find_file_end(&cxt); - if (ok && sts != RMS$_NMF && - sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; - if (!ok) { - if (!(sts & 1)) { - SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); - } - PerlIO_close(tmpfp); - fp = NULL; - } - else { - PerlIO_rewind(tmpfp); - IoTYPE(io) = '<'; - IoIFP(io) = fp = tmpfp; - IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ - } - } - } -#else /* !VMS */ -#ifdef MACOS_TRADITIONAL - sv_setpv(tmpcmd, "glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#else -#ifdef DOSISH -#ifdef OS2 - sv_setpv(tmpcmd, "for a in "); - 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, PL_cshname, PL_cshlen); - sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "' 2>/dev/null |"); -#else - sv_setpv(tmpcmd, "echo "); - sv_catsv(tmpcmd, tmpglob); -#if 'z' - 'a' == 25 - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#else - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); -#endif -#endif /* !CSH */ -#endif /* !DOSISH */ -#endif /* MACOS_TRADITIONAL */ - (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, O_RDONLY, 0, Nullfp); - fp = IoIFP(io); -#endif /* !VMS */ - LEAVE; - } + else if (type == OP_GLOB) + fp = Perl_start_glob(aTHX_ POPs, io); } 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)); + else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { + report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); } } if (!fp) { - if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (ckWARN2(WARN_GLOB, WARN_CLOSED) + && (!io || !(IoFLAGS(io) & IOf_START))) { if (type == OP_GLOB) - Perl_warner(aTHX_ WARN_GLOB, + Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", Strerror(errno)); else - report_closed_fh(PL_last_in_gv, io, "readline", "filehandle"); + report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1377,22 +1484,34 @@ Perl_do_readline(pTHX) tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen) Sv_Grow(sv, 80); /* try short-buffering it */ - if (type == OP_RCATLINE) + offset = 0; + if (type == OP_RCATLINE && SvOK(sv)) { + if (!SvPOK(sv)) { + STRLEN n_a; + (void)SvPV_force(sv, n_a); + } offset = SvCUR(sv); - else - offset = 0; + } } else { sv = sv_2mortal(NEWSV(57, 80)); offset = 0; } + /* This should not be marked tainted if the fp is marked clean */ +#define MAYBE_TAINT_LINE(io, sv) \ + if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ + TAINT; \ + SvTAINTED_on(sv); \ + } + /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { + PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) { @@ -1405,7 +1524,7 @@ Perl_do_readline(pTHX) } else if (type == OP_GLOB) { if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { - Perl_warner(aTHX_ WARN_GLOB, + Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (child exited with status %d%s)", (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); @@ -1413,18 +1532,17 @@ Perl_do_readline(pTHX) } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); + SPAGAIN; PUSHTARG; } + MAYBE_TAINT_LINE(io, sv); RETURN; } - /* This should not be marked tainted if the fp is marked clean */ - if (!(IoFLAGS(io) & IOf_UNTAINT)) { - TAINT; - SvTAINTED_on(sv); - } + MAYBE_TAINT_LINE(io, sv); IoLINES(io)++; IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); + SPAGAIN; XPUSHs(sv); if (type == OP_GLOB) { char *tmps; @@ -1467,7 +1585,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1488,24 +1606,44 @@ PP(pp_enter) PP(pp_helem) { - djSP; + dSP; HE* he; SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; +#ifdef PERL_COPY_ON_WRITE + U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0; +#else + U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; +#endif + I32 preeminent = 0; if (SvTYPE(hv) == SVt_PVHV) { - he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + if (PL_op->op_private & OPpLVAL_INTRO) { + MAGIC *mg; + HV *stash; + /* does the element we're localizing already exist? */ + preeminent = + /* can we determine whether it exists? */ + ( !SvRMAGICAL(hv) + || mg_find((SV*)hv, PERL_MAGIC_env) + || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE) + ) + ) ? hv_exists_ent(hv, keysv, 0) : 1; + + } + he = hv_fetch_ent(hv, keysv, lval && !defer, hash); 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; } @@ -1520,7 +1658,7 @@ PP(pp_helem) lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0); + sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0); SvREFCNT_dec(key2); /* sv_magic() increments refcount */ LvTARG(lv) = SvREFCNT_inc(hv); LvTARGLEN(lv) = 1; @@ -1530,8 +1668,14 @@ PP(pp_helem) 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 (!preeminent) { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + SAVEDELETE(hv, savepvn(key,keylen), keylen); + } else + save_helem(hv, keysv, svp); + } } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); @@ -1551,7 +1695,7 @@ PP(pp_helem) PP(pp_leave) { - djSP; + dSP; register PERL_CONTEXT *cx; register SV **mark; SV **newsp; @@ -1578,12 +1722,12 @@ PP(pp_leave) SP = newsp; else if (gimme == G_SCALAR) { MARK = newsp + 1; - if (MARK <= SP) + if (MARK <= SP) { if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) *MARK = TOPs; else *MARK = sv_mortalcopy(TOPs); - else { + } else { MEXTEND(mark,0); *MARK = &PL_sv_undef; } @@ -1607,7 +1751,7 @@ PP(pp_leave) PP(pp_iter) { - djSP; + dSP; register PERL_CONTEXT *cx; SV* sv; AV* av; @@ -1628,12 +1772,12 @@ PP(pp_iter) STRLEN maxlen; char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { -#ifndef USE_THREADS /* don't risk potential race */ +#ifndef USE_5005THREADS /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setsv(*itersvp, cur); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1654,12 +1798,12 @@ PP(pp_iter) if (cx->blk_loop.iterix > cx->blk_loop.itermax) RETPUSHNO; -#ifndef USE_THREADS /* don't risk potential race */ +#ifndef USE_5005THREADS /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setiv(*itersvp, cx->blk_loop.iterix++); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1677,13 +1821,21 @@ PP(pp_iter) SvREFCNT_dec(*itersvp); - if ((sv = SvMAGICAL(av) - ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) - : AvARRAY(av)[++cx->blk_loop.iterix])) + if (SvMAGICAL(av) || AvREIFY(av)) { + SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + if (svp) + sv = *svp; + else + sv = Nullsv; + } + else { + sv = AvARRAY(av)[++cx->blk_loop.iterix]; + } + if (sv) SvTEMP_off(sv); else sv = &PL_sv_undef; - if (av != PL_curstack && SvIMMORTAL(sv)) { + if (av != PL_curstack && sv == &PL_sv_undef) { SV *lv = cx->blk_loop.iterlval; if (lv && SvREFCNT(lv) > 1) { SvREFCNT_dec(lv); @@ -1695,7 +1847,7 @@ PP(pp_iter) lv = cx->blk_loop.iterlval = NEWSV(26, 0); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, 'y', Nullch, 0); + sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); } LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = cx->blk_loop.iterix; @@ -1709,7 +1861,7 @@ PP(pp_iter) PP(pp_subst) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1726,10 +1878,12 @@ PP(pp_subst) bool rxtainted; char *orig; I32 r_flags; - register REGEXP *rx = pm->op_pmregexp; + register REGEXP *rx = PM_GETRE(pm); STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; + STRLEN slen; + bool doutf8 = FALSE; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1738,7 +1892,10 @@ PP(pp_subst) else { TARG = DEFSV; EXTEND(SP,1); - } + } + + if (SvIsCOW(TARG)) + sv_force_normal_flags(TARG,0); if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) @@ -1754,18 +1911,21 @@ PP(pp_subst) rxtainted |= 2; TAINT_NOT; + PL_reg_match_utf8 = DO_UTF8(TARG); + force_it: if (!pm || !s) - DIE(aTHX_ "panic: do_subst"); + DIE(aTHX_ "panic: pp_subst"); strend = s + len; - maxiters = 2*(strend - s) + 10; /* We can match twice at each - position, once with zero-length, - second time with non-zero. */ + slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; + maxiters = 2 * slen + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; - rx = pm->op_pmregexp; + rx = PM_GETRE(pm); } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) ? REXEC_COPY_STR : 0; @@ -1777,13 +1937,14 @@ PP(pp_subst) } orig = m = s; if (rx->reganch & RE_USE_INTUIT) { + PL_bostr = orig; 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 + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) @@ -1795,10 +1956,30 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* known replacement string? */ - c = dstr ? SvPV(dstr, clen) : Nullch; - + if (dstr) { + /* replacement needing upgrading? */ + if (DO_UTF8(TARG) && !doutf8) { + SV *nsv = sv_newmortal(); + SvSetSV(nsv, dstr); + if (PL_encoding) + sv_recode_to_utf8(nsv, PL_encoding); + else + sv_utf8_upgrade(nsv); + c = SvPV(nsv, clen); + doutf8 = TRUE; + } + else { + c = SvPV(dstr, clen); + doutf8 = DO_UTF8(dstr); + } + } + else { + c = Nullch; + doutf8 = FALSE; + } + /* can do inplace substitution? */ - if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) + if (c && (I32)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)) @@ -1895,6 +2076,8 @@ PP(pp_subst) SPAGAIN; } SvTAINT(TARG); + if (doutf8) + SvUTF8_on(TARG); LEAVE_SCOPE(oldsave); RETURN; } @@ -1910,6 +2093,8 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); + if (DO_UTF8(TARG)) + SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; @@ -1936,14 +2121,23 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); - sv_catpvn(dstr, s, strend - s); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, r_flags)); + if (doutf8 && !DO_UTF8(dstr)) { + SV* nsv = sv_2mortal(newSVpvn(s, strend - s)); + + sv_utf8_upgrade(nsv); + sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv)); + } + else + sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); + doutf8 |= DO_UTF8(dstr); SvPVX(dstr) = 0; sv_free(dstr); @@ -1952,6 +2146,8 @@ PP(pp_subst) PUSHs(sv_2mortal(newSViv((I32)iters))); (void)SvPOK_only(TARG); + if (doutf8) + SvUTF8_on(TARG); TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); @@ -1961,7 +2157,7 @@ PP(pp_subst) goto ret_no; nope: -ret_no: +ret_no: SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -1970,7 +2166,7 @@ ret_no: PP(pp_grepwhile) { - djSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2011,7 +2207,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2020,7 +2216,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; @@ -2056,7 +2252,7 @@ PP(pp_leavesub) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2069,7 +2265,7 @@ PP(pp_leavesub) * get any slower by more conditions */ PP(pp_leavesublv) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2078,7 +2274,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { @@ -2150,18 +2346,16 @@ PP(pp_leavesublv) else if (gimme == G_ARRAY) { EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { - if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + if (*mark != &PL_sv_undef + && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; POPSUB(cx,sv); PL_curpm = newpm; LEAVE; LEAVESUB(sv); - DIE(aTHX_ "Can't return %s from lvalue subroutine", - (*mark != &PL_sv_undef) - ? (SvREADONLY(TOPs) - ? "a readonly value" : "a temporary") - : "an uninitialized value"); + DIE(aTHX_ "Can't return a %s from lvalue subroutine", + SvREADONLY(TOPs) ? "readonly value" : "temporary"); } else { /* Can be a localized value subject to deletion. */ @@ -2209,7 +2403,7 @@ PP(pp_leavesublv) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2222,7 +2416,6 @@ PP(pp_leavesublv) STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) { - dTHR; SV *dbsv = GvSV(PL_DBsub); if (!PERLDB_SUB_NN) { @@ -2230,7 +2423,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) save_item(dbsv); if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") + || 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) ))) { @@ -2259,7 +2452,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - djSP; dPOPss; + dSP; dPOPss; GV *gv; HV *stash; register CV *cv; @@ -2282,6 +2475,8 @@ PP(pp_entersub) } if (SvGMAGICAL(sv)) { mg_get(sv); + if (SvROK(sv)) + goto got_rv; sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else @@ -2293,6 +2488,7 @@ PP(pp_entersub) cv = get_cv(sym, TRUE); break; } + got_rv: { SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); @@ -2361,7 +2557,7 @@ try_autoload: DIE(aTHX_ "No DBsub routine"); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS /* * 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 @@ -2405,7 +2601,7 @@ try_autoload: COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", - thr, sv);) + thr, sv)); MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } @@ -2489,11 +2685,11 @@ try_autoload: } DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv));); + CvDEPTH(cv))); SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE @@ -2508,7 +2704,7 @@ try_autoload: } PL_stack_sp = mark + 1; fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, + items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); PL_stack_sp = PL_stack_base + items; @@ -2526,11 +2722,11 @@ try_autoload: * back. This would allow popping @_ in XSUB, e.g.. XXXX */ AV* av; I32 items; -#ifdef USE_THREADS +#ifdef USE_5005THREADS av = (AV*)PL_curpad[0]; #else av = GvAV(PL_defgv); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { @@ -2538,7 +2734,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } /* We assume first XSUB in &DB::sub is the called one. */ @@ -2548,7 +2744,7 @@ try_autoload: PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(aTHXo_ cv); + (void)(*CvXSUB(cv))(aTHX_ cv); /* Enforce some sanity in scalar context. */ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { @@ -2622,7 +2818,7 @@ try_autoload: svp = AvARRAY(padlist); } } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (!hasargs) { AV* av = (AV*)PL_curpad[0]; @@ -2632,15 +2828,15 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); -#ifndef USE_THREADS +#ifndef USE_5005THREADS if (hasargs) -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ { AV* av; SV** ary; @@ -2657,10 +2853,10 @@ try_autoload: AvREAL_off(av); AvREIFY_on(av); } -#ifndef USE_THREADS +#ifndef USE_5005THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; @@ -2680,7 +2876,7 @@ try_autoload: } Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + while (items--) { if (*MARK) SvTEMP_off(*MARK); @@ -2706,25 +2902,28 @@ void Perl_sub_crush_depth(pTHX_ CV *cv) { if (CvANON(cv)) - Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ packWARN(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\"", + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } PP(pp_aelem) { - djSP; + dSP; SV** svp; - I32 elem = POPi; + SV* elemsv = POPs; + IV elem = SvIV(elemsv); AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); SV *sv; + if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -2738,7 +2937,7 @@ PP(pp_aelem) lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, 'y', Nullch, 0); + sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = elem; LvTARGLEN(lv) = 1; @@ -2790,7 +2989,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - djSP; + dSP; SV* sv = TOPs; if (SvROK(sv)) { @@ -2807,7 +3006,7 @@ PP(pp_method) PP(pp_method_named) { - djSP; + dSP; SV* sv = cSVOP->op_sv; U32 hash = SvUVX(sv); @@ -2824,27 +3023,32 @@ S_method_common(pTHX_ SV* meth, U32* hashp) HV* stash; char* name; STRLEN namelen; - char* packname; + char* packname = 0; STRLEN packlen; name = SvPV(meth, namelen); sv = *(PL_stack_base + TOPMARK + 1); + if (!sv) + Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); + if (SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; + /* this isn't a reference */ packname = Nullch; if (!SvOK(sv) || !(packname = SvPV(sv, packlen)) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || - ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + /* this isn't the name of a filehandle either */ + if (!packname || + ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) @@ -2853,12 +3057,15 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SvOK(sv) ? "without a package or object reference" : "on an undefined value"); } - stash = gv_stashpvn(packname, packlen, TRUE); + /* assume it's a package name */ + stash = gv_stashpvn(packname, packlen, FALSE); goto fetch; } + /* it _is_ a filehandle name -- replace with a reference */ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } + /* if we got here, ob should be a reference or a glob */ if (!ob || !(SvOBJECT(ob) || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) @@ -2870,6 +3077,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) stash = SvSTASH(ob); fetch: + /* NOTE: stash may be null, hope hv_fetch_ent and + gv_fetchmethod can cope (it seems they can) */ + /* shortcut for simple names */ if (hashp) { HE* he = hv_fetch_ent(stash, meth, 0, *hashp); @@ -2882,11 +3092,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } gv = gv_fetchmethod(stash, name); + if (!gv) { + /* This code tries to figure out just what went wrong with + gv_fetchmethod. It therefore needs to duplicate a lot of + the internals of that function. We can't move it inside + Perl_gv_fetchmethod_autoload(), however, since that would + cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we + don't want that. + */ char* leaf = name; char* sep = Nullch; char* p; - GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -2895,47 +3112,48 @@ S_method_common(pTHX_ SV* meth, U32* hashp) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); + /* the method name is unqualified or starts with SUPER:: */ + packname = sep ? CopSTASHPV(PL_curcop) : + stash ? HvNAME(stash) : packname; packlen = strlen(packname); } else { + /* the method name is qualified */ packname = name; packlen = sep - name; } - gv = gv_fetchpv(packname, 0, SVt_PVHV); - if (gv && isGV(gv)) { + + /* we're relying on gv_fetchmethod not autovivifying the stash */ + if (gv_stashpvn(packname, packlen, FALSE)) { Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, packname); + "Can't locate object method \"%s\" via package \"%.*s\"", + leaf, (int)packlen, packname); } else { Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"" - " (perhaps you forgot to load \"%s\"?)", - leaf, packname, packname); + "Can't locate object method \"%s\" via package \"%.*s\"" + " (perhaps you forgot to load \"%.*s\"?)", + leaf, (int)packlen, packname, (int)packlen, packname); } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS static void -unset_cvowner(pTHXo_ void *cvarg) +unset_cvowner(pTHX_ void *cvarg) { register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); MUTEX_LOCK(CvMUTEXP(cv)); DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv));); + CvDEPTH(cv))); assert(thr == CvOWNER(cv)); CvOWNER(cv) = 0; MUTEX_UNLOCK(CvMUTEXP(cv)); SvREFCNT_dec(cv); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */