X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=56bcf1bb85649c3398d0b7ee6df6fde50660719a;hb=096f421241;hp=9a2dd11b18122a00a4cafb5486853eeee492cab4;hpb=8091aa9182ff763aa607dd82f4d61b99f8adab37;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 9a2dd11..56bcf1b 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,7 +3,9 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -=head1 NAME +use Carp::Clan qw/^DBIx::Class/; + +=head1 NAME DBIx::Class::AccessorGroup - Lets you build groups of accessors @@ -16,12 +18,32 @@ getters and setters. =head1 METHODS +=head2 mk_group_accessors + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +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. + +@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 ]. + =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; } @@ -38,8 +60,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."); } @@ -61,18 +82,65 @@ sub mk_group_accessors { } } +=head2 mk_group_ro_accessors + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +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. + +=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 + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +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. + +=cut + sub mk_group_wo_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); } +=head2 make_group_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single accessor in a given group; called by mk_group_accessors +for each entry in @fieldspec. + +=cut + sub make_group_accessor { my ($class, $group, $field) = @_; @@ -92,6 +160,21 @@ sub make_group_accessor { }; } +=head2 make_group_ro_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single read-only accessor in a given group; called by +mk_group_ro_accessors for each entry in @fieldspec. + +=cut + sub make_group_ro_accessor { my($class, $group, $field) = @_; @@ -102,8 +185,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 { @@ -112,6 +194,21 @@ sub make_group_ro_accessor { }; } +=head2 make_group_wo_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single write-only accessor in a given group; called by +mk_group_wo_accessors for each entry in @fieldspec. + +=cut + sub make_group_wo_accessor { my($class, $group, $field) = @_; @@ -122,8 +219,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 { @@ -132,16 +228,106 @@ sub make_group_wo_accessor { }; } +=head2 get_simple + +=over 4 + +=item Arguments: $field + +Returns: $value + +=back + +Simple getter for hash-based objects which returns the value for the field +name passed as an argument. + +=cut + sub get_simple { my ($self, $get) = @_; return $self->{$get}; } +=head2 set_simple + +=over 4 + +=item Arguments: $field, $new_value + +Returns: $new_value + +=back + +Simple setter for hash-based objects which sets and then returns the value +for the field name passed as an argument. + +=cut + sub set_simple { my ($self, $set, $val) = @_; return $self->{$set} = $val; } +=head2 get_component_class + +=over 4 + +=item Arguments: $name + +Returns: $component_class + +=back + +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. + +=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 + +=over 4 + +=item Arguments: $name, $new_component_class + +Returns: $new_component_class + +=back + +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. + +=cut + +sub set_component_class { + my ($self, $set, $val) = @_; + eval "require $val"; + if ($@) { + my $val_path = $val; + $val_path =~ s{::}{/}g; + carp $@ unless $@ =~ /^Can't locate $val_path\.pm/; + } + 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