diff options
| -rw-r--r-- | XSUB.h | 38 | ||||
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | util.c | 43 |
5 files changed, 53 insertions, 37 deletions
@@ -298,43 +298,7 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ - STMT_START { \ - SV *_sv; \ - const char *vn = NULL, *module = SvPV_nolen_const(ST(0)); \ - if (items >= 2) /* version supplied as bootstrap arg */ \ - _sv = ST(1); \ - else { \ - /* XXX GV_ADDWARN */ \ - _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \ - vn = "XS_VERSION"), 0); \ - if (!_sv || !SvOK(_sv)) \ - _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \ - vn = "VERSION"), 0); \ - } \ - if (_sv) { \ - SV *xpt = NULL; \ - SV *xssv = Perl_newSVpvn(aTHX_ STR_WITH_LEN(XS_VERSION)); \ - SV *pmsv = sv_derived_from(_sv, "version") \ - ? SvREFCNT_inc_simple_NN(_sv) \ - : new_version(_sv); \ - xssv = upg_version(xssv, 0); \ - if ( vcmp(pmsv,xssv) ) { \ - xpt = Perl_newSVpvf(aTHX_ "%s object version %"SVf \ - " does not match %s%s%s%s %"SVf, \ - module, \ - SVfARG(Perl_sv_2mortal(aTHX_ vstringify(xssv))), \ - vn ? "$" : "", vn ? module : "", \ - vn ? "::" : "", \ - vn ? vn : "bootstrap parameter", \ - SVfARG(Perl_sv_2mortal(aTHX_ vstringify(pmsv)))); \ - Perl_sv_2mortal(aTHX_ xpt); \ - } \ - SvREFCNT_dec(xssv); \ - SvREFCNT_dec(pmsv); \ - if (xpt) \ - Perl_croak_sv(aTHX_ xpt); \ - } \ - } STMT_END + Perl_xs_version_bootcheck(aTHX_ items, ax, STR_WITH_LEN(XS_VERSION)) #else # define XS_VERSION_BOOTCHECK #endif @@ -2255,6 +2255,9 @@ Apo |void* |my_cxt_init |NN int *index|size_t size #endif #endif +Apo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \ + |STRLEN xs_len + #ifndef HAS_STRLCAT Apno |Size_t |my_strlcat |NULLOK char *dst|NULLOK const char *src|Size_t size #endif diff --git a/global.sym b/global.sym index 152f4b962c..a429d93529 100644 --- a/global.sym +++ b/global.sym @@ -742,6 +742,7 @@ Perl_warn Perl_warn_sv Perl_warner Perl_whichsig +Perl_xs_version_bootcheck Perl_yylex Perl_utf8n_to_uvchr Perl_uvchr_to_utf8 @@ -4687,6 +4687,11 @@ PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) #define PERL_ARGS_ASSERT_WRITE_TO_STDERR \ assert(msv) +PERL_CALLCONV void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK \ + assert(xs_p) + PERL_CALLCONV int Perl_yyerror(pTHX_ const char *const s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_YYERROR \ @@ -6471,6 +6471,49 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ #endif /* PERL_IMPLICIT_CONTEXT */ +void +Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, + STRLEN xs_len) +{ + SV *sv; + const char *vn = NULL; + const char *module = SvPV_nolen_const(PL_stack_base[ax]); + + PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; + + if (items >= 2) /* version supplied as bootstrap arg */ + sv = PL_stack_base[ax + 1]; + else { + /* XXX GV_ADDWARN */ + sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "XS_VERSION"), 0); + if (!sv || !SvOK(sv)) + sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "VERSION"), 0); + } + if (sv) { + SV *xpt = NULL; + SV *xssv = Perl_newSVpvn(aTHX_ xs_p, xs_len); + SV *pmsv = sv_derived_from(sv, "version") + ? SvREFCNT_inc_simple_NN(sv) + : new_version(sv); + xssv = upg_version(xssv, 0); + if ( vcmp(pmsv,xssv) ) { + xpt = Perl_newSVpvf(aTHX_ "%s object version %"SVf + " does not match %s%s%s%s %"SVf, + module, + SVfARG(Perl_sv_2mortal(aTHX_ vstringify(xssv))), + vn ? "$" : "", vn ? module : "", + vn ? "::" : "", + vn ? vn : "bootstrap parameter", + SVfARG(Perl_sv_2mortal(aTHX_ vstringify(pmsv)))); + Perl_sv_2mortal(aTHX_ xpt); + } + SvREFCNT_dec(xssv); + SvREFCNT_dec(pmsv); + if (xpt) + Perl_croak_sv(aTHX_ xpt); + } +} + #ifndef HAS_STRLCAT Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size) |