OK, here's a second attempt, with some tests.
--- Simple-0.17.pm 2008-11-05 11:02:44.000000000 +0000
+++ Simple-0.17+.pm 2008-11-05 16:43:28.000000000 +0000
@@ -4,7 +4,7 @@
use warnings;
no warnings 'redefine';
-our $VERSION = '0.17';
+our $VERSION = '0.17+djh';
#use Smart::Comments;
use Carp qw(carp confess);
@@ -351,7 +351,8 @@
my $methods = Class::Inspector->methods($pkg, 'expanded');
if ($methods and ref($methods) eq 'ARRAY') {
if ($from_class_accessor) {
- my %functions = map { $_->[2] => 1 } @$methods; #
create hash from array
+ my $i = 0;
+ my %functions = map { $_->[2] => $i++ } @$methods; #
create hash from array
### %functions
#my @accessors = map { /^_(.*)_accessor$/; $1 } keys
%functions;
### @accessors
@@ -362,9 +363,12 @@
if ($meth =~ /^_(.*)_accessor$/) {
my $accessor = $1;
if (exists $functions{$accessor}) {
+ if ($self->{inherited_methods}
+ or $methods->[$functions{$accessor}]->[1]
eq $pkg) {
+ push @{ $classes[-1]->{properties} },
$accessor;
+ }
delete $functions{$accessor};
delete $functions{"_${accessor}_accessor"};
- push @{ $classes[-1]->{properties} },
$accessor;
}
next;
}
@@ -373,7 +377,10 @@
my $accessor = $1;
delete $functions{$meth};
if (!$accessors{$accessor}) {
- push @{ $classes[-1]->{properties} },
$accessor;
+ if ($self->{inherited_methods}
+ or
$methods->[$functions{$accessor}]->[1] eq $pkg) {
+ push @{ $classes[-1]->{properties}
}, $accessor;
+ }
$accessors{$accessor} = 1;
}
}
@@ -388,8 +395,7 @@
if (! $self->{inherited_methods}) {
my $source_name = Devel::Peek::CvGV($method->[3]);
$source_name =~ s/^\*//;
- next if $method->[0] ne $source_name and
- $source_name !~
/^Class::Accessor::Grouped::__ANON__/;
+ next if $method->[0] ne $source_name;
}
$method = $method->[2];
next if $public_only && $method =~ /^_/o;
and two updated files for the test plus an extra test class:
--- t/class-accessor-grouped.t 2008-10-27 07:32:05.000000000 +0000
+++ t/class-accessor-grouped.t 2008-11-05 11:00:56.000000000 +0000
@@ -14,7 +14,7 @@
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys=1;
-plan tests => 1;
+plan tests => 3;
require "t/data/TestClassAccessorGrouped.pm";
my $painter = UML::Class::Simple->new(['TestClassAccessorGrouped']);
@@ -26,7 +26,8 @@
'classes' => [
{
'methods' => [
- 'blah'
+ 'blah',
+ 'overridden'
],
'name' => 'TestClassAccessorGrouped',
'properties' => [
@@ -43,3 +44,68 @@
};
_EOC_
+
+require "t/data/TestClassAccessorGroupedInheritance.pm";
+my $painter2 =
UML::Class::Simple->new(['TestClassAccessorGroupedInheritance']);
+
+my $dom2 = $painter2->as_dom;
+
+is Dumper($dom2), <<'_EOC_';
+$VAR1 = {
+ 'classes' => [
+ {
+ 'methods' => [
+ 'overridden',
+ 'subclass_only'
+ ],
+ 'name' => 'TestClassAccessorGroupedInheritance',
+ 'properties' => [
+ 'lr1name',
+ 'lr2name',
+ 'multiple1',
+ 'multiple2',
+ 'result_class',
+ 'singlefield',
+ 'sub_lr1name',
+ 'sub_lr2name',
+ 'sub_multiple1',
+ 'sub_multiple2',
+ 'sub_result_class',
+ 'sub_singlefield'
+ ],
+ 'subclasses' => []
+ }
+ ]
+};
+_EOC_
+
+
+my $painter3 =
UML::Class::Simple->new(['TestClassAccessorGroupedInheritance']);
+
+$painter3->inherited_methods(0);
+
+my $dom3 = $painter3->as_dom;
+
+is Dumper($dom3), <<'_EOC_';
+$VAR1 = {
+ 'classes' => [
+ {
+ 'methods' => [
+ 'overridden',
+ 'subclass_only'
+ ],
+ 'name' => 'TestClassAccessorGroupedInheritance',
+ 'properties' => [
+ 'sub_lr1name',
+ 'sub_lr2name',
+ 'sub_multiple1',
+ 'sub_multiple2',
+ 'sub_result_class',
+ 'sub_singlefield'
+ ],
+ 'subclasses' => []
+ }
+ ]
+};
+_EOC_
+
--- t/data/TestClassAccessorGrouped.pm 2008-10-27 07:23:33.000000000 +0000
+++ t/data/TestClassAccessorGrouped.pm 2008-11-04 16:46:07.000000000 +0000
@@ -7,6 +7,9 @@
__PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1field/],
[qw/lr2name lr2field/]);
__PACKAGE__->mk_group_accessors('component_class', 'result_class');
+sub overridden {
+}
+
sub blah {
}
cat t/data/TestClassAccessorGroupedInheritance.pm
package TestClassAccessorGroupedInheritance;
use base 'TestClassAccessorGrouped';
__PACKAGE__->mk_group_accessors('single', 'sub_singlefield');
__PACKAGE__->mk_group_accessors('multiple', qw/sub_multiple1
sub_multiple2/);
__PACKAGE__->mk_group_accessors('listref', [qw/sub_lr1name
sub_lr1field/], [qw/sub_lr2name sub_lr2field/]);
__PACKAGE__->mk_group_accessors('component_class', 'sub_result_class');
sub overridden {
}
sub subclass_only {
}
1
