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