Added get_inherited/set_inherited to get/set inheritable class/object data much like...

Added Scalar::Util/Class::ISA to requires

diff --git a/Build.PL b/Build.PL
index 751c6b3..90d70fc 100644 (file)
--- a/Build.PL
+++ b/Build.PL
@@ -7,7 +7,9 @@ Module::Build->new(
     module_name => 'Class::Accessor::Grouped',
     license => 'perl',
     requires => {
-        Carp => 0
+        'Carp' => 0,
+        'Scalar::Util' => 0,
+        'Class::ISA' => 0
     },
     create_makefile_pl => 'passthrough',
     create_readme => 1,

diff --git a/MANIFEST b/MANIFEST
index f7bb7fe..5fc4403 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -9,8 +9,12 @@ README
 t/accessors.t\r
 t/accessors_ro.t\r
 t/accessors_wo.t\r
+t/inherited.t\r
 t/lib/AccessorGroups.pm\r
 t/lib/AccessorGroupsRO.pm\r
 t/lib/AccessorGroupsWO.pm\r
+t/lib/BaseInheritedGroups.pm\r
+t/lib/NotHashBased.pm\r
+t/lib/SuperInheritedGroups.pm\r
 t/pod-coverage.t\r
 t/pod.t\r

diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index 30ef920..e9d92b5 100644 (file)
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -19,6 +19,7 @@ aegis.log$
 # Avoid Module::Build generated and utility files.
 \bBuild$
 \b_build
+Build.bat
 
 # Avoid temp and backup files.
 ~$

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 0336faf..09210de 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -2,6 +2,8 @@ package Class::Accessor::Grouped;
 use strict;
 use warnings;
 use Carp;
+use Class::ISA;
+use Scalar::Util qw/blessed reftype/;
 use vars qw($VERSION);
 
 $VERSION = '0.01';
@@ -269,6 +271,76 @@ sub set_simple {
   return $self->{$set} = $val;
 }
 
+
+=head2 get_inherited
+
+=over 4
+
+=item Arguments: $field
+
+Returns: $value
+
+=back
+
+Simple getter for Classes and hash-based objects which returns the value for the field name passed as
+an argument. This behaves much like L<Class::Data::Accessor> where the field can be set in a
+base class, inherited and changed in subclasses, and inherited and changed for object instances.
+
+=cut
+
+sub get_inherited {
+    my ($self, $get) = @_;
+
+    if (blessed $self) {
+        if (reftype($self) eq 'HASH' && exists $self->{$get}) {
+            return $self->{$get};
+        } elsif (reftype($self) ne 'HASH') {
+            croak('Cannot get inherited value on an object instance that is not hash-based');
+        };
+    };
+
+    no strict 'refs';
+
+    my @supers = Class::ISA::self_and_super_path(ref $self || $self);
+    foreach (@supers) {
+        return ${$_.'::_'.$get} if ${$_.'::_'.$get};
+    };
+}
+
+=head2 set_inherited
+
+=over 4
+
+=item Arguments: $field, $new_value
+
+Returns: $new_value
+
+=back
+
+Simple setter for Classes and hash-based objects which sets and then returns the value
+for the field name passed as an argument. When called on a hash-based object it will set the appropriate
+hash key value. When called on a class, it will set a class level variable.
+
+B<Note:>: This method will die if you try to set an object variable on a non hash-based object.
+
+=cut
+
+sub set_inherited {
+    my ($self, $set, $val) = @_;
+
+    if (blessed $self) {
+        if (reftype($self) eq 'HASH') {
+            return $self->{$set} = $val;
+        } else {
+            croak('Cannot set inherited value on an object instance that is not hash-based');
+        };
+    } else {
+        no strict 'refs';
+
+        return ${$self.'::_'.$set} = $val;
+    };
+}
+
 1;
 
 =head1 AUTHORS

diff --git a/t/inherited.t b/t/inherited.t
new file mode 100644 (file)
index 0000000..46a545a
--- /dev/null
+++ b/t/inherited.t
@@ -0,0 +1,63 @@
+use Test::More tests => 29;
+use strict;
+use warnings;
+use lib 't/lib';
+use SuperInheritedGroups;
+use NotHashBased;
+
+my $super = SuperInheritedGroups->new;
+my $base = BaseInheritedGroups->new;
+
+# set base. base, super, object = base
+is(BaseInheritedGroups->basefield('All Your Base'), 'All Your Base');
+is(SuperInheritedGroups->basefield, 'All Your Base');
+is($super->basefield, 'All Your Base');
+is($base->basefield, 'All Your Base');
+
+# set super. super = super, base = base, object = super
+is(SuperInheritedGroups->basefield('Now Its Our Base'), 'Now Its Our Base');
+is(SuperInheritedGroups->basefield, 'Now Its Our Base');
+is(BaseInheritedGroups->basefield, 'All Your Base');
+is($super->basefield, 'Now Its Our Base');
+is($base->basefield, 'All Your Base');
+
+#set base
+is($base->basefield('First Base'), 'First Base');
+is($base->basefield, 'First Base');
+is($super->basefield, 'Now Its Our Base');
+is(BaseInheritedGroups->basefield, 'All Your Base');
+is(SuperInheritedGroups->basefield, 'Now Its Our Base');
+
+# set object, object = object, super = super, base = base
+is($super->basefield('Third Base'), 'Third Base');
+is($super->basefield, 'Third Base');
+is(SuperInheritedGroups->basefield, 'Now Its Our Base');
+is(BaseInheritedGroups->basefield, 'All Your Base');
+
+# create new super. new = base, object = object, super = super, base = base
+my $newsuper = SuperInheritedGroups->new;
+is($newsuper->basefield, 'Now Its Our Base');
+is($super->basefield, 'Third Base');
+is(SuperInheritedGroups->basefield, 'Now Its Our Base');
+is(BaseInheritedGroups->basefield, 'All Your Base');
+
+# create new base. new = base, super = super, base = base
+my $newbase = BaseInheritedGroups->new;
+is($newbase->basefield, 'All Your Base');
+is($newsuper->basefield, 'Now Its Our Base');
+is($super->basefield, 'Third Base');
+is(SuperInheritedGroups->basefield, 'Now Its Our Base');
+is(BaseInheritedGroups->basefield, 'All Your Base');
+
+# croak on get/set on non hash-based object
+my $dying = NotHashBased->new;
+
+eval {
+    $dying->killme;
+};
+ok($@ =~ /Cannot get.*is not hash-based/);
+
+eval {
+    $dying->killme('foo');
+};
+ok($@ =~ /Cannot set.*is not hash-based/);

diff --git a/t/lib/BaseInheritedGroups.pm b/t/lib/BaseInheritedGroups.pm
new file mode 100644 (file)
index 0000000..1f63f0f
--- /dev/null
+++ b/t/lib/BaseInheritedGroups.pm
@@ -0,0 +1,12 @@
+package BaseInheritedGroups;
+use strict;
+use warnings;
+use base 'Class::Accessor::Grouped';
+
+__PACKAGE__->mk_group_accessors('inherited', 'basefield');
+
+sub new {
+    return bless {}, shift;
+};
+
+1;

diff --git a/t/lib/NotHashBased.pm b/t/lib/NotHashBased.pm
new file mode 100644 (file)
index 0000000..5844a90
--- /dev/null
+++ b/t/lib/NotHashBased.pm
@@ -0,0 +1,12 @@
+package NotHashBased;
+use strict;
+use warnings;
+use base 'Class::Accessor::Grouped';
+
+sub new {
+    return bless [], shift;
+};
+
+__PACKAGE__->mk_group_accessors('inherited', 'killme');
+
+1;

diff --git a/t/lib/SuperInheritedGroups.pm b/t/lib/SuperInheritedGroups.pm
new file mode 100644 (file)
index 0000000..0266bee
--- /dev/null
+++ b/t/lib/SuperInheritedGroups.pm
@@ -0,0 +1,6 @@
+package SuperInheritedGroups;
+use strict;
+use warnings;
+use base 'BaseInheritedGroups';
+
+1;