X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/53213d38f22e9356f489162e494d2ffa46ec2ca2..1c8b67b38f0a53a8eee6b8fa0ed6fa49e4c25cc7:/gv.c diff --git a/gv.c b/gv.c index 7e954d8..87e94b0 100644 --- a/gv.c +++ b/gv.c @@ -450,7 +450,6 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, static const char file[] = __FILE__; CV *cv, *oldcompcv = NULL; int opnum = 0; - SV *opnumsv; bool ampable = TRUE; /* &{}-able */ COP *oldcurcop = NULL; yy_parser *oldparser = NULL; @@ -536,8 +535,13 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, if (stash) (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { +#ifdef DEBUGGING + CV *orig_cv = cv; +#endif CvLVALUE_on(cv); - newATTRSUB_flags( + /* newATTRSUB will free the CV and return NULL if we're still + compiling after a syntax error */ + if ((cv = newATTRSUB_flags( oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( @@ -547,21 +551,25 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, code, opnum ), 1 - ); - assert(GvCV(gv) == cv); - if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS - && opnum != OP_UNDEF) - CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + )) != NULL) { + assert(GvCV(gv) == orig_cv); + if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS + && opnum != OP_UNDEF) + CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + } LEAVE; PL_parser = oldparser; PL_curcop = oldcurcop; PL_compcv = oldcompcv; } - opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; - cv_set_call_checker( - cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv - ); - SvREFCNT_dec(opnumsv); + if (cv) { + SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; + cv_set_call_checker( + cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv + ); + SvREFCNT_dec(opnumsv); + } + return gv; } @@ -1018,10 +1026,9 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le return gv; } Perl_croak(aTHX_ - "Can't locate object method \"%"SVf + "Can't locate object method \"%"UTF8f "\" via package \"%"HEKf"\"", - SVfARG(newSVpvn_flags(name, nend - name, - SVs_TEMP | is_utf8)), + is_utf8, nend - name, name, HEKfARG(HvNAME_HEK(stash))); } else { @@ -1031,7 +1038,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le packnamesv = newSVpvn_flags(origname, nsplit - origname, SVs_TEMP | is_utf8); } else { - packnamesv = sv_2mortal(newSVsv(error_report)); + packnamesv = error_report; } Perl_croak(aTHX_ @@ -1130,9 +1137,10 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated", + "Use of inherited AUTOLOAD for non-method %"SVf + "::%"UTF8f"() is deprecated", SVfARG(packname), - SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); + is_utf8, len, name); if (CvISXSUB(cv)) { /* Instead of forcing the XSUB do another lookup for $AUTOLOAD @@ -1402,7 +1410,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const char *name = nambeg; GV *gv = NULL; GV**gvp; - I32 len; + STRLEN len; const char *name_cursor; HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); @@ -1561,18 +1569,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { - SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8); /* diag_listed_as: Variable "%s" is not imported%s */ Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "Variable \"%c%"SVf"\" is not imported", + "Variable \"%c%"UTF8f"\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', - SVfARG(namesv)); + is_utf8, len, name); if (GvCVu(*gvp)) Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv) + "\t(Did you mean &%"UTF8f" instead?)\n", + is_utf8, len, name ); stash = NULL; } @@ -1589,15 +1597,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash) { if (add && !PL_in_clean_all) { - SV * const namesv = newSVpvn_flags(name, len, is_utf8); SV * const err = Perl_mess(aTHX_ - "Global symbol \"%s%"SVf"\" requires explicit package name", + "Global symbol \"%s%"UTF8f + "\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), SVfARG(namesv)); + : ""), is_utf8, len, name); GV *gv; - SvREFCNT_dec_NN(namesv); if (is_utf8) SvUTF8_on(err); qerror(err); @@ -1639,14 +1646,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, else if (*name == '-' || *name == '+') require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } else if (sv_type == SVt_PV) { - if (*name == '*') { - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, - WARN_SYNTAX), - "$* is no longer supported, and will become a syntax error"); - } else if (*name == '#') { + if (*name == '*' || *name == '#') { + /* diag_listed_as: $* is no longer supported */ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$# is no longer supported"); + "$%c is no longer supported", *name); } } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { @@ -1695,8 +1699,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly", - SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 ))); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Had to create %"UTF8f" unexpectedly", + is_utf8, name_end-nambeg, nambeg); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); if ( isIDFIRST_lazy_if(name, is_utf8) @@ -1937,14 +1942,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; } case '*': /* $* */ - if (sv_type == SVt_PV) - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$* is no longer supported, and will become a syntax error"); - break; case '#': /* $# */ if (sv_type == SVt_PV) + /* diag_listed_as: $* is no longer supported */ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$# is no longer supported"); + "$%c is no longer supported", *name); break; case '\010': /* $^H */ { @@ -2122,10 +2124,10 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) { dVAR; PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; + assert(!(flags & ~SVf_UTF8)); - return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld", - SVfARG(newSVpvn_flags(pack, strlen(pack), - SVs_TEMP | flags)), + return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld", + flags, strlen(pack), pack, (long)PL_gensym++), GV_ADD, SVt_PVGV); } @@ -3172,10 +3174,11 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && *gvp == (SV*)gv) { SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + const bool imported = !!GvIMPORTED_CV(gv); SvREFCNT(gv) = 0; sv_clear((SV*)gv); SvREFCNT(gv) = 1; - SvFLAGS(gv) = SVt_IV|SVf_ROK; + SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); SvRV_set(gv, value);