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