Move the code to create accessors out of ColumnCase and into ColumnGroups.
[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) = @_;
510ca912 27 $class->add_columns(@cols);
6a94f7f4 28 $class->_register_column_group($group => @cols);
ea2e61bf 29}
30
31sub _register_column_group {
32 my ($class, $group, @cols) = @_;
b8e1e21f 33
96eab6f8 34 # Must do a complete deep copy else column groups
35 # might accidentally be shared.
36 my $groups = dclone $class->_column_groups;
b8e1e21f 37
ea2e61bf 38 if ($group eq 'Primary') {
510ca912 39 $class->set_primary_key(@cols);
8eae3205 40 $groups->{'Essential'}{$_} ||= 1 for @cols;
ea2e61bf 41 }
42
ea2e61bf 43 if ($group eq 'All') {
510ca912 44 unless (exists $class->_column_groups->{'Primary'}) {
8eae3205 45 $groups->{'Primary'}{$cols[0]} = 1;
510ca912 46 $class->set_primary_key($cols[0]);
ea2e61bf 47 }
510ca912 48 unless (exists $class->_column_groups->{'Essential'}) {
8eae3205 49 $groups->{'Essential'}{$cols[0]} = 1;
ea2e61bf 50 }
51 }
52
8eae3205 53 $groups->{$group}{$_} ||= 1 for @cols;
b8e1e21f 54
ea2e61bf 55 $class->_column_groups($groups);
56}
57
8da46543 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.
62#
63# To make this work CDBICompat has decide if an accessor
64# method was put there by itself and only then overwrite.
65{
66 my %our_accessors;
67
68 sub _has_custom_accessor {
69 my($class, $name) = @_;
70
71 no strict 'refs';
72 my $existing_accessor = *{$class .'::'. $name}{CODE};
73 return $existing_accessor && !$our_accessors{$existing_accessor};
74 }
75
76 sub _deploy_accessor {
77 my($class, $name, $accessor) = @_;
78
79 return if $class->_has_custom_accessor($name);
80
81 {
82 no strict 'refs';
83 no warnings 'redefine';
84 *{$class .'::'. $name} = $accessor;
85 }
86
87 $our_accessors{$accessor}++;
88
89 return 1;
90 }
91}
92
93sub _mk_group_accessors {
94 my ($class, $type, $group, @fields) = @_;
95
96 # So we don't have to do lots of lookups inside the loop.
97 my $maker = $class->can($type) unless ref $type;
98
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.");
104 }
105
106 my $name = $field;
107
108 ($name, $field) = @$field if ref $field;
109
110 my $accessor = $class->$maker($group, $field);
111 my $alias = "_${name}_accessor";
112
113 # warn " $field $alias\n";
114 {
115 no strict 'refs';
116
117 $class->_deploy_accessor($name, $accessor);
118 $class->_deploy_accessor($alias, $accessor);
119 }
120 }
121}
122
8c49f629 123sub all_columns { return shift->result_source_instance->columns; }
ea2e61bf 124
125sub primary_column {
126 my ($class) = @_;
103647d5 127 my @pri = $class->primary_columns;
ea2e61bf 128 return wantarray ? @pri : $pri[0];
129}
130
902133a3 131sub _essential {
132 return shift->columns("Essential");
133}
134
ea2e61bf 135sub find_column {
136 my ($class, $col) = @_;
103647d5 137 return $col if $class->has_column($col);
ea2e61bf 138}
139
140sub __grouper {
141 my ($class) = @_;
04786a4c 142 my $grouper = { class => $class };
143 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
ea2e61bf 144}
145
146sub _find_columns {
147 my ($class, @col) = @_;
148 return map { $class->find_column($_) } @col;
149}
150
151package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
152
153sub groups_for {
154 my ($self, @cols) = @_;
155 my %groups;
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};
159 }
160 }
161 return keys %groups;
162}
163
164
1651;