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
   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   return keys %{$class->_column_groups->{$group}};
  23 }
  24
  25 sub _add_column_group {
  26   my ($class, $group, @cols) = @_;
  27   $class->mk_group_accessors(column => @cols);
  28   $class->add_columns(@cols);
  29   $class->_register_column_group($group => @cols);
  30 }
  31
  32 sub add_columns {
  33   my ($class, @cols) = @_;
  34   $class->result_source_instance->add_columns(@cols);
  35 }
  36
  37 sub _register_column_group {
  38   my ($class, $group, @cols) = @_;
  39
  40   # Must do a complete deep copy else column groups
  41   # might accidentally be shared.
  42   my $groups = dclone $class->_column_groups;
  43
  44   if ($group eq 'Primary') {
  45     $class->set_primary_key(@cols);
  46     $groups->{'Essential'}{$_} ||= 1 for @cols;
  47   }
  48
  49   if ($group eq 'All') {
  50     unless (exists $class->_column_groups->{'Primary'}) {
  51       $groups->{'Primary'}{$cols[0]} = 1;
  52       $class->set_primary_key($cols[0]);
  53     }
  54     unless (exists $class->_column_groups->{'Essential'}) {
  55       $groups->{'Essential'}{$cols[0]} = 1;
  56     }
  57   }
  58
  59   $groups->{$group}{$_} ||= 1 for @cols;
  60
  61   $class->_column_groups($groups);
  62 }
  63
  64 # CDBI will never overwrite an accessor, but it only uses one
  65 # accessor for all column types.  DBIC uses many different
  66 # accessor types so, for example, if you declare a column()
  67 # and then a has_a() for that same column it must overwrite.
  68 #
  69 # To make this work CDBICompat has decide if an accessor
  70 # method was put there by itself and only then overwrite.
  71 {
  72   my %our_accessors;
  73
  74   sub _has_custom_accessor {
  75     my($class, $name) = @_;
  76
  77     no strict 'refs';
  78     my $existing_accessor = *{$class .'::'. $name}{CODE};
  79     return $existing_accessor && !$our_accessors{$existing_accessor};
  80   }
  81
  82   sub _deploy_accessor {
  83     my($class, $name, $accessor) = @_;
  84
  85     return if $class->_has_custom_accessor($name);
  86
  87     {
  88       no strict 'refs';
  89       no warnings 'redefine';
  90       my $fullname = join '::', $class, $name;
  91       *$fullname = Sub::Name::subname $fullname, $accessor;
  92     }
  93
  94     $our_accessors{$accessor}++;
  95
  96     return 1;
  97   }
  98 }
  99
 100 sub _mk_group_accessors {
 101   my ($class, $type, $group, @fields) = @_;
 102
 103   # So we don't have to do lots of lookups inside the loop.
 104   my $maker = $class->can($type) unless ref $type;
 105
 106   # warn "$class $type $group\n";
 107   foreach my $field (@fields) {
 108     if( $field eq 'DESTROY' ) {
 109         carp("Having a data accessor named DESTROY in ".
 110              "'$class' is unwise.");
 111     }
 112
 113     my $name = $field;
 114
 115     ($name, $field) = @$field if ref $field;
 116
 117     my $accessor = $class->$maker($group, $field);
 118     my $alias = "_${name}_accessor";
 119
 120     # warn "  $field $alias\n";
 121     {
 122       no strict 'refs';
 123
 124       $class->_deploy_accessor($name,  $accessor);
 125       $class->_deploy_accessor($alias, $accessor);
 126     }
 127   }
 128 }
 129
 130 sub all_columns { return shift->result_source_instance->columns; }
 131
 132 sub primary_column {
 133   my ($class) = @_;
 134   my @pri = $class->primary_columns;
 135   return wantarray ? @pri : $pri[0];
 136 }
 137
 138 sub _essential {
 139     return shift->columns("Essential");
 140 }
 141
 142 sub find_column {
 143   my ($class, $col) = @_;
 144   return $col if $class->has_column($col);
 145 }
 146
 147 sub __grouper {
 148   my ($class) = @_;
 149   my $grouper = { class => $class };
 150   return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
 151 }
 152
 153 sub _find_columns {
 154   my ($class, @col) = @_;
 155   return map { $class->find_column($_) } @col;
 156 }
 157
 158 package # hide from PAUSE (should be harmless, no POD no Version)
 159     DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
 160
 161 sub groups_for {
 162   my ($self, @cols) = @_;
 163   my %groups;
 164   foreach my $col (@cols) {
 165     foreach my $group (keys %{$self->{class}->_column_groups}) {
 166       $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
 167     }
 168   }
 169   return keys %groups;
 170 }
 171
 172 1;