diff --git a/XSAccessor.xs b/XSAccessor.xs index 7111b5b..5d0fc0c 100644 --- a/XSAccessor.xs +++ b/XSAccessor.xs @@ -175,14 +175,20 @@ if (!(SvROK(self) && SvTYPE(SvRV(self)) == SVt_PVAV)) { #ifdef CXA_ENABLE_ENTERSUB_OPTIMIZATION -#define CXA_OPTIMIZATION_OK(op) ((op->op_spare & 1) != 1) -#define CXA_DISABLE_OPTIMIZATION(op) (op->op_spare |= 1) +#ifdef USE_CPERL +#define OpSPARE(o) o->op_typechecked +#else +#define OpSPARE(o) o->op_spare +#endif + +#define CXA_OPTIMIZATION_OK(op) ((OpSPARE(op) & 1) != 1) +#define CXA_DISABLE_OPTIMIZATION(op) (OpSPARE(op) |= 1) /* see t/08hash_entersub.t */ #define CXAH_OPTIMIZE_ENTERSUB_TEST(name) \ STMT_START { \ /* print op_spare so that we get failing tests if perl starts using it */ \ - warn("cxah: accessor: op_spare: %u", PL_op->op_spare); \ + warn("cxah: accessor: op_spare: %u", OpSPARE(PL_op)); \ \ if (PL_op->op_ppaddr == CXA_DEFAULT_ENTERSUB) { \ if (CXA_OPTIMIZATION_OK(PL_op)) { \ @@ -483,7 +489,11 @@ PROTOTYPES: DISABLE BOOT: #ifdef CXA_ENABLE_ENTERSUB_OPTIMIZATION +# ifdef USE_CPERL +CXA_DEFAULT_ENTERSUB = PL_ppaddr[OP_ENTERXSSUB]; +# else CXA_DEFAULT_ENTERSUB = PL_ppaddr[OP_ENTERSUB]; +# endif #endif #ifdef USE_ITHREADS _init_cxsa_lock(&CXSAccessor_lock); /* cf. CXSAccessor.h */ diff --git a/t/50reentrant_goto.t b/t/50reentrant_goto.t index fb5ff73..8f3171c 100644 --- a/t/50reentrant_goto.t +++ b/t/50reentrant_goto.t @@ -33,8 +33,7 @@ sub install_accessor_with_shim { } TODO: { - todo_skip 'bug in perls < 5.8.9', 28, $] < 5.008009 - if $] < 5.008009; + todo_skip 'bug in perls < 5.8.9', 28 if $] < 5.008009; for my $name (qw/bar baz/) { diff --git a/t/50reentrant_goto_sigsegv.t b/t/50reentrant_goto_sigsegv.t new file mode 100644 index 0000000..247b6f5 --- /dev/null +++ b/t/50reentrant_goto_sigsegv.t @@ -0,0 +1,61 @@ +# segfault bug in perls < 5.8.9 (a perl bug) +# patches welcome +# see http://github.com/tsee/Class-XSAccessor/commit/8fe9c128027cc49c8e2d89c442c77285598b12d3 + +use strict; +use warnings; + +use Class::XSAccessor; +use Test::More tests => 28; + +my $shim_calls; + +sub install_accessor_with_shim { + my ($class, $name, $field) = @_; + + $field = $name if not defined $field; + + Class::XSAccessor->import ({ + class => $class, + getters => { $name => $field }, + replace => 1, + }); + + my $xs_cref = $class->can ($name); + + no strict 'refs'; + no warnings 'redefine'; + + *{"${class}::${name}"} = sub { + $shim_calls++; + goto $xs_cref; + }; +} + +TODO: { + todo_skip 'bug in perls < 5.8.9', 14 if $] < 5.008009; + + for my $name (qw/bar baz/) { + for my $pass (1..2) { + + $shim_calls = 0; + + install_accessor_with_shim ('Foo', $name); + my $obj = bless ({ $name => 'a'}, 'Foo'); + + is ($shim_calls, 0, "Reset number of calls ($name pass $pass)" ); + is ($obj->$name, 'a', "Accessor read works ($name pass $pass)" ); + is ($shim_calls, 1, "Shim called ($name pass $pass)" ); + + eval { $obj->$name ('ack!') }; + like ($@, qr/Usage\: (Foo::)?$name\(self\)/, + "Exception from R/O accessor thrown ($name pass $pass)" ); + is ($shim_calls, 2, "Shim called anyway ($name pass $pass)" ); + + eval { $obj->$name ('ick!') }; + like ($@, qr/Usage\: (Foo::)?$name\(self\)/, + "Exception from R/O accessor thrown once again ($name pass $pass)" ); + is ($shim_calls, 3, "Shim called again ($name pass $pass)" ); + } + } +}