1package # hide from PAUSE 2 DBIx::Class::CDBICompat::ColumnGroups; 3 4use strict; 5use warnings; 6use Sub::Name (); 7use Storable 'dclone'; 8use List::Util (); 9 10use base qw/DBIx::Class::Row/; 11 12__PACKAGE__->mk_classdata('_column_groups' => { }); 13 14sub columns { 15 my $proto = shift; 16 my $class = ref $proto || $proto; 17 my $group = shift || "All"; 18 $class->_init_result_source_instance(); 19 20 $class->_add_column_group($group => @_) if @_; 21 return $class->all_columns if $group eq "All"; 22 return $class->primary_column if $group eq "Primary"; 23 24 my $grp = $class->_column_groups->{$group}; 25 my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp); 26 return @grp_cols; 27} 28 29sub _add_column_group { 30 my ($class, $group, @cols) = @_; 31 $class->mk_group_accessors(column => @cols); 32 $class->add_columns(@cols); 33 $class->_register_column_group($group => @cols); 34} 35 36sub add_columns { 37 my ($class, @cols) = @_; 38 $class->result_source_instance->add_columns(@cols); 39} 40 41sub _register_column_group { 42 my ($class, $group, @cols) = @_; 43 44 # Must do a complete deep copy else column groups 45 # might accidentally be shared. 46 my $groups = dclone $class->_column_groups; 47 48 if ($group eq 'Primary') { 49 $class->set_primary_key(@cols); 50 delete $groups->{'Essential'}{$_} for @cols; 51 my $first = List::Util::max(values %{$groups->{'Essential'}}); 52 $groups->{'Essential'}{$_} = ++$first for reverse @cols; 53 } 54 55 if ($group eq 'All') { 56 unless (exists $class->_column_groups->{'Primary'}) { 57 $groups->{'Primary'}{$cols[0]} = 1; 58 $class->set_primary_key($cols[0]); 59 } 60 unless (exists $class->_column_groups->{'Essential'}) { 61 $groups->{'Essential'}{$cols[0]} = 1; 62 } 63 } 64 65 delete $groups->{$group}{$_} for @cols; 66 my $first = List::Util::max(values %{$groups->{$group}}); 67 $groups->{$group}{$_} = ++$first for reverse @cols; 68 69 $class->_column_groups($groups); 70} 71 72# CDBI will never overwrite an accessor, but it only uses one 73# accessor for all column types. DBIC uses many different 74# accessor types so, for example, if you declare a column() 75# and then a has_a() for that same column it must overwrite. 76# 77# To make this work CDBICompat has decide if an accessor 78# method was put there by itself and only then overwrite. 79{ 80 my %our_accessors; 81 82 sub _has_custom_accessor { 83 my($class, $name) = @_; 84 85 no strict 'refs'; 86 my $existing_accessor = *{$class .'::'. $name}{CODE}; 87 return $existing_accessor && !$our_accessors{$existing_accessor}; 88 } 89 90 sub _deploy_accessor { 91 my($class, $name, $accessor) = @_; 92 93 return if $class->_has_custom_accessor($name); 94 95 { 96 no strict 'refs'; 97 no warnings 'redefine'; 98 my $fullname = join '::', $class, $name; 99 *$fullname = Sub::Name::subname $fullname, $accessor; 100 } 101 102 $our_accessors{$accessor}++; 103 104 return 1; 105 } 106} 107 108sub _mk_group_accessors { 109 my ($class, $type, $group, @fields) = @_; 110 111 # So we don't have to do lots of lookups inside the loop. 112 my $maker = $class->can($type) unless ref $type; 113 114 # warn "$class $type $group\n"; 115 foreach my $field (@fields) { 116 if( $field eq 'DESTROY' ) { 117 carp("Having a data accessor named DESTROY in ". 118 "'$class' is unwise."); 119 } 120 121 my $name = $field; 122 123 ($name, $field) = @$field if ref $field; 124 125 my $accessor = $class->$maker($group, $field); 126 my $alias = "_${name}_accessor"; 127 128 # warn " $field $alias\n"; 129 { 130 no strict 'refs'; 131 132 $class->_deploy_accessor($name, $accessor); 133 $class->_deploy_accessor($alias, $accessor); 134 } 135 } 136} 137 138sub all_columns { return shift->result_source_instance->columns; } 139 140sub primary_column { 141 my ($class) = @_; 142 my @pri = $class->primary_columns; 143 return wantarray ? @pri : $pri[0]; 144} 145 146sub _essential { 147 return shift->columns("Essential"); 148} 149 150sub find_column { 151 my ($class, $col) = @_; 152 return $col if $class->has_column($col); 153} 154 155sub __grouper { 156 my ($class) = @_; 157 my $grouper = { class => $class }; 158 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim'); 159} 160 161sub _find_columns { 162 my ($class, @col) = @_; 163 return map { $class->find_column($_) } @col; 164} 165 166package # hide from PAUSE (should be harmless, no POD no Version) 167 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim; 168 169sub groups_for { 170 my ($self, @cols) = @_; 171 my %groups; 172 foreach my $col (@cols) { 173 foreach my $group (keys %{$self->{class}->_column_groups}) { 174 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col}; 175 } 176 } 177 return keys %groups; 178} 179 1801; 181