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 Storable 'dclone';
   8 use List::Util ();
   9
  10 use base qw/DBIx::Class::Row/;
  11
  12 __PACKAGE__->mk_classdata('_column_groups' => { });
  13
  14 sub 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
  29 sub _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
  36 sub add_columns {
  37   my ($class, @cols) = @_;
  38   $class->result_source_instance->add_columns(@cols);
  39 }
  40
  41 sub _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
 108 sub _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
 138 sub all_columns { return shift->result_source_instance->columns; }
 139
 140 sub primary_column {
 141   my ($class) = @_;
 142   my @pri = $class->primary_columns;
 143   return wantarray ? @pri : $pri[0];
 144 }
 145
 146 sub _essential {
 147     return shift->columns("Essential");
 148 }
 149
 150 sub find_column {
 151   my ($class, $col) = @_;
 152   return $col if $class->has_column($col);
 153 }
 154
 155 sub __grouper {
 156   my ($class) = @_;
 157   my $grouper = { class => $class };
 158   return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
 159 }
 160
 161 sub _find_columns {
 162   my ($class, @col) = @_;
 163   return map { $class->find_column($_) } @col;
 164 }
 165
 166 package # hide from PAUSE (should be harmless, no POD no Version)
 167     DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
 168
 169 sub 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
 180 1;