X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCDBICompat%2FColumnCase.pm;h=c1a1cd3a4202d6a150a55b20df46537bb3ddf616;hb=8da46543004ecb546d27b1cc40450d7160e8178f;hp=0f847dbfc00855a91cf57ce2c3dfc8e5cd477c89;hpb=03dc7a51297ef94935ec776ee35421a1e131fdbb;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 0f847db..c1a1cd3 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -79,72 +79,16 @@ sub _build_query { return \%new_query; } +sub _deploy_accessor { + my($class, $name, $accessor) = @_; -# CDBI will never overwrite an accessor, but it only uses one -# accessor for all column types. DBIC uses many different -# accessor types so, for example, if you declare a column() -# and then a has_a() for that same column it must overwrite. -# -# To make this work CDBICompat has decide if an accessor -# method was put there by itself and only then overwrite. -{ - my %our_accessors; - - sub _has_custom_accessor { - my($class, $name) = @_; - - no strict 'refs'; - my $existing_accessor = *{$class .'::'. $name}{CODE}; - return $existing_accessor && !$our_accessors{$existing_accessor}; - } - - sub _deploy_accessor { - my($class, $name, $accessor) = @_; - - return if $class->_has_custom_accessor($name); - - for my $name ($name, lc $name) { - no strict 'refs'; - no warnings 'redefine'; - *{$class .'::'. $name} = $accessor; - } - - $our_accessors{$accessor}++; - - return 1; - } -} - -sub _mk_group_accessors { - my ($class, $type, $group, @fields) = @_; - - # So we don't have to do lots of lookups inside the loop. - my $maker = $class->can($type) unless ref $type; - - # warn "$class $type $group\n"; - foreach my $field (@fields) { - if( $field eq 'DESTROY' ) { - carp("Having a data accessor named DESTROY in ". - "'$class' is unwise."); - } + return if $class->_has_custom_accessor($name); - my $name = $field; - - ($name, $field) = @$field if ref $field; - - my $accessor = $class->$maker($group, $field); - my $alias = "_${name}_accessor"; - - # warn " $field $alias\n"; - { - no strict 'refs'; - - $class->_deploy_accessor($name, $accessor); - $class->_deploy_accessor($alias, $accessor); - } - } + $class->next::method(lc $name => $accessor); + return $class->next::method($name => $accessor); } + sub new { my ($class, $attrs, @rest) = @_; my %att;