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     return $existing_accessor && !$our_accessors{$existing_accessor};
  87   }
  88
  89   sub _deploy_accessor {
  90     my($class, $name, $accessor) = @_;
  91
  92     return if $class->_has_custom_accessor($name);
  93
  94     {
  95       no strict 'refs';
  96       no warnings 'redefine';
  97       my $fullname = join '::', $class, $name;
  98       *$fullname = Sub::Name::subname $fullname, $accessor;
  99     }
 100
 101     $our_accessors{$accessor}++;
 102
 103     return 1;
 104   }
 105 }
 106
 107 sub _mk_group_accessors {
 108   my ($class, $type, $group, @fields) = @_;
 109
 110   # So we don't have to do lots of lookups inside the loop.
 111   my $maker = $class->can($type) unless ref $type;
 112
 113   # warn "$class $type $group\n";
 114   foreach my $field (@fields) {
 115     if( $field eq 'DESTROY' ) {
 116         carp("Having a data accessor named DESTROY in ".
 117              "'$class' is unwise.");
 118     }
 119
 120     my $name = $field;
 121
 122     ($name, $field) = @$field if ref $field;
 123
 124     my $accessor = $class->$maker($group, $field);
 125     my $alias = "_${name}_accessor";
 126
 127     # warn "  $field $alias\n";
 128     {
 129       no strict 'refs';
 130
 131       $class->_deploy_accessor($name,  $accessor);
 132       $class->_deploy_accessor($alias, $accessor);
 133     }
 134   }
 135 }
 136
 137 sub all_columns { return shift->result_source_instance->columns; }
 138
 139 sub primary_column {
 140   my ($class) = @_;
 141   my @pri = $class->primary_columns;
 142   return wantarray ? @pri : $pri[0];
 143 }
 144
 145 sub _essential {
 146     return shift->columns("Essential");
 147 }
 148
 149 sub find_column {
 150   my ($class, $col) = @_;
 151   return $col if $class->has_column($col);
 152 }
 153
 154 sub __grouper {
 155   my ($class) = @_;
 156   my $grouper = { class => $class };
 157   return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
 158 }
 159
 160 sub _find_columns {
 161   my ($class, @col) = @_;
 162   return map { $class->find_column($_) } @col;
 163 }
 164
 165 package # hide from PAUSE (should be harmless, no POD no Version)
 166     DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
 167
 168 sub groups_for {
 169   my ($self, @cols) = @_;
 170   my %groups;
 171   foreach my $col (@cols) {
 172     foreach my $group (keys %{$self->{class}->_column_groups}) {
 173       $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
 174     }
 175   }
 176   return keys %groups;
 177 }
 178
 179 1;