diff options
| -rw-r--r-- | cv.h | 22 | ||||
| -rw-r--r-- | dump.c | 11 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 8 | ||||
| -rw-r--r-- | ext/XS-APItest/t/autoload.t | 49 | ||||
| -rw-r--r-- | gv.c | 48 | ||||
| -rw-r--r-- | op.c | 26 | ||||
| -rw-r--r-- | pp.c | 4 | ||||
| -rw-r--r-- | toke.c | 6 |
8 files changed, 158 insertions, 16 deletions
@@ -71,6 +71,23 @@ For more information, see L<perlguts>. #define CvFLAGS(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags #define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq +/* These two are sometimes called on non-CVs */ +#define CvPROTO(sv) \ + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvEND(sv)+1 : SvPVX_const(sv) \ + : NULL \ + ) +#define CvPROTOLEN(sv) \ + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvLEN(sv)-SvCUR(sv)-2 \ + : SvCUR(sv) \ + : 0 \ + ) + #define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */ #define CVf_LVALUE 0x0002 /* CV return value can be used as lvalue */ #define CVf_CONST 0x0004 /* inlinable sub */ @@ -86,6 +103,7 @@ For more information, see L<perlguts>. (esp. useful for special XSUBs) */ #define CVf_CVGV_RC 0x0400 /* CvGV is reference counted */ #define CVf_DYNFILE 0x1000 /* The filename isn't static */ +#define CVf_AUTOLOAD 0x2000 /* SvPVX contains AUTOLOADed sub name */ /* This symbol for optimised communication between toke.c and op.c: */ #define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE) @@ -147,6 +165,10 @@ For more information, see L<perlguts>. #define CvDYNFILE_on(cv) (CvFLAGS(cv) |= CVf_DYNFILE) #define CvDYNFILE_off(cv) (CvFLAGS(cv) &= ~CVf_DYNFILE) +#define CvAUTOLOAD(cv) (CvFLAGS(cv) & CVf_AUTOLOAD) +#define CvAUTOLOAD_on(cv) (CvFLAGS(cv) |= CVf_AUTOLOAD) +#define CvAUTOLOAD_off(cv) (CvFLAGS(cv) &= ~CVf_AUTOLOAD) + /* Flags for newXS_flags */ #define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */ @@ -1442,6 +1442,7 @@ const struct flag_to_name cv_flags_names[] = { {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}, {CVf_CVGV_RC, "CVGV_RC,"}, {CVf_DYNFILE, "DYNFILE,"}, + {CVf_AUTOLOAD, "AUTOLOAD,"}, {CVf_ISXSUB, "ISXSUB,"} }; @@ -1954,11 +1955,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo break; case SVt_PVCV: - if (SvPOK(sv)) { + if (CvAUTOLOAD(sv)) { STRLEN len; - const char *const proto = SvPV_const(sv, len); + const char *const name = SvPV_const(sv, len); + Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n", + (int) len, name); + } + if (SvPOK(sv)) { Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n", - (int) len, proto); + (int) CvPROTOLEN(sv), CvPROTO(sv)); } /* FALL THROUGH */ case SVt_PVFM: diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 96efeb4cfd..4911f9aba2 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1526,6 +1526,14 @@ AUTOLOAD() OUTPUT: RETVAL +SV * +AUTOLOADp(...) + PROTOTYPE: *$ + CODE: + RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv)); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest diff --git a/ext/XS-APItest/t/autoload.t b/ext/XS-APItest/t/autoload.t index dd89c501a0..46564077b2 100644 --- a/ext/XS-APItest/t/autoload.t +++ b/ext/XS-APItest/t/autoload.t @@ -1,9 +1,13 @@ #!perl +# This script tests not only the interface for XS AUTOLOAD routines to find +# out the sub name, but also that that interface does not interfere with +# prototypes, the way it did before 5.15.4. + use strict; use warnings; -use Test::More tests => 3; +use Test::More tests => 14; use XS::APItest; @@ -12,3 +16,46 @@ is "XS::APItest::AutoLoader::fr\0b"->(), "fr\0b", 'name with embedded null passed to XS AUTOLOAD'; is "XS::APItest::AutoLoader::fr\x{1ed9}b"->(), "fr\x{1ed9}b", 'Unicode name passed to XS AUTOLOAD'; + +*AUTOLOAD = *XS::APItest::AutoLoader::AUTOLOADp; + +is frob(), 'frob', 'name passed to XS AUTOLOAD with proto'; +is prototype \&AUTOLOAD, '*$', 'prototype is unchanged'; +is "fr\0b"->(), "fr\0b", + 'name with embedded null passed to XS AUTOLOAD with proto'; +is prototype \&AUTOLOAD, '*$', 'proto unchanged after embedded-null call'; +is "fr\x{1ed9}b"->(), "fr\x{1ed9}b", + 'Unicode name passed to XS AUTOLOAD with proto'; +is prototype \&AUTOLOAD, '*$', 'prototype is unchanged after Unicode call'; + +# Test that the prototype was preserved from the parser’s point of view + +ok !eval "sub { ::AUTOLOAD(1) }", + 'parse failure due to AUTOLOAD prototype'; +ok eval "sub { ::AUTOLOAD(1,2) }", 'successful parse respecting prototype' + or diag $@; + +package fribble { sub a { return 7 } } +no warnings 'once'; +*a = \&AUTOLOAD; +'$'->(); +# &a('fribble') will return '$' +# But if intuit_method does not see the (*...) proto, this compiles as +# fribble->a +no strict; +is eval 'a fribble, 3', '$', 'intuit_method sees * in AUTOLOAD proto' + or diag $@; + +# precedence check +# *$ should parse as a list operator, but right now the AUTOLOAD +# sub name is $ +is join(" ", eval 'a "b", "c"'), '$', + 'precedence determination respects prototype of AUTOLOAD sub'; + +{ + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval 'sub a($){}'; + like $w, qr/^Prototype mismatch: sub main::a \(\*\$\) vs \(\$\)/m, + 'proto warnings respect AUTOLOAD prototypes'; +} @@ -1172,13 +1172,53 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', - * pass along the same data via some unused fields in the CV + * pass along the same data via the SvPVX field in the CV + * + * Due to an unfortunate accident of history, the SvPVX field + * serves two purposes. It is also used for the subroutine’s pro- + * type. Since SvPVX has been documented as returning the sub name + * for a long time, but not as returning the prototype, we have + * to preserve the SvPVX AUTOLOAD behaviour and put the prototype + * elsewhere. + * + * We put the prototype in the same allocated buffer, but after + * the sub name. The SvPOK flag indicates the presence of a proto- + * type. The CvAUTOLOAD flag indicates the presence of a sub name. + * If both flags are on, then SvLEN is used to indicate the end of + * the prototype (artificially lower than what is actually allo- + * cated), at the risk of having to reallocate a few bytes unneces- + * sarily--but that should happen very rarely, if ever. + * + * We use SvUTF8 for both prototypes and sub names, so if one is + * UTF8, the other must be upgraded. */ CvSTASH_set(cv, stash); - SvPV_set(cv, (char *)name); /* cast to lose constness warning */ - SvCUR_set(cv, len); - if (is_utf8) + if (SvPOK(cv)) { /* Ouch! */ + SV *tmpsv = newSVpvn_flags(name, len, is_utf8); + STRLEN ulen; + const char *proto = CvPROTO(cv); + assert(proto); + if (SvUTF8(cv)) + sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); + ulen = SvCUR(tmpsv); + SvCUR(tmpsv)++; /* include null in string */ + sv_catpvn_flags( + tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) + ); + SvTEMP_on(tmpsv); /* Allow theft */ + sv_setsv_nomg((SV *)cv, tmpsv); + SvREFCNT_dec(tmpsv); + SvLEN(cv) = SvCUR(cv) + 1; + SvCUR(cv) = ulen; + } + else { + sv_setpvn((SV *)cv, name, len); + SvPOK_off(cv); + if (is_utf8) SvUTF8_on(cv); + else SvUTF8_off(cv); + } + CvAUTOLOAD_on(cv); return gv; } @@ -6250,9 +6250,23 @@ void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { + const char * const cvp = CvPROTO(cv); + const STRLEN clen = CvPROTOLEN(cv); + PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; - if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ - || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP)))) + + if (((!p != !cvp) /* One has prototype, one has not. */ + || (p && ( + (flags & SVf_UTF8) == SvUTF8(cv) + ? len != clen || memNE(cvp, p, len) + : flags & SVf_UTF8 + ? bytes_cmp_utf8((const U8 *)cvp, clen, + (const U8 *)p, len) + : bytes_cmp_utf8((const U8 *)p, len, + (const U8 *)cvp, clen) + ) + ) + ) && ckWARN_d(WARN_PROTOTYPE)) { SV* const msg = sv_newmortal(); SV* name = NULL; @@ -6263,7 +6277,9 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", + SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP)) + ); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); @@ -8997,7 +9013,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto"); - proto = SvPV(protosv, proto_len); + if (SvTYPE(protosv) == SVt_PVCV) + proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); + else proto = SvPV(protosv, proto_len); proto_end = proto + proto_len; aop = cUNOPx(entersubop)->op_first; if (!aop->op_sibling) @@ -457,7 +457,9 @@ PP(pp_prototype) } cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) - ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); + ret = newSVpvn_flags( + CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv) + ); set: SETs(ret); RETURN; @@ -3739,7 +3739,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) return 0; if (cv) { if (SvPOK(cv)) { - const char *proto = SvPVX_const(cv); + const char *proto = CvPROTO(cv); if (proto) { if (*proto == ';') proto++; @@ -6775,8 +6775,8 @@ Perl_yylex(pTHX) #endif SvPOK(cv)) { - STRLEN protolen; - const char *proto = SvPV_const(MUTABLE_SV(cv), protolen); + STRLEN protolen = CvPROTOLEN(cv); + const char *proto = CvPROTO(cv); if (!protolen) TERM(FUNC0SUB); while (*proto == ';') |