X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=d4493e21843946da2255e2f542382091f1fea362;hb=09d8fb4a05e6cd025924cc08e41484f17a116695;hp=b8079fc8c16dc28e4d922a6e3593d5304e3b3fcb;hpb=aa1088bf7ed82084a2d4b2ca957650a15a294ab4;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index b8079fc..d4493e2 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,295 +3,121 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -use Carp::Clan qw/^DBIx::Class/; +use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped ); -=head1 NAME +use Scalar::Util 'blessed'; +use DBIx::Class::_Util 'fail_on_internal_call'; +use namespace::clean; -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) = @_; - - $self->_mk_group_accessors('make_group_accessor', $group, @fields); - return; +sub mk_classdata :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->mk_classaccessor(@_); } - -{ - no strict 'refs'; - no warnings 'redefine'; - - sub _mk_group_accessors { - my($self, $maker, $group, @fields) = @_; - my $class = ref $self || $self; - - # So we don't have to do lots of lookups inside the loop. - $maker = $self->can($maker) unless ref $maker; - - foreach my $field (@fields) { - if( $field eq 'DESTROY' ) { - carp("Having a data accessor named DESTROY in ". - "'$class' is unwise."); - } - - my $name = $field; - - ($name, $field) = @$field if ref $field; - - my $accessor = $self->$maker($group, $field); - my $alias = "_${name}_accessor"; - - #warn "$class $group $field $alias"; - - *{$class."\:\:$name"} = $accessor; - #unless defined &{$class."\:\:$field"} - - *{$class."\:\:$alias"} = $accessor; - #unless defined &{$class."\:\:$alias"} - } - } -} - -=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) = @_; - - my $set = "set_$group"; - my $get = "get_$group"; - - # Build a closure around $field. - return sub { - my $self = shift; - - if(@_) { - return $self->$set($field, @_); - } - else { - return $self->$get($field); - } - }; +sub mk_classaccessor :DBIC_method_is_indirect_sugar { + my $self = shift; + $self->mk_group_accessors('inherited', $_[0]); + (@_ > 1) + ? $self->set_inherited(@_) + : ( DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call ) + ; } -=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) = @_; - - my $get = "get_$group"; - - return sub { - my $self = shift; - - if(@_) { - my $caller = caller; - croak("'$caller' cannot alter the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->$get($field); - } - }; -} - -=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) = @_; - - my $set = "set_$group"; - - return sub { - my $self = shift; - - unless (@_) { - my $caller = caller; - croak("'$caller' cannot access the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->$set($field, @_); - } - }; -} - -=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; +sub mk_group_accessors { + my $class = shift; + my $type = shift; + + $class->next::method($type, @_); + + # label things + if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) { + + $class = ref $class + if length ref $class; + + for my $acc_pair ( + map + { [ $_, "_${_}_accessor" ] } + map + { ref $_ ? $_->[0] : $_ } + @_ + ) { + + for my $i (0, 1) { + + my $acc_name = $acc_pair->[$i]; + + attributes->import( + $class, + ( + $class->can($acc_name) + || + Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?") + ), + 'DBIC_method_is_generated_from_resultsource_metadata', + ($i + ? "DBIC_method_is_${type}_extra_accessor" + : "DBIC_method_is_${type}_accessor" + ), + ) + } + } + } } -=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 +sub get_component_class { + my $class = $_[0]->get_inherited($_[1]); + + no strict 'refs'; + if ( + defined $class + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $class + and + # It's already an object, just go for it. + ! defined blessed $class + and + ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { + $_[0]->ensure_class_loaded($class); + + ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; + } -=head3 Return value: $component_class + $class; +}; -=cut +sub set_component_class { + $_[0]->set_inherited($_[1], $_[2]); -sub get_component_class { - my ($self, $get) = @_; - if (ref $self) { - return $self->{$get}; - } else { - $get = "_$get"; - return $self->can($get) ? $self->$get : undef; - } + # trigger a load for the case of $foo->component_accessor("bar")->new + $_[0]->get_component_class($_[1]) + if defined wantarray; } -=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. +1; -=head3 Arguments: $name, $new_component_class +=head1 NAME -=head3 Return value: $new_component_class +DBIx::Class::AccessorGroup - See Class::Accessor::Grouped -=cut +=head1 SYNOPSIS -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); - } -} +=head1 DESCRIPTION -1; +This class now exists in its own right on CPAN as Class::Accessor::Grouped -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -Matt S. Trout +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut -