various fixes - also cperl

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 */

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/) {
 

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)" );
+      }
+    }
+}