X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FAccessor%2FGrouped.pm;h=933c6871b03fb37999481356e982b502659f4a26;hb=22fa67203b1d5719e7b09491e39bbde991400c53;hp=9a552ceffb3d3aa78c2f52973b0c56631afe21fb;hpb=301f15cd662f6dc75ab49fa17af40d331d191d47;p=p5sagit%2FClass-Accessor-Grouped.git diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm index 9a552ce..933c687 100644 --- a/lib/Class/Accessor/Grouped.pm +++ b/lib/Class/Accessor/Grouped.pm @@ -2,15 +2,17 @@ package Class::Accessor::Grouped; use strict; use warnings; use Carp; -use Class::ISA; -use Scalar::Util qw/blessed reftype/; +use Class::Inspector (); +use Scalar::Util qw/reftype blessed/; +use MRO::Compat; + use vars qw($VERSION); -$VERSION = '0.01'; +$VERSION = '0.07000'; =head1 NAME -Class:Accessor::Grouped- Lets you build groups of accessors +Class::Accessor::Grouped - Lets you build groups of accessors =head1 SYNOPSIS @@ -36,6 +38,10 @@ Creates a set of accessors in a given group. $group is the name of the accessor group for the generated accessors; they will call get_$group($field) on get and set_$group($field, $value) on set. +If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple' +to tell Class::Accessor::Grouped to use its own get_simple and set_simple +methods. + @fieldspec is a list of field/accessor names; if a fieldspec is a scalar this is used as both field and accessor name, if a listref it is expected to be of the form [ $accessor, $field ]. @@ -56,7 +62,7 @@ sub mk_group_accessors { sub _mk_group_accessors { my($self, $maker, $group, @fields) = @_; - my $class = ref $self || $self; + my $class = blessed $self || $self; # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; @@ -74,8 +80,6 @@ sub mk_group_accessors { my $accessor = $self->$maker($group, $field); my $alias = "_${name}_accessor"; - #warn "$class $group $field $alias"; - *{$class."\:\:$name"} = $accessor; #unless defined &{$class."\:\:$field"} @@ -282,29 +286,43 @@ 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. +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) = @_; + my $class; if (blessed $self) { - if (reftype($self) eq 'HASH' && exists $self->{$get}) { + my $reftype = reftype $self; + $class = ref $self; + + if ($reftype eq 'HASH' && exists $self->{$get}) { return $self->{$get}; - } elsif (reftype($self) ne 'HASH') { + } elsif ($reftype ne 'HASH') { croak('Cannot get inherited value on an object instance that is not hash-based'); }; + } else { + $class = $self; }; no strict 'refs'; + return ${$class.'::__cag_'.$get} if defined(${$class.'::__cag_'.$get}); + + if (!@{$class.'::__cag_supers'}) { + @{$class.'::__cag_supers'} = $self->get_super_paths; + }; - my @supers = Class::ISA::self_and_super_path(ref $self || $self); - foreach (@supers) { - return ${$_.'::_'.$get} if defined(${$_.'::_'.$get}); + foreach (@{$class.'::__cag_supers'}) { + return ${$_.'::__cag_'.$get} if defined(${$_.'::__cag_'.$get}); }; + + return undef; } =head2 set_inherited @@ -317,11 +335,13 @@ 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. +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. +B: This method will die if you try to set an object variable on a non +hash-based object. =cut @@ -329,7 +349,7 @@ sub set_inherited { my ($self, $set, $val) = @_; if (blessed $self) { - if (reftype($self) eq 'HASH') { + if (reftype $self eq 'HASH') { return $self->{$set} = $val; } else { croak('Cannot set inherited value on an object instance that is not hash-based'); @@ -337,15 +357,90 @@ sub set_inherited { } else { no strict 'refs'; - return ${$self.'::_'.$set} = $val; + return ${$self.'::__cag_'.$set} = $val; }; } +=head2 get_component_class + +=over 4 + +=item Arguments: $field + +Returns: $value + +=back + +Gets the value of the specified component class. + + __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); + + $self->result_class->method(); + + ## same as + $self->get_component_class('result_class')->method(); + +=cut + +sub get_component_class { + my ($self, $field) = @_; + + return $self->get_inherited($field); +}; + +=head2 set_component_class + +=over 4 + +=item Arguments: $field, $class + +Returns: $new_value + +=back + +Inherited accessor that automatically loads the specified class before setting +it. This method will die if the specified class could not be loaded. + + __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); + __PACKAGE__->result_class('MyClass'); + + $self->result_class->method(); + +=cut + +sub set_component_class { + my ($self, $field, $value) = @_; + + if ($value) { + local $^W = 0; + if (Class::Inspector->installed($value) && !Class::Inspector->loaded($value)) { + eval "use $value"; + + croak("Could not load $field '$value': ", $@) if $@; + }; + }; + + return $self->set_inherited($field, $value); +}; + +=head2 get_super_paths + +Returns a list of 'parent' or 'super' class names that the current class inherited from. + +=cut + +sub get_super_paths { + my $class = blessed $_[0] || $_[0]; + + return @{mro::get_linear_isa($class)}; +}; + 1; =head1 AUTHORS Matt S. Trout +Christopher H. Laco =head1 LICENSE