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     for( $name, "_${name}_accessor" ) {
 141       $class->_deploy_accessor(
 142         $_,
 143         $class->$maker($group, $field, $_)
 144       );
 145     }
 146   }
 147 }
 148
 149 sub all_columns { return shift->result_source_instance->columns; }
 150
 151 sub primary_column {
 152   my ($class) = @_;
 153   my @pri = $class->primary_columns;
 154   return wantarray ? @pri : $pri[0];
 155 }
 156
 157 sub _essential {
 158     return shift->columns("Essential");
 159 }
 160
 161 sub find_column {
 162   my ($class, $col) = @_;
 163   return $col if $class->has_column($col);
 164 }
 165
 166 sub __grouper {
 167   my ($class) = @_;
 168   my $grouper = { class => $class };
 169   return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
 170 }
 171
 172 sub _find_columns {
 173   my ($class, @col) = @_;
 174   return map { $class->find_column($_) } @col;
 175 }
 176
 177 package # hide from PAUSE (should be harmless, no POD no Version)
 178     DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
 179
 180 sub groups_for {
 181   my ($self, @cols) = @_;
 182   my %groups;
 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};
 186     }
 187   }
 188   return keys %groups;
 189 }
 190
 191 1;