Stop loading B - use our own perlstring() implementation

[p5sagit/Class-Accessor-Grouped.git] / lib / Class / Accessor / Grouped.pm

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index bc379d7..f1fe9a9 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -15,7 +15,7 @@ BEGIN {
   }
 }
 
-our $VERSION = '0.10009';
+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
@@ -68,16 +68,10 @@ BEGIN {
   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
@@ -105,7 +99,7 @@ sub _mk_group_accessors {
       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} ) {
@@ -703,7 +697,7 @@ my $maker_templates = {
     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
@@ -717,7 +711,7 @@ EOS
     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
@@ -737,7 +731,7 @@ EOS
     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
@@ -786,6 +780,16 @@ my ($accessor_maker_cache, $no_xsa_warned_classes);
 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) = @_;
@@ -804,14 +808,10 @@ $gen_accessor = sub {
     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
             &&
@@ -857,11 +857,7 @@ $gen_accessor = sub {
       # 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
@@ -870,12 +866,14 @@ $gen_accessor = sub {
         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 "
@@ -898,13 +896,16 @@ $gen_accessor = sub {
 
         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;
@@ -912,8 +913,9 @@ $gen_accessor = sub {
       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)