In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8a280620fcbbc5f0c47b80ca2dc5d3eb208012ae?hp=5de8bffdbc0d73b6750568e36033f7168cd88f51>
- Log ----------------------------------------------------------------- commit 8a280620fcbbc5f0c47b80ca2dc5d3eb208012ae Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 16:56:50 2010 +0100 Refactor Perl_xs_apiversion_bootcheck() Use fewer mortals, and avoid leaking an SV if upg_version() croaks. M util.c commit 379a89070cf5bdcfa33b12551d2c9ef0a3e11418 Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 16:13:38 2010 +0100 Convert the implementation of XS_APIVERSION_BOOTCHECK to a function. The previous macro generated over .5K of object code. This is in every shared object, and is only called once. Hence this change increases the perl binary by about .5K (once), to save .5K for every XS module loaded. M XSUB.h M embed.fnc M global.sym M proto.h M util.c commit 88c4b02d8afbe13e65dd6f677f5056354ec301cb Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 15:55:08 2010 +0100 XS::APItest tests for XS_APIVERSION_BOOTCHECK. M ext/XS-APItest/APItest.xs M ext/XS-APItest/XSUB-redefined-macros.xs M ext/XS-APItest/t/xsub_h.t commit 2ccd9aae61c3a09fcad5c90b7b21eb45c9e640ae Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 15:12:30 2010 +0100 xs_version_bootcheck() is an implementation detail, rather than a public API. XS_VERSION_BOOTCHECK() is the public API. M embed.fnc commit a2f871a29d6365cd9bb6b78aff1e44658f81cc1b Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 14:59:10 2010 +0100 Refactor xs_version_bootcheck() to remove complex constructions. Replace complex format strings ternary conditionals with an if/else block. Avoid assignment within expressions. Directly use the SV for the module's name, rather than converting it to a char *. M util.c commit f9cc56fa8caacd402d316a1cd95160cd70fb4c9e Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 11:59:47 2010 +0100 xs_version_bootcheck() must use mortals, as {new,upg}_version() can croak. It's unlikely that XS_VERSION will contain a bogus version string (for long), but the value passed in (or derived from $XS_VERSION or $VERSION) might well. For that case, without this change, temporary SVs created within xs_version_bootcheck() won't be freed (before interpreter exit). M MANIFEST M ext/XS-APItest/APItest.xs M ext/XS-APItest/Makefile.PL A ext/XS-APItest/XSUB-redefined-macros.xs M ext/XS-APItest/t/xsub_h.t M util.c commit 0e7bfc0a13342232c7329dcc019fa6e7fe360521 Author: Nicholas Clark <[email protected]> Date: Fri Oct 8 14:00:43 2010 +0100 threads::shared should not FREETMPS in its BOOT code. perl_construct() sets the current interpreter context, and ends in an ENTER. Hence threads::shared needs to restore the interpreter context, and balance the ENTER with a leave. Previously it was using its PERL_SET_CONTEXT() macro, which also contains a FREETMPS. However, this FREETMPS is erroneous in this specific context, as it does not have a balancing SAVETMPS. Hence calling SAVETMPS here would run it in the context of the shared interpreter, but it would (attempt to) free up temporaries created in the context of the parent interpreter. M dist/threads-shared/lib/threads/shared.pm M dist/threads-shared/shared.xs ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + XSUB.h | 19 +------- dist/threads-shared/lib/threads/shared.pm | 2 +- dist/threads-shared/shared.xs | 3 +- embed.fnc | 8 +++- ext/XS-APItest/APItest.xs | 10 ++++ ext/XS-APItest/Makefile.PL | 2 +- ext/XS-APItest/XSUB-redefined-macros.xs | 27 ++++++++++ ext/XS-APItest/t/xsub_h.t | 31 ++++++++++++ global.sym | 1 + proto.h | 6 ++ util.c | 75 +++++++++++++++++++++-------- 12 files changed, 143 insertions(+), 42 deletions(-) create mode 100644 ext/XS-APItest/XSUB-redefined-macros.xs diff --git a/MANIFEST b/MANIFEST index 314968e..6ce960d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3406,6 +3406,7 @@ ext/XS-APItest/t/xs_special_subs_require.t for require too ext/XS-APItest/t/xs_special_subs.t Test that XS BEGIN/CHECK/INIT/END work ext/XS-APItest/t/xsub_h.t Tests for XSUB.h ext/XS-APItest/typemap +ext/XS-APItest/XSUB-redefined-macros.xs XS code needing redefined macros. ext/XS-APItest/XSUB-undef-XS_VERSION.xs XS code needing #undef XS_VERSION ext/XS-Typemap/Makefile.PL XS::Typemap extension ext/XS-Typemap/README XS::Typemap extension diff --git a/XSUB.h b/XSUB.h index 174ce88..6906ded 100644 --- a/XSUB.h +++ b/XSUB.h @@ -304,24 +304,7 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. #endif #define XS_APIVERSION_BOOTCHECK \ - STMT_START { \ - SV *_xpt = NULL; \ - SV *_compver = Perl_newSVpv(aTHX_ "v" PERL_API_VERSION_STRING, 0); \ - SV *_runver = new_version(PL_apiversion); \ - _compver = upg_version(_compver, 0); \ - if (vcmp(_compver, _runver)) { \ - _xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf \ - " of %s does not match %"SVf, \ - SVfARG(Perl_sv_2mortal(aTHX_ vstringify(_compver))), \ - SvPV_nolen_const(ST(0)), \ - SVfARG(Perl_sv_2mortal(aTHX_ vstringify(_runver)))); \ - Perl_sv_2mortal(aTHX_ _xpt); \ - } \ - SvREFCNT_dec(_compver); \ - SvREFCNT_dec(_runver); \ - if (_xpt) \ - Perl_croak_sv(aTHX_ _xpt); \ - } STMT_END + Perl_xs_apiversion_bootcheck(aTHX_ ST(0), STR_WITH_LEN("v" PERL_API_VERSION_STRING)) #ifdef NO_XSLOCKS # define dXCPT dJMPENV; int rEtV = 0 diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index 3ff48fd..269e35a 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.33_03'; +our $VERSION = '1.33_04'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index 549fe37..6ead3ba 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -1194,7 +1194,8 @@ Perl_sharedsv_init(pTHX) /* This pair leaves us in shared context ... */ PL_sharedsv_space = perl_alloc(); perl_construct(PL_sharedsv_space); - CALLER_CONTEXT; + LEAVE; /* This balances the ENTER at the end of perl_construct. */ + PERL_SET_CONTEXT((aTHX = caller_perl)); recursive_lock_init(aTHX_ &PL_sharedsv_lock); PL_lockhook = &Perl_sharedsv_locksv; PL_sharehook = &Perl_sharedsv_share; diff --git a/embed.fnc b/embed.fnc index 6bdc12f..3ddf03d 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2255,8 +2255,14 @@ 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 \ +: This function is an implementation detail. The public API for this is +: XS_VERSION_BOOTCHECK +Xpo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \ |STRLEN xs_len +: This function is an implementation detail. The public API for this is +: XS_APIVERSION_BOOTCHECK +Xpo |void |xs_apiversion_bootcheck|NN SV *module|NN const char *api_p \ + |STRLEN api_len #ifndef HAS_STRLCAT Apno |Size_t |my_strlcat |NULLOK char *dst|NULLOK const char *src|Size_t size diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 3322922..b59aff4 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -606,6 +606,8 @@ static int my_keyword_plugin(pTHX_ } XS(XS_XS__APItest__XSUB_XS_VERSION_undef); +XS(XS_XS__APItest__XSUB_XS_VERSION_empty); +XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid); #include "const-c.inc" @@ -619,6 +621,8 @@ MODULE = XS::APItest PACKAGE = XS::APItest::XSUB BOOT: newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__); + newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__); + newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__); void XS_VERSION_defined(...) @@ -626,6 +630,12 @@ XS_VERSION_defined(...) XS_VERSION_BOOTCHECK; XSRETURN_EMPTY; +void +XS_APIVERSION_valid(...) + PPCODE: + XS_APIVERSION_BOOTCHECK; + XSRETURN_EMPTY; + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index 084de96..6a0271a 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -10,7 +10,7 @@ WriteMakefile( ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module AUTHOR => 'Tim Jenness <[email protected]>, Christian Soeller <[email protected]>, Hugo van der Sanden <[email protected]>, Andrew Main (Zefram) <[email protected]>', 'C' => ['exception.c', 'core.c', 'notcore.c'], - 'OBJECT' => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) $(O_FILES)', + 'OBJECT' => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) XSUB-redefined-macros$(OBJ_EXT) $(O_FILES)', realclean => {FILES => 'const-c.inc const-xs.inc'}, ($Config{gccversion} && $Config{d_attribute_deprecated} ? (CCFLAGS => $Config{ccflags} . ' -Wno-deprecated-declarations') : ()), diff --git a/ext/XS-APItest/XSUB-redefined-macros.xs b/ext/XS-APItest/XSUB-redefined-macros.xs new file mode 100644 index 0000000..05cfb41 --- /dev/null +++ b/ext/XS-APItest/XSUB-redefined-macros.xs @@ -0,0 +1,27 @@ +#include "EXTERN.h" +#include "perl.h" + +/* We have to be in a different .xs so that we can do this: */ + +#undef XS_VERSION +#define XS_VERSION "" +#undef PERL_API_VERSION_STRING +#define PERL_API_VERSION_STRING "1.0.16" +#include "XSUB.h" + +/* This can't be "MODULE = XS::APItest" as then we get duplicate bootstraps. */ +MODULE = XS::APItest::XSUB1 PACKAGE = XS::APItest::XSUB + +PROTOTYPES: DISABLE + +void +XS_VERSION_empty(...) + PPCODE: + XS_VERSION_BOOTCHECK; + XSRETURN_EMPTY; + +void +XS_APIVERSION_invalid(...) + PPCODE: + XS_APIVERSION_BOOTCHECK; + XSRETURN_EMPTY; diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t index c25b3a9..93742b1 100644 --- a/ext/XS-APItest/t/xsub_h.t +++ b/ext/XS-APItest/t/xsub_h.t @@ -89,4 +89,35 @@ foreach $XS_VERSION (undef, @versions) { } } +{ + my $count = 0; + { + package Counter; + our @ISA = 'version'; + sub new { + ++$count; + return version::new(@_); + } + + sub DESTROY { + --$count; + } + } + + { + my $var = Counter->new(); + is ($count, 1, "1 object exists"); + is (eval {XS_VERSION_empty('main', $var); 1}, undef); + like ($@, qr/Invalid version format \(version required\)/); + } + + is ($count, 0, "no objects exist"); +} + +is_deeply([XS_APIVERSION_valid("Pie")], [], "XS_APIVERSION_BOOTCHECK passes"); +is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef, + "XS_APIVERSION_BOOTCHECK croaks for an invalid version"); +like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/, + "expected error"); + done_testing(); diff --git a/global.sym b/global.sym index a429d93..203affb 100644 --- a/global.sym +++ b/global.sym @@ -742,6 +742,7 @@ Perl_warn Perl_warn_sv Perl_warner Perl_whichsig +Perl_xs_apiversion_bootcheck Perl_xs_version_bootcheck Perl_yylex Perl_utf8n_to_uvchr diff --git a/proto.h b/proto.h index fffbdca..8a020f5 100644 --- a/proto.h +++ b/proto.h @@ -4687,6 +4687,12 @@ PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) #define PERL_ARGS_ASSERT_WRITE_TO_STDERR \ assert(msv) +PERL_CALLCONV void Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, STRLEN api_len) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK \ + assert(module); assert(api_p) + 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 \ diff --git a/util.c b/util.c index 16fae9a..20429f7 100644 --- a/util.c +++ b/util.c @@ -6472,7 +6472,7 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, { SV *sv; const char *vn = NULL; - const char *module = SvPV_nolen_const(PL_stack_base[ax]); + SV *const module = PL_stack_base[ax]; PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; @@ -6480,35 +6480,70 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 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); + vn = "XS_VERSION"; + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + if (!sv || !SvOK(sv)) { + vn = "VERSION"; + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + } } if (sv) { - SV *xpt = NULL; - SV *xssv = Perl_newSVpvn(aTHX_ xs_p, xs_len); + SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); SV *pmsv = sv_derived_from(sv, "version") - ? SvREFCNT_inc_simple_NN(sv) - : new_version(sv); + ? sv : sv_2mortal(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)))); + SV *string = vstringify(xssv); + SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf + " does not match ", module, string); + + SvREFCNT_dec(string); + string = vstringify(pmsv); + + if (vn) { + Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, + string); + } else { + Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); + } + SvREFCNT_dec(string); + Perl_sv_2mortal(aTHX_ xpt); - } - SvREFCNT_dec(xssv); - SvREFCNT_dec(pmsv); - if (xpt) Perl_croak_sv(aTHX_ xpt); + } } } +void +Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, + STRLEN api_len) +{ + SV *xpt = NULL; + SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); + SV *runver; + + PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; + + /* This might croak */ + compver = upg_version(compver, 0); + /* This should never croak */ + runver = new_version(PL_apiversion); + if (vcmp(compver, runver)) { + SV *compver_string = vstringify(compver); + SV *runver_string = vstringify(runver); + xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf + " of %"SVf" does not match %"SVf, + compver_string, module, runver_string); + Perl_sv_2mortal(aTHX_ xpt); + + SvREFCNT_dec(compver_string); + SvREFCNT_dec(runver_string); + } + SvREFCNT_dec(runver); + if (xpt) + Perl_croak_sv(aTHX_ xpt); +} + #ifndef HAS_STRLCAT Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size) -- Perl5 Master Repository
