X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=a4ceff83f37068cacd4c9ab69238c57a89b86903;hb=3d18a9c1993fb77df13803ad30978c590fb872e4;hp=a7e85be061135179abe0d0adb9056d533100dca8;hpb=c687b87e860c97257542dda2b14c0137f6fbc583;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index a7e85be..a4ceff8 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,12 +3,43 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -use NEXT; +use Carp::Clan qw/^DBIx::Class/; + +=head1 NAME + +DBIx::Class::AccessorGroup - Lets you build groups of accessors + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +This class lets you build groups of accessors that will call different +getters and setters. + +=head1 METHODS + +=head2 mk_group_accessors + +Creates a set of accessors in a given group. + +=head3 Arguments: $group, @fieldspec + +$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. + +@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 ]. + +=head3 Return value: none + +=cut sub mk_group_accessors { - my($self, $group, @fields) = @_; + my ($self, $group, @fields) = @_; - $self->_mk_group_accessors('make_group_accessor', $group, @fields); + $self->_mk_group_accessors('make_group_accessor', $group, @fields); + return; } @@ -25,8 +56,7 @@ sub mk_group_accessors { foreach my $field (@fields) { if( $field eq 'DESTROY' ) { - require Carp; - &Carp::carp("Having a data accessor named DESTROY in ". + carp("Having a data accessor named DESTROY in ". "'$class' is unwise."); } @@ -48,18 +78,53 @@ sub mk_group_accessors { } } +=head2 mk_group_ro_accessors + +Creates a set of read only accessors in a given group. Identical to + but accessors will throw an error if passed a value +rather than setting the value. + +=head3 Arguments: $group, @fieldspec + +=head3 Return value: none + +=cut + sub mk_group_ro_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); } +=head2 mk_group_wo_accessors + +Creates a set of write only accessors in a given group. Identical to + but accessors will throw an error if not passed a +value rather than getting the value. + +=head3 Arguments: $group, @fieldspec + +=head3 Return value: none + +=cut + sub mk_group_wo_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); } +=head2 make_group_accessor + +Returns a single accessor in a given group; called by mk_group_accessors +for each entry in @fieldspec. + +=head3 Arguments: $group, $field + +=head3 Return value: $sub (\CODE) + +=cut + sub make_group_accessor { my ($class, $group, $field) = @_; @@ -79,6 +144,17 @@ sub make_group_accessor { }; } +=head2 make_group_ro_accessor + +Returns a single read-only accessor in a given group; called by +mk_group_ro_accessors for each entry in @fieldspec. + +=head3 Arguments: $group, $field + +=head3 Return value: $sub (\CODE) + +=cut + sub make_group_ro_accessor { my($class, $group, $field) = @_; @@ -89,8 +165,7 @@ sub make_group_ro_accessor { if(@_) { my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot alter the value of '$field' on ". + croak("'$caller' cannot alter the value of '$field' on ". "objects of class '$class'"); } else { @@ -99,6 +174,17 @@ sub make_group_ro_accessor { }; } +=head2 make_group_wo_accessor + +Returns a single write-only accessor in a given group; called by +mk_group_wo_accessors for each entry in @fieldspec. + +=head3 Arguments: $group, $field + +=head3 Return value: $sub (\CODE) + +=cut + sub make_group_wo_accessor { my($class, $group, $field) = @_; @@ -109,8 +195,7 @@ sub make_group_wo_accessor { unless (@_) { my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot access the value of '$field' on ". + croak("'$caller' cannot access the value of '$field' on ". "objects of class '$class'"); } else { @@ -119,4 +204,92 @@ sub make_group_wo_accessor { }; } +=head2 get_simple + +Simple getter for hash-based objects which returns the value for the field +name passed as an argument. + +=head3 Arguments: $field + +=head3 Return value: $value + +=cut + +sub get_simple { + my ($self, $get) = @_; + return $self->{$get}; +} + +=head2 set_simple + +Simple setter for hash-based objects which sets and then returns the value +for the field name passed as an argument. + +=head3 Arguments: $field, $new_value + +=head3 Return value: $new_value + +=cut + +sub set_simple { + my ($self, $set, $val) = @_; + return $self->{$set} = $val; +} + +=head2 get_component_class + +Returns the class name for a component; returns an object key if called on +an object, or attempts to return classdata referenced by _$name if called +on a class. + +=head3 Arguments: $name + +=head3 Return value: $component_class + +=cut + +sub get_component_class { + my ($self, $get) = @_; + if (ref $self) { + return $self->{$get}; + } else { + $get = "_$get"; + return $self->can($get) ? $self->$get : undef; + } +} + +=head2 set_component_class + +Sets a component class name; attempts to require the class before setting +but does not error if unable to do so. Sets an object key of the given name +if called or an object or classdata called _$name if called on a class. + +=head3 Arguments: $name, $new_component_class + +=head3 Return value: $new_component_class + +=cut + +sub set_component_class { + my ($self, $set, $val) = @_; + eval "require $val"; + if (ref $self) { + return $self->{$set} = $val; + } else { + $set = "_$set"; + return $self->can($set) ? $self->$set($val) : $self->mk_classdata($set => $val); + } +} + 1; + +=head1 AUTHORS + +Matt S. Trout + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut +