X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=31cdcb0e817304f58217231e2d727436c635fac6;hb=d2308dde5718dc0f828584c3fa24d7417c484040;hp=0625f01f7238468fb1ba5798c845224f873d1b91;hpb=484c9dda865880cd4e1cda8e0117f1d073a6aa7e;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 0625f01..31cdcb0 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,160 +3,126 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -use NEXT; +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 - -=over 4 - -=cut - -sub mk_group_accessors { - my($self, $group, @fields) = @_; - - $self->_mk_group_accessors('make_group_accessor', $group, @fields); +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' ) { - require Carp; - &Carp::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"} - } - } +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 ) + ; } -sub mk_group_ro_accessors { - my($self, $group, @fields) = @_; - - $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); -} - -sub mk_group_wo_accessors { - my($self, $group, @fields) = @_; - - $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); +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" + ), + ) + } + } + } + elsif( $type eq 'inherited_ro_instance' ) { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); + } } -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 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') }; + } + + $class; +}; + +sub set_component_class { + $_[0]->set_inherited($_[1], $_[2]); + + # trigger a load for the case of $foo->component_accessor("bar")->new + $_[0]->get_component_class($_[1]) + if defined wantarray; } -sub make_group_ro_accessor { - my($class, $group, $field) = @_; - - my $get = "get_$group"; - - return sub { - my $self = shift; - - if(@_) { - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot alter the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->$get($field); - } - }; -} - -sub make_group_wo_accessor { - my($class, $group, $field) = @_; - - my $set = "set_$group"; - - return sub { - my $self = shift; +1; - unless (@_) { - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot access the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->$set($field, @_); - } - }; -} +=head1 NAME -sub get_simple { - my ($self, $get) = @_; - return $self->{$get}; -} +DBIx::Class::AccessorGroup - See Class::Accessor::Grouped -sub set_simple { - my ($self, $set, $val) = @_; - return $self->{$set} = $val; -} +=head1 SYNOPSIS -1; +=head1 DESCRIPTION -=back +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 -