}
}
-our $VERSION = '0.10008';
+our $VERSION = '0.10010';
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
# when changing minimum version don't forget to adjust Makefile.PL as well
constant->import( TRACK_UNDEFER_FAIL => (
$INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
and
- $0 =~ m|^ x?t / .+ \.t $|x
+ $0 =~ m{ ^ (?: \. \/ )? x?t / .+ \.t $}x
) ? 1 : 0 );
- require B;
- # a perl 5.6 kludge
- unless (B->can('perlstring')) {
- require Data::Dumper;
- my $d = Data::Dumper->new([])->Indent(0)->Purity(0)->Pad('')->Useqq(1)->Terse(1)->Freezer('')->Toaster('');
- *B::perlstring = sub { $d->Values([shift])->Dump };
- }
+ sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
}
# Yes this method is undocumented
if ($name =~ /\0/) {
Carp::croak(sprintf
"Illegal accessor name %s - nulls should never appear in stash keys",
- B::perlstring($name),
+ __CAG_ENV__::perlstring($name),
);
}
elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) {
cxsa_call => 'accessors',
pp_generator => sub {
# my ($group, $fieldname) = @_;
- my $quoted_fieldname = B::perlstring($_[1]);
+ my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
@_ > 1
cxsa_call => 'getters',
pp_generator => sub {
# my ($group, $fieldname) = @_;
- my $quoted_fieldname = B::perlstring($_[1]);
+ my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', $_[0], $quoted_fieldname;
@_ > 1
cxsa_call => 'setters',
pp_generator => sub {
# my ($group, $fieldname) = @_;
- my $quoted_fieldname = B::perlstring($_[1]);
+ my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', $_[0], $quoted_fieldname;
@_ > 1
my $original_simple_getter = __PACKAGE__->can ('get_simple');
my $original_simple_setter = __PACKAGE__->can ('set_simple');
+my ($resolved_methods, $cag_produced_crefs);
+
+sub CLONE {
+ my @crefs = grep { defined $_ } values %{$cag_produced_crefs||{}};
+ $cag_produced_crefs = @crefs
+ ? { map { $_ => $_ } @crefs }
+ : undef
+ ;
+}
+
# Note!!! Unusual signature
$gen_accessor = sub {
my ($type, $class, $group, $field, $methname) = @_;
die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
if __CAG_ENV__::NO_CXSA;
- my ($expected_cref, $cached_implementation);
- my $ret = $expected_cref = sub {
+ my $ret = sub {
my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0];
- # $cached_implementation will be set only if the shim got
- # 'around'ed, in which case it is handy to avoid re-running
- # this block over and over again
- my $resolved_implementation = $cached_implementation->{$current_class} || do {
+ my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do {
if (
($current_class->can('get_simple')||0) == $original_simple_getter
&&
# if after this shim was created someone wrapped it with an 'around',
# we can not blindly reinstall the method slot - we will destroy the
# wrapper. Silently chain execution further...
- if ( !$expected_cref or $expected_cref != ($current_class->can($methname)||0) ) {
-
- # there is no point in re-determining it on every subsequent call,
- # just store for future reference
- $cached_implementation->{$current_class} ||= $resolved_implementation;
+ if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) {
# older perls segfault if the cref behind the goto throws
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
goto $resolved_implementation;
}
+
if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
my $deferred_calls_seen = do {
no strict 'refs';
\%{"${current_class}::__cag_deferred_xs_shim_invocations"}
};
my @cframe = caller(0);
+
if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
Carp::carp (
"Deferred version of method $cframe[3] invoked more than once (originally "
my $fq_name = "${current_class}::${methname}";
*$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
-
- # need to update what the shim expects too *in case* its
- # ->can was cached for some moronic reason
- $expected_cref = $resolved_implementation;
- Scalar::Util::weaken($expected_cref);
}
+ # now things are installed - one ref less to carry
+ delete $resolved_methods->{$current_class}{$methname};
+
+ # but need to record it in the expectation registry *in case* it
+ # was cached via ->can for some moronic reason
+ Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );
+
+
# older perls segfault if the cref behind the goto throws
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
goto $resolved_implementation;
};
- Scalar::Util::weaken($expected_cref); # to break the self-reference
- $ret;
+ Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);
+
+ $ret; # returning shim
}
# no Sub::Name - just install the coderefs directly (compiling every time)