X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCDBICompat%2FColumnGroups.pm;h=47eefd5ddfbfc8124f6160ce0b0e0b5704702a88;hb=514b84f6b60b566d75d2ff2ddd08659c4cf7b427;hp=6efd72519d4f5479b60291ed9391ef6eb2889cc1;hpb=c0eb27e8608791775aff1a8d35fe14b4abf011b0;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 6efd725..47eefd5 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -4,10 +4,12 @@ package # hide from PAUSE use strict; use warnings; -use Storable 'dclone'; - use base qw/DBIx::Class::Row/; +use List::Util (); +use DBIx::Class::_Util 'set_subname'; +use namespace::clean; + __PACKAGE__->mk_classdata('_column_groups' => { }); sub columns { @@ -19,7 +21,10 @@ sub columns { $class->_add_column_group($group => @_) if @_; return $class->all_columns if $group eq "All"; return $class->primary_column if $group eq "Primary"; - return keys %{$class->_column_groups->{$group}}; + + my $grp = $class->_column_groups->{$group}; + my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp); + return @grp_cols; } sub _add_column_group { @@ -39,11 +44,13 @@ sub _register_column_group { # Must do a complete deep copy else column groups # might accidentally be shared. - my $groups = dclone $class->_column_groups; + my $groups = DBIx::Class::_Util::deep_clone( $class->_column_groups ); if ($group eq 'Primary') { $class->set_primary_key(@cols); - $groups->{'Essential'}{$_} ||= 1 for @cols; + delete $groups->{'Essential'}{$_} for @cols; + my $first = List::Util::max(values %{$groups->{'Essential'}}); + $groups->{'Essential'}{$_} = ++$first for reverse @cols; } if ($group eq 'All') { @@ -56,7 +63,9 @@ sub _register_column_group { } } - $groups->{$group}{$_} ||= 1 for @cols; + delete $groups->{$group}{$_} for @cols; + my $first = List::Util::max(values %{$groups->{$group}}); + $groups->{$group}{$_} = ++$first for reverse @cols; $class->_column_groups($groups); } @@ -73,10 +82,26 @@ sub _register_column_group { sub _has_custom_accessor { my($class, $name) = @_; - + no strict 'refs'; my $existing_accessor = *{$class .'::'. $name}{CODE}; - return $existing_accessor && !$our_accessors{$existing_accessor}; + + return( + defined $existing_accessor + and + ! $our_accessors{$existing_accessor} + and + # under 5.8 mro the CODE slot may simply be a "cached method" + ! ( + DBIx::Class::_ENV_::OLD_MRO + and + grep { + $_ ne $class + and + ($_->can($name)||0) == $existing_accessor + } @{mro::get_linear_isa($class)} + ) + ) } sub _deploy_accessor { @@ -87,9 +112,10 @@ sub _register_column_group { { no strict 'refs'; no warnings 'redefine'; - *{$class .'::'. $name} = $accessor; + my $fullname = join '::', $class, $name; + *$fullname = set_subname $fullname, $accessor; } - + $our_accessors{$accessor}++; return 1; @@ -113,15 +139,11 @@ sub _mk_group_accessors { ($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); + for( $name, "_${name}_accessor" ) { + $class->_deploy_accessor( + $_, + $class->$maker($group, $field, $_) + ); } } } @@ -154,7 +176,8 @@ sub _find_columns { return map { $class->find_column($_) } @col; } -package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim; +package # hide from PAUSE (should be harmless, no POD no Version) + DBIx::Class::CDBICompat::ColumnGroups::GrouperShim; sub groups_for { my ($self, @cols) = @_; @@ -166,6 +189,5 @@ sub groups_for { } return keys %groups; } - 1;