Commit | Line | Data |
75d07914 |
1 | package # hide from PAUSE |
c0e7b4e5 |
2 | DBIx::Class::CDBICompat::ColumnGroups; |
ea2e61bf |
3 | |
4 | use strict; |
5 | use warnings; |
ddc0a6c8 |
6 | use Sub::Name (); |
b818efd7 |
7 | use List::Util (); |
96eab6f8 |
8 | |
75a23b3e |
9 | use base qw/DBIx::Class::Row/; |
ea2e61bf |
10 | |
11 | __PACKAGE__->mk_classdata('_column_groups' => { }); |
12 | |
ea2e61bf |
13 | sub 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 |
28 | sub _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 |
35 | sub add_columns { |
36 | my ($class, @cols) = @_; |
37 | $class->result_source_instance->add_columns(@cols); |
38 | } |
39 | |
ea2e61bf |
40 | sub _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}; |
1e023345 |
86 | |
87 | return( |
88 | defined $existing_accessor |
89 | and |
90 | ! $our_accessors{$existing_accessor} |
91 | and |
92 | # under 5.8 mro the CODE slot may simply be a "cached method" |
93 | ! ( |
94 | DBIx::Class::_ENV_::OLD_MRO |
95 | and |
96 | grep { |
97 | $_ ne $class |
98 | and |
99 | ($_->can($name)||0) == $existing_accessor |
100 | } @{mro::get_linear_isa($class)} |
101 | ) |
102 | ) |
8da46543 |
103 | } |
104 | |
105 | sub _deploy_accessor { |
106 | my($class, $name, $accessor) = @_; |
107 | |
108 | return if $class->_has_custom_accessor($name); |
109 | |
110 | { |
111 | no strict 'refs'; |
112 | no warnings 'redefine'; |
ddc0a6c8 |
113 | my $fullname = join '::', $class, $name; |
114 | *$fullname = Sub::Name::subname $fullname, $accessor; |
8da46543 |
115 | } |
d4daee7b |
116 | |
8da46543 |
117 | $our_accessors{$accessor}++; |
118 | |
119 | return 1; |
120 | } |
121 | } |
122 | |
123 | sub _mk_group_accessors { |
124 | my ($class, $type, $group, @fields) = @_; |
125 | |
126 | # So we don't have to do lots of lookups inside the loop. |
127 | my $maker = $class->can($type) unless ref $type; |
128 | |
129 | # warn "$class $type $group\n"; |
130 | foreach my $field (@fields) { |
131 | if( $field eq 'DESTROY' ) { |
132 | carp("Having a data accessor named DESTROY in ". |
133 | "'$class' is unwise."); |
134 | } |
135 | |
136 | my $name = $field; |
137 | |
138 | ($name, $field) = @$field if ref $field; |
139 | |
140 | my $accessor = $class->$maker($group, $field); |
141 | my $alias = "_${name}_accessor"; |
142 | |
143 | # warn " $field $alias\n"; |
144 | { |
145 | no strict 'refs'; |
d4daee7b |
146 | |
8da46543 |
147 | $class->_deploy_accessor($name, $accessor); |
148 | $class->_deploy_accessor($alias, $accessor); |
149 | } |
150 | } |
151 | } |
152 | |
8c49f629 |
153 | sub all_columns { return shift->result_source_instance->columns; } |
ea2e61bf |
154 | |
155 | sub primary_column { |
156 | my ($class) = @_; |
103647d5 |
157 | my @pri = $class->primary_columns; |
ea2e61bf |
158 | return wantarray ? @pri : $pri[0]; |
159 | } |
160 | |
902133a3 |
161 | sub _essential { |
162 | return shift->columns("Essential"); |
163 | } |
164 | |
ea2e61bf |
165 | sub find_column { |
166 | my ($class, $col) = @_; |
103647d5 |
167 | return $col if $class->has_column($col); |
ea2e61bf |
168 | } |
169 | |
170 | sub __grouper { |
171 | my ($class) = @_; |
04786a4c |
172 | my $grouper = { class => $class }; |
173 | return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim'); |
ea2e61bf |
174 | } |
175 | |
176 | sub _find_columns { |
177 | my ($class, @col) = @_; |
178 | return map { $class->find_column($_) } @col; |
179 | } |
180 | |
b24d86a1 |
181 | package # hide from PAUSE (should be harmless, no POD no Version) |
182 | DBIx::Class::CDBICompat::ColumnGroups::GrouperShim; |
ea2e61bf |
183 | |
184 | sub groups_for { |
185 | my ($self, @cols) = @_; |
186 | my %groups; |
187 | foreach my $col (@cols) { |
188 | foreach my $group (keys %{$self->{class}->_column_groups}) { |
189 | $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col}; |
190 | } |
191 | } |
192 | return keys %groups; |
193 | } |
ea2e61bf |
194 | |
195 | 1; |