1package # hide from PAUSE
2    DBIx::Class::CDBICompat::ColumnGroups;
3
4use strict;
5use warnings;
6use Sub::Name ();
7use Storable 'dclone';
8use List::Util ();
9
10use base qw/DBIx::Class::Row/;
11
12__PACKAGE__->mk_classdata('_column_groups' => { });
13
14sub columns {
15  my $proto = shift;
16  my $class = ref $proto || $proto;
17  my $group = shift || "All";
18  $class->_init_result_source_instance();
19
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";
23
24  my $grp = $class->_column_groups->{$group};
25  my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
26  return @grp_cols;
27}
28
29sub _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);
34}
35
36sub add_columns {
37  my ($class, @cols) = @_;
38  $class->result_source_instance->add_columns(@cols);
39}
40
41sub _register_column_group {
42  my ($class, $group, @cols) = @_;
43
44  # Must do a complete deep copy else column groups
45  # might accidentally be shared.
46  my $groups = dclone $class->_column_groups;
47
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;
53  }
54
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]);
59    }
60    unless (exists $class->_column_groups->{'Essential'}) {
61      $groups->{'Essential'}{$cols[0]} = 1;
62    }
63  }
64
65  delete $groups->{$group}{$_} for @cols;
66  my $first = List::Util::max(values %{$groups->{$group}});
67  $groups->{$group}{$_} = ++$first for reverse @cols;
68
69  $class->_column_groups($groups);
70}
71
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.
76#
77# To make this work CDBICompat has decide if an accessor
78# method was put there by itself and only then overwrite.
79{
80  my %our_accessors;
81
82  sub _has_custom_accessor {
83    my($class, $name) = @_;
84
85    no strict 'refs';
86    my $existing_accessor = *{$class .'::'. $name}{CODE};
87    return $existing_accessor && !$our_accessors{$existing_accessor};
88  }
89
90  sub _deploy_accessor {
91    my($class, $name, $accessor) = @_;
92
93    return if $class->_has_custom_accessor($name);
94
95    {
96      no strict 'refs';
97      no warnings 'redefine';
98      my $fullname = join '::', $class, $name;
99      *$fullname = Sub::Name::subname $fullname, $accessor;
100    }
101
102    $our_accessors{$accessor}++;
103
104    return 1;
105  }
106}
107
108sub _mk_group_accessors {
109  my ($class, $type, $group, @fields) = @_;
110
111  # So we don't have to do lots of lookups inside the loop.
112  my $maker = $class->can($type) unless ref $type;
113
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.");
119    }
120
121    my $name = $field;
122
123    ($name, $field) = @$field if ref $field;
124
125    my $accessor = $class->$maker($group, $field);
126    my $alias = "_${name}_accessor";
127
128    # warn "  $field $alias\n";
129    {
130      no strict 'refs';
131
132      $class->_deploy_accessor($name,  $accessor);
133      $class->_deploy_accessor($alias, $accessor);
134    }
135  }
136}
137
138sub all_columns { return shift->result_source_instance->columns; }
139
140sub primary_column {
141  my ($class) = @_;
142  my @pri = $class->primary_columns;
143  return wantarray ? @pri : $pri[0];
144}
145
146sub _essential {
147    return shift->columns("Essential");
148}
149
150sub find_column {
151  my ($class, $col) = @_;
152  return $col if $class->has_column($col);
153}
154
155sub __grouper {
156  my ($class) = @_;
157  my $grouper = { class => $class };
158  return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
159}
160
161sub _find_columns {
162  my ($class, @col) = @_;
163  return map { $class->find_column($_) } @col;
164}
165
166package # hide from PAUSE (should be harmless, no POD no Version)
167    DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
168
169sub groups_for {
170  my ($self, @cols) = @_;
171  my %groups;
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};
175    }
176  }
177  return keys %groups;
178}
179
1801;
181