1 package # hide from PAUSE
2 DBIx::Class::CDBICompat::ColumnGroups;
9 use base qw/DBIx::Class::Row/;
11 __PACKAGE__->mk_classdata('_column_groups' => { });
15 my $class = ref $proto || $proto;
16 my $group = shift || "All";
17 $class->_init_result_source_instance();
19 $class->_add_column_group($group => @_) if @_;
20 return $class->all_columns if $group eq "All";
21 return $class->primary_column if $group eq "Primary";
23 my $grp = $class->_column_groups->{$group};
24 my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
28 sub _add_column_group {
29 my ($class, $group, @cols) = @_;
30 $class->mk_group_accessors(column => @cols);
31 $class->add_columns(@cols);
32 $class->_register_column_group($group => @cols);
36 my ($class, @cols) = @_;
37 $class->result_source_instance->add_columns(@cols);
40 sub _register_column_group {
41 my ($class, $group, @cols) = @_;
43 # Must do a complete deep copy else column groups
44 # might accidentally be shared.
45 my $groups = DBIx::Class::_Util::deep_clone( $class->_column_groups );
47 if ($group eq 'Primary') {
48 $class->set_primary_key(@cols);
49 delete $groups->{'Essential'}{$_} for @cols;
50 my $first = List::Util::max(values %{$groups->{'Essential'}});
51 $groups->{'Essential'}{$_} = ++$first for reverse @cols;
54 if ($group eq 'All') {
55 unless (exists $class->_column_groups->{'Primary'}) {
56 $groups->{'Primary'}{$cols[0]} = 1;
57 $class->set_primary_key($cols[0]);
59 unless (exists $class->_column_groups->{'Essential'}) {
60 $groups->{'Essential'}{$cols[0]} = 1;
64 delete $groups->{$group}{$_} for @cols;
65 my $first = List::Util::max(values %{$groups->{$group}});
66 $groups->{$group}{$_} = ++$first for reverse @cols;
68 $class->_column_groups($groups);
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.
76 # To make this work CDBICompat has decide if an accessor
77 # method was put there by itself and only then overwrite.
81 sub _has_custom_accessor {
82 my($class, $name) = @_;
85 my $existing_accessor = *{$class .'::'. $name}{CODE};
86 return $existing_accessor && !$our_accessors{$existing_accessor};
89 sub _deploy_accessor {
90 my($class, $name, $accessor) = @_;
92 return if $class->_has_custom_accessor($name);
96 no warnings 'redefine';
97 my $fullname = join '::', $class, $name;
98 *$fullname = Sub::Name::subname $fullname, $accessor;
101 $our_accessors{$accessor}++;
107 sub _mk_group_accessors {
108 my ($class, $type, $group, @fields) = @_;
110 # So we don't have to do lots of lookups inside the loop.
111 my $maker = $class->can($type) unless ref $type;
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.");
122 ($name, $field) = @$field if ref $field;
124 my $accessor = $class->$maker($group, $field);
125 my $alias = "_${name}_accessor";
127 # warn " $field $alias\n";
131 $class->_deploy_accessor($name, $accessor);
132 $class->_deploy_accessor($alias, $accessor);
137 sub all_columns { return shift->result_source_instance->columns; }
141 my @pri = $class->primary_columns;
142 return wantarray ? @pri : $pri[0];
146 return shift->columns("Essential");
150 my ($class, $col) = @_;
151 return $col if $class->has_column($col);
156 my $grouper = { class => $class };
157 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
161 my ($class, @col) = @_;
162 return map { $class->find_column($_) } @col;
165 package # hide from PAUSE (should be harmless, no POD no Version)
166 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
169 my ($self, @cols) = @_;
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};