From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 15 Nov 2012 18:48:09 +0000 (+0100)
Subject: Stop leaking extra methods into the inheritance chain
X-Git-Tag: v0.10009~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FClass-Accessor-Grouped.git;a=commitdiff_plain;h=e4cb632058a1584cd2727d5f7fc98dbeb6728aea

Stop leaking extra methods into the inheritance chain

Not opting to use namespace::clean as we can keep 5.6 compat
this way ;)
---

diff --git a/Changes b/Changes
index 70fc4e3..63a86a5 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Class::Accessor::Grouped.
 
+    - Stop leaking extra methods into the inheritance chain - there
+      are plenty already
+
 0.10008 2012-11-15 09:48 (UTC)
     - Allow disabling of accessor name checking introduced in 0.10007
     - Pass tests if Class::XSAccessor is available but Sub::Name isn't
diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index ca61579..3096b21 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -71,17 +71,13 @@ BEGIN {
     $0 =~ m|^ x?t / .+ \.t $|x
   ) ? 1 : 0 );
 
-  *Class::Accessor::Grouped::perlstring = ($] < '5.008')
-    ? do {
-      require Data::Dumper;
-      my $d = Data::Dumper->new([])->Indent(0)->Purity(0)->Pad('')->Useqq(1)->Terse(1)->Freezer('')->Toaster('');
-      sub { $d->Values([shift])->Dump };
-    }
-    : do {
-      require B;
-      \&B::perlstring;
-    }
-  ;
+  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 };
+  }
 }
 
 # Yes this method is undocumented
@@ -109,7 +105,7 @@ sub _mk_group_accessors {
       if ($name =~ /\0/) {
         Carp::croak(sprintf
           "Illegal accessor name %s - nulls should never appear in stash keys",
-          perlstring($name),
+          B::perlstring($name),
         );
       }
       elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) {
@@ -707,7 +703,7 @@ my $maker_templates = {
     cxsa_call => 'accessors',
     pp_generator => sub {
       # my ($group, $fieldname) = @_;
-      my $quoted_fieldname = perlstring($_[1]);
+      my $quoted_fieldname = B::perlstring($_[1]);
       sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
 
 @_ > 1
@@ -721,7 +717,7 @@ EOS
     cxsa_call => 'getters',
     pp_generator => sub {
       # my ($group, $fieldname) = @_;
-      my $quoted_fieldname = perlstring($_[1]);
+      my $quoted_fieldname = B::perlstring($_[1]);
       sprintf  <<'EOS', $_[0], $quoted_fieldname;
 
 @_ > 1
@@ -741,7 +737,7 @@ EOS
     cxsa_call => 'setters',
     pp_generator => sub {
       # my ($group, $fieldname) = @_;
-      my $quoted_fieldname = perlstring($_[1]);
+      my $quoted_fieldname = B::perlstring($_[1]);
       sprintf  <<'EOS', $_[0], $quoted_fieldname;
 
 @_ > 1
diff --git a/t/accessors_pp.t b/t/accessors_pp.t
index 3fed3aa..cb89232 100644
--- a/t/accessors_pp.t
+++ b/t/accessors_pp.t
@@ -21,7 +21,7 @@ BEGIN {
 }
 
 # rerun the regular 3 tests under the assumption of no Sub::Name
-for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
+for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t clean_namespace.t/) {
 
   subtest "$tname without Sub::Name (pass $_)" => sub {
     my $tfn = catfile($Bin, $tname);
diff --git a/t/accessors_xs.t b/t/accessors_xs.t
index ccefd72..12890dd 100644
--- a/t/accessors_xs.t
+++ b/t/accessors_xs.t
@@ -23,7 +23,7 @@ BEGIN {
 
 # rerun the regular 3 tests under XSAccessor
 $Class::Accessor::Grouped::USE_XS = 1;
-for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
+for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t clean_namespace.t/) {
 
   subtest "$tname with USE_XS (pass $_)" => sub {
     my $tfn = catfile($Bin, $tname);
diff --git a/t/clean_namespace.t b/t/clean_namespace.t
new file mode 100644
index 0000000..f423a0f
--- /dev/null
+++ b/t/clean_namespace.t
@@ -0,0 +1,46 @@
+use Test::More;
+use strict;
+use warnings;
+
+BEGIN {
+  plan skip_all => "Package::Stash required for this test"
+    unless eval { require Package::Stash };
+
+  require MRO::Compat if $] < 5.009_005;
+}
+
+{
+  package AccessorGroups::Clean;
+  use strict;
+  use warnings;
+  use base 'Class::Accessor::Grouped';
+
+  my $obj = bless {};
+  for (qw/simple inherited component_class/) {
+    __PACKAGE__->mk_group_accessors($_ => "${_}_a");
+    $obj->${\ "${_}_a"} ('blah');
+  }
+}
+
+is_deeply
+[ sort keys %{ { map
+  { %{Package::Stash->new($_)->get_all_symbols('CODE')} }
+  (reverse @{mro::get_linear_isa('AccessorGroups::Clean')})
+} } ],
+[ sort +(
+  (map { ( "$_", "_${_}_accessor" ) } qw/simple_a inherited_a component_class_a/ ),
+  (map { ( "get_$_", "set_$_" ) } qw/simple inherited component_class/ ),
+  qw/
+    _mk_group_accessors
+    get_super_paths
+    make_group_accessor
+    make_group_ro_accessor
+    make_group_wo_accessor
+    mk_group_accessors
+    mk_group_ro_accessors
+    mk_group_wo_accessors
+  /,
+)],
+'Expected list of methods in a freshly inheriting class';
+
+done_testing;
diff --git a/t/pod_spelling.t b/t/pod_spelling.t
index fabc1af..b7a9840 100644
--- a/t/pod_spelling.t
+++ b/t/pod_spelling.t
@@ -48,3 +48,4 @@ fREW
 frew
 getter
 subclasses
+Benchmarking
\ No newline at end of file