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};
88 defined $existing_accessor
90 ! $our_accessors{$existing_accessor}
92 # under 5.8 mro the CODE slot may simply be a "cached method"
94 DBIx::Class::_ENV_::OLD_MRO
99 ($_->can($name)||0) == $existing_accessor
100 } @{mro::get_linear_isa($class)}
105 sub _deploy_accessor {
106 my($class, $name, $accessor) = @_;
108 return if $class->_has_custom_accessor($name);
112 no warnings 'redefine';
113 my $fullname = join '::', $class, $name;
114 *$fullname = Sub::Name::subname $fullname, $accessor;
117 $our_accessors{$accessor}++;
123 sub _mk_group_accessors {
124 my ($class, $type, $group, @fields) = @_;
126 # So we don't have to do lots of lookups inside the loop.
127 my $maker = $class->can($type) unless ref $type;
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.");
138 ($name, $field) = @$field if ref $field;
140 for( $name, "_${name}_accessor" ) {
141 $class->_deploy_accessor(
143 $class->$maker($group, $field, $_)
149 sub all_columns { return shift->result_source_instance->columns; }
153 my @pri = $class->primary_columns;
154 return wantarray ? @pri : $pri[0];
158 return shift->columns("Essential");
162 my ($class, $col) = @_;
163 return $col if $class->has_column($col);
168 my $grouper = { class => $class };
169 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
173 my ($class, @col) = @_;
174 return map { $class->find_column($_) } @col;
177 package # hide from PAUSE (should be harmless, no POD no Version)
178 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
181 my ($self, @cols) = @_;
183 foreach my $col (@cols) {
184 foreach my $group (keys %{$self->{class}->_column_groups}) {
185 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};