lib/DBIx/Class/CDBICompat/ColumnGroups.pm

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