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