From: Christopher H. Laco Date: Thu, 25 May 2006 01:05:04 +0000 (+0000) Subject: Added get_inherited/set_inherited to get/set inheritable class/object data much like... X-Git-Tag: v0.04000~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e6f2a0fd4b3bd39666fb3dcc92cc019e39d8841a;p=p5sagit%2FClass-Accessor-Grouped.git Added get_inherited/set_inherited to get/set inheritable class/object data much like Class::Data::Accessor does Added Scalar::Util/Class::ISA to requires --- diff --git a/Build.PL b/Build.PL index 751c6b3..90d70fc 100644 --- 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 --- a/MANIFEST +++ b/MANIFEST @@ -9,8 +9,12 @@ README t/accessors.t t/accessors_ro.t t/accessors_wo.t +t/inherited.t t/lib/AccessorGroups.pm t/lib/AccessorGroupsRO.pm t/lib/AccessorGroupsWO.pm +t/lib/BaseInheritedGroups.pm +t/lib/NotHashBased.pm +t/lib/SuperInheritedGroups.pm t/pod-coverage.t t/pod.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 30ef920..e9d92b5 100644 --- 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 --- 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 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: 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 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 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 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 index 0000000..0266bee --- /dev/null +++ b/t/lib/SuperInheritedGroups.pm @@ -0,0 +1,6 @@ +package SuperInheritedGroups; +use strict; +use warnings; +use base 'BaseInheritedGroups'; + +1;