1 package # hide from PAUSE
2 DBIx::Class::CDBICompat::ColumnGroups;
10 use base qw/DBIx::Class::Row/;
12 __PACKAGE__->mk_classdata('_column_groups' => { });
16 my $class = ref $proto || $proto;
17 my $group = shift || "All";
18 $class->_init_result_source_instance();
20 $class->_add_column_group($group => @_) if @_;
21 return $class->all_columns if $group eq "All";
22 return $class->primary_column if $group eq "Primary";
24 my $grp = $class->_column_groups->{$group};
25 my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
29 sub _add_column_group {
30 my ($class, $group, @cols) = @_;
31 $class->mk_group_accessors(column => @cols);
32 $class->add_columns(@cols);
33 $class->_register_column_group($group => @cols);
37 my ($class, @cols) = @_;
38 $class->result_source_instance->add_columns(@cols);
41 sub _register_column_group {
42 my ($class, $group, @cols) = @_;
44 # Must do a complete deep copy else column groups
45 # might accidentally be shared.
46 my $groups = dclone $class->_column_groups;
48 if ($group eq 'Primary') {
49 $class->set_primary_key(@cols);
50 delete $groups->{'Essential'}{$_} for @cols;
51 my $first = List::Util::max(values %{$groups->{'Essential'}});
52 $groups->{'Essential'}{$_} = ++$first for reverse @cols;
55 if ($group eq 'All') {
56 unless (exists $class->_column_groups->{'Primary'}) {
57 $groups->{'Primary'}{$cols[0]} = 1;
58 $class->set_primary_key($cols[0]);
60 unless (exists $class->_column_groups->{'Essential'}) {
61 $groups->{'Essential'}{$cols[0]} = 1;
65 delete $groups->{$group}{$_} for @cols;
66 my $first = List::Util::max(values %{$groups->{$group}});
67 $groups->{$group}{$_} = ++$first for reverse @cols;
69 $class->_column_groups($groups);
72 # CDBI will never overwrite an accessor, but it only uses one
73 # accessor for all column types. DBIC uses many different
74 # accessor types so, for example, if you declare a column()
75 # and then a has_a() for that same column it must overwrite.
77 # To make this work CDBICompat has decide if an accessor
78 # method was put there by itself and only then overwrite.
82 sub _has_custom_accessor {
83 my($class, $name) = @_;
86 my $existing_accessor = *{$class .'::'. $name}{CODE};
87 return $existing_accessor && !$our_accessors{$existing_accessor};
90 sub _deploy_accessor {
91 my($class, $name, $accessor) = @_;
93 return if $class->_has_custom_accessor($name);
97 no warnings 'redefine';
98 my $fullname = join '::', $class, $name;
99 *$fullname = Sub::Name::subname $fullname, $accessor;
102 $our_accessors{$accessor}++;
108 sub _mk_group_accessors {
109 my ($class, $type, $group, @fields) = @_;
111 # So we don't have to do lots of lookups inside the loop.
112 my $maker = $class->can($type) unless ref $type;
114 # warn "$class $type $group\n";
115 foreach my $field (@fields) {
116 if( $field eq 'DESTROY' ) {
117 carp("Having a data accessor named DESTROY in ".
118 "'$class' is unwise.");
123 ($name, $field) = @$field if ref $field;
125 my $accessor = $class->$maker($group, $field);
126 my $alias = "_${name}_accessor";
128 # warn " $field $alias\n";
132 $class->_deploy_accessor($name, $accessor);
133 $class->_deploy_accessor($alias, $accessor);
138 sub all_columns { return shift->result_source_instance->columns; }
142 my @pri = $class->primary_columns;
143 return wantarray ? @pri : $pri[0];
147 return shift->columns("Essential");
151 my ($class, $col) = @_;
152 return $col if $class->has_column($col);
157 my $grouper = { class => $class };
158 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
162 my ($class, @col) = @_;
163 return map { $class->find_column($_) } @col;
166 package # hide from PAUSE (should be harmless, no POD no Version)
167 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
170 my ($self, @cols) = @_;
172 foreach my $col (@cols) {
173 foreach my $group (keys %{$self->{class}->_column_groups}) {
174 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};