1 package # hide from PAUSE
2 DBIx::Class::CDBICompat::ColumnGroups;
9 use base qw/DBIx::Class::Row/;
11 __PACKAGE__->mk_classdata('_column_groups' => { });
15 my $class = ref $proto || $proto;
16 my $group = shift || "All";
17 $class->_init_result_source_instance();
19 $class->_add_column_group($group => @_) if @_;
20 return $class->all_columns if $group eq "All";
21 return $class->primary_column if $group eq "Primary";
22 return keys %{$class->_column_groups->{$group}};
25 sub _add_column_group {
26 my ($class, $group, @cols) = @_;
27 $class->add_columns(@cols);
28 $class->_register_column_group($group => @cols);
31 sub _register_column_group {
32 my ($class, $group, @cols) = @_;
34 # Must do a complete deep copy else column groups
35 # might accidentally be shared.
36 my $groups = dclone $class->_column_groups;
38 if ($group eq 'Primary') {
39 $class->set_primary_key(@cols);
40 $groups->{'Essential'}{$_} ||= 1 for @cols;
43 if ($group eq 'All') {
44 unless (exists $class->_column_groups->{'Primary'}) {
45 $groups->{'Primary'}{$cols[0]} = 1;
46 $class->set_primary_key($cols[0]);
48 unless (exists $class->_column_groups->{'Essential'}) {
49 $groups->{'Essential'}{$cols[0]} = 1;
53 $groups->{$group}{$_} ||= 1 for @cols;
55 $class->_column_groups($groups);
58 # CDBI will never overwrite an accessor, but it only uses one
59 # accessor for all column types. DBIC uses many different
60 # accessor types so, for example, if you declare a column()
61 # and then a has_a() for that same column it must overwrite.
63 # To make this work CDBICompat has decide if an accessor
64 # method was put there by itself and only then overwrite.
68 sub _has_custom_accessor {
69 my($class, $name) = @_;
72 my $existing_accessor = *{$class .'::'. $name}{CODE};
73 return $existing_accessor && !$our_accessors{$existing_accessor};
76 sub _deploy_accessor {
77 my($class, $name, $accessor) = @_;
79 return if $class->_has_custom_accessor($name);
83 no warnings 'redefine';
84 *{$class .'::'. $name} = $accessor;
87 $our_accessors{$accessor}++;
93 sub _mk_group_accessors {
94 my ($class, $type, $group, @fields) = @_;
96 # So we don't have to do lots of lookups inside the loop.
97 my $maker = $class->can($type) unless ref $type;
99 # warn "$class $type $group\n";
100 foreach my $field (@fields) {
101 if( $field eq 'DESTROY' ) {
102 carp("Having a data accessor named DESTROY in ".
103 "'$class' is unwise.");
108 ($name, $field) = @$field if ref $field;
110 my $accessor = $class->$maker($group, $field);
111 my $alias = "_${name}_accessor";
113 # warn " $field $alias\n";
117 $class->_deploy_accessor($name, $accessor);
118 $class->_deploy_accessor($alias, $accessor);
123 sub all_columns { return shift->result_source_instance->columns; }
127 my @pri = $class->primary_columns;
128 return wantarray ? @pri : $pri[0];
132 return shift->columns("Essential");
136 my ($class, $col) = @_;
137 return $col if $class->has_column($col);
142 my $grouper = { class => $class };
143 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
147 my ($class, @col) = @_;
148 return map { $class->find_column($_) } @col;
151 package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
154 my ($self, @cols) = @_;
156 foreach my $col (@cols) {
157 foreach my $group (keys %{$self->{class}->_column_groups}) {
158 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};