X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=becd1e909a8699f4dd84c1eba854d46fec9b44de;hb=d9b01026c06e57b0b2693843df5de20c56e09baf;hp=3e225bc2704c1cc900b5ef2f324f2d3d16a9ebe6;hpb=d4b87e753f3c5c8123aeebb4ae822cef9f2eed3c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 3e225bc..becd1e9 100644 --- a/gv.c +++ b/gv.c @@ -1296,9 +1296,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* Names of length 1. (Or 0. But name is NUL terminated, so that will be case '\0' in this switch statement (ie a default case) */ switch (*name) { - case '&': - case '`': - case '\'': + case '&': /* $& */ + case '`': /* $` */ + case '\'': /* $' */ if ( sv_type == SVt_PVAV || sv_type == SVt_PVHV || @@ -1309,17 +1309,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, PL_sawampersand = TRUE; goto magicalize; - case ':': + case ':': /* $: */ sv_setpv(GvSVn(gv),PL_chopset); goto magicalize; - case '?': + case '?': /* $? */ #ifdef COMPLEX_STATUS SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif goto magicalize; - case '!': + case '!': /* $! */ GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ @@ -1330,8 +1330,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; - case '-': - case '+': + case '-': /* $- */ + case '+': /* $+ */ GvMULTI_on(gv); /* no used once warnings here */ { AV* const av = GvAVn(gv); @@ -1348,13 +1348,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; } - case '*': - case '#': + case '*': /* $* */ + case '#': /* $# */ if (sv_type == SVt_PV) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "$%c is no longer supported", *name); break; - case '|': + case '|': /* $| */ sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; @@ -1368,28 +1368,28 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, ro_magicalize: SvREADONLY_on(GvSVn(gv)); /* FALL THROUGH */ - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - case '[': - case '^': - case '~': - case '=': - case '%': - case '.': - case '(': - case ')': - case '<': - case '>': - case '\\': - case '/': + case '0': /* $0 */ + case '1': /* $1 */ + case '2': /* $2 */ + case '3': /* $3 */ + case '4': /* $4 */ + case '5': /* $5 */ + case '6': /* $6 */ + case '7': /* $7 */ + case '8': /* $8 */ + case '9': /* $9 */ + case '[': /* $[ */ + case '^': /* $^ */ + case '~': /* $~ */ + case '=': /* $= */ + case '%': /* $% */ + case '.': /* $. */ + case '(': /* $( */ + case ')': /* $) */ + case '<': /* $< */ + case '>': /* $> */ + case '\\': /* $\ */ + case '/': /* $/ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -1409,10 +1409,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, sv_setpvs(GvSVn(gv),"\f"); PL_formfeed = GvSVn(gv); break; - case ';': + case ';': /* $; */ sv_setpvs(GvSVn(gv),"\034"); break; - case ']': + case ']': /* $] */ { SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) @@ -1902,7 +1902,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); - postpr = 1; + if (cv) + postpr = 1; break; case copy_amg: { @@ -2007,35 +2008,24 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case ge_amg: case eq_amg: case ne_amg: - postpr = 1; off=ncmp_amg; break; + off = ncmp_amg; + break; case slt_amg: case sle_amg: case sgt_amg: case sge_amg: case seq_amg: case sne_amg: - postpr = 1; off=scmp_amg; break; + off = scmp_amg; + break; } - if (off != -1) cv = cvp[off]; - if (!cv) { - goto not_found; - } + if ((off != -1) && (cv = cvp[off])) + postpr = 1; + else + goto not_found; } else { not_found: /* No method found, either report or croak */ switch (method) { - case lt_amg: - case le_amg: - case gt_amg: - case ge_amg: - case eq_amg: - case ne_amg: - case slt_amg: - case sle_amg: - case sgt_amg: - case sge_amg: - case seq_amg: - case sne_amg: - postpr = 0; break; case to_sv_amg: case to_av_amg: case to_hv_amg: @@ -2372,6 +2362,66 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } /* +=for apidoc gv_try_downgrade + +If the typeglob C can be expressed more succinctly, by having +something other than a real GV in its place in the stash, replace it +with the optimised form. Basic requirements for this are that C +is a real typeglob, is sufficiently ordinary, and is only referenced +from its package. This function is meant to be used when a GV has been +looked up in part to see what was there, causing upgrading, but based +on what was found it turns out that the real GV isn't required after all. + +If C is a completely empty typeglob, it is deleted from the stash. + +If C is a typeglob containing only a sufficiently-ordinary constant +sub, the typeglob is replaced with a scalar-reference placeholder that +more compactly represents the same thing. + +=cut +*/ + +void +Perl_gv_try_downgrade(pTHX_ GV *gv) +{ + HV *stash; + CV *cv; + HEK *namehek; + SV **gvp; + PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; + if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && + !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGV(gv) == gv && (stash = GvSTASH(gv)))) + return; + cv = GvCV(gv); + if (!cv) { + HEK *gvnhek = GvNAME_HEK(gv); + (void)hv_delete(stash, HEK_KEY(gvnhek), + HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD); + } else if (GvMULTI(gv) && cv && + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && CvGV(cv) == gv && + CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && + !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && + (namehek = GvNAME_HEK(gv)) && + (gvp = hv_fetch(stash, HEK_KEY(namehek), + HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && + *gvp == (SV*)gv) { + SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + SvREFCNT(gv) = 0; + sv_clear((SV*)gv); + SvREFCNT(gv) = 1; + SvFLAGS(gv) = SVt_IV|SVf_ROK; + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); + } +} + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4