lib/DBIx/Class/CDBICompat/ColumnGroups.pm

   1 package # hide from PAUSE
   2     DBIx::Class::CDBICompat::ColumnGroups;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/DBIx::Class::Row/;
   8
   9 use List::Util ();
  10 use DBIx::Class::_Util 'set_subname';
  11 use namespace::clean;
  12
  13 __PACKAGE__->mk_classdata('_column_groups' => { });
  14
  15 sub columns {
  16   my $proto = shift;
  17   my $class = ref $proto || $proto;
  18   my $group = shift || "All";
  19   $class->_init_result_source_instance();
  20
  21   $class->_add_column_group($group => @_) if @_;
  22   return $class->all_columns    if $group eq "All";
  23   return $class->primary_column if $group eq "Primary";
  24
  25   my $grp = $class->_column_groups->{$group};
  26   my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
  27   return @grp_cols;
  28 }
  29
  30 sub _add_column_group {
  31   my ($class, $group, @cols) = @_;
  32   $class->mk_group_accessors(column => @cols);
  33   $class->add_columns(@cols);
  34   $class->_register_column_group($group => @cols);
  35 }
  36
  37 sub add_columns {
  38   my ($class, @cols) = @_;
  39   $class->result_source_instance->add_columns(@cols);
  40 }
  41
  42 sub _register_column_group {
  43   my ($class, $group, @cols) = @_;
  44
  45   # Must do a complete deep copy else column groups
  46   # might accidentally be shared.
  47   my $groups = DBIx::Class::_Util::deep_clone( $class->_column_groups );
  48
  49   if ($group eq 'Primary') {
  50     $class->set_primary_key(@cols);
  51     delete $groups->{'Essential'}{$_} for @cols;
  52     my $first = List::Util::max(values %{$groups->{'Essential'}});
  53     $groups->{'Essential'}{$_} = ++$first for reverse @cols;
  54   }
  55
  56   if ($group eq 'All') {
  57     unless (exists $class->_column_groups->{'Primary'}) {
  58       $groups->{'Primary'}{$cols[0]} = 1;
  59       $class->set_primary_key($cols[0]);
  60     }
  61     unless (exists $class->_column_groups->{'Essential'}) {
  62       $groups->{'Essential'}{$cols[0]} = 1;
  63     }
  64   }
  65
  66   delete $groups->{$group}{$_} for @cols;
  67   my $first = List::Util::max(values %{$groups->{$group}});
  68   $groups->{$group}{$_} = ++$first for reverse @cols;
  69
  70   $class->_column_groups($groups);
  71 }
  72
  73 # CDBI will never overwrite an accessor, but it only uses one
  74 # accessor for all column types.  DBIC uses many different
  75 # accessor types so, for example, if you declare a column()
  76 # and then a has_a() for that same column it must overwrite.
  77 #
  78 # To make this work CDBICompat has decide if an accessor
  79 # method was put there by itself and only then overwrite.
  80 {
  81   my %our_accessors;
  82
  83   sub _has_custom_accessor {
  84     my($class, $name) = @_;
  85
  86     no strict 'refs';
  87     my $existing_accessor = *{$class .'::'. $name}{CODE};
  88
  89     return(
  90       defined $existing_accessor
  91         and
  92       ! $our_accessors{$existing_accessor}
  93         and
  94       # under 5.8 mro the CODE slot may simply be a "cached method"
  95       ! (
  96         DBIx::Class::_ENV_::OLD_MRO
  97           and
  98         grep {
  99           $_ ne $class
 100             and
 101           ($_->can($name)||0) == $existing_accessor
 102         } @{mro::get_linear_isa($class)}
 103       )
 104     )
 105   }
 106
 107   sub _deploy_accessor {
 108     my($class, $name, $accessor) = @_;
 109
 110     return if $class->_has_custom_accessor($name);
 111
 112     {
 113       no strict 'refs';
 114       no warnings 'redefine';
 115       my $fullname = join '::', $class, $name;
 116       *$fullname = set_subname $fullname, $accessor;
 117     }
 118
 119     $our_accessors{$accessor}++;
 120
 121     return 1;
 122   }
 123 }
 124
 125 sub _mk_group_accessors {
 126   my ($class, $type, $group, @fields) = @_;
 127
 128   # So we don't have to do lots of lookups inside the loop.
 129   my $maker = $class->can($type) unless ref $type;
 130
 131   # warn "$class $type $group\n";
 132   foreach my $field (@fields) {
 133     if( $field eq 'DESTROY' ) {
 134         carp("Having a data accessor named DESTROY in ".
 135              "'$class' is unwise.");
 136     }
 137
 138     my $name = $field;
 139
 140     ($name, $field) = @$field if ref $field;
 141
 142     for( $name, "_${name}_accessor" ) {
 143       $class->_deploy_accessor(
 144         $_,
 145         $class->$maker($group, $field, $_)
 146       );
 147     }
 148   }
 149 }
 150
 151 sub all_columns { return shift->result_source_instance->columns; }
 152
 153 sub primary_column {
 154   my ($class) = @_;
 155   my @pri = $class->primary_columns;
 156   return wantarray ? @pri : $pri[0];
 157 }
 158
 159 sub _essential {
 160     return shift->columns("Essential");
 161 }
 162
 163 sub find_column {
 164   my ($class, $col) = @_;
 165   return $col if $class->has_column($col);
 166 }
 167
 168 sub __grouper {
 169   my ($class) = @_;
 170   my $grouper = { class => $class };
 171   return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
 172 }
 173
 174 sub _find_columns {
 175   my ($class, @col) = @_;
 176   return map { $class->find_column($_) } @col;
 177 }
 178
 179 package # hide from PAUSE (should be harmless, no POD no Version)
 180     DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
 181
 182 sub groups_for {
 183   my ($self, @cols) = @_;
 184   my %groups;
 185   foreach my $col (@cols) {
 186     foreach my $group (keys %{$self->{class}->_column_groups}) {
 187       $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
 188     }
 189   }
 190   return keys %groups;
 191 }
 192
 193 1;