lib/DBIx/Class/CDBICompat/ColumnCase.pm

   1 package # hide from PAUSE
   2     DBIx::Class::CDBICompat::ColumnCase;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/DBIx::Class/;
   8
   9 sub _register_column_group {
  10   my ($class, $group, @cols) = @_;
  11   return $class->next::method($group => map lc, @cols);
  12 }
  13
  14 sub add_columns {
  15   my ($class, @cols) = @_;
  16   $class->mk_group_accessors(column => @cols);
  17   $class->result_source_instance->add_columns(map lc, @cols);
  18 }
  19
  20 sub has_a {
  21   my ($class, $col, @rest) = @_;
  22   $class->next::method(lc($col), @rest);
  23   $class->mk_group_accessors('inflated_column' => $col);
  24   return 1;
  25 }
  26
  27 sub has_many {
  28   my ($class, $rel, $f_class, $f_key, @rest) = @_;
  29   return $class->next::method($rel, $f_class, ( ref($f_key) ?
  30                                                           $f_key :
  31                                                           lc($f_key) ), @rest);
  32 }
  33
  34 sub get_inflated_column {
  35   my ($class, $get, @rest) = @_;
  36   return $class->next::method(lc($get), @rest);
  37 }
  38
  39 sub store_inflated_column {
  40   my ($class, $set, @rest) = @_;
  41   return $class->next::method(lc($set), @rest);
  42 }
  43
  44 sub set_inflated_column {
  45   my ($class, $set, @rest) = @_;
  46   return $class->next::method(lc($set), @rest);
  47 }
  48
  49 sub get_column {
  50   my ($class, $get, @rest) = @_;
  51   return $class->next::method(lc($get), @rest);
  52 }
  53
  54 sub set_column {
  55   my ($class, $set, @rest) = @_;
  56   return $class->next::method(lc($set), @rest);
  57 }
  58
  59 sub store_column {
  60   my ($class, $set, @rest) = @_;
  61   return $class->next::method(lc($set), @rest);
  62 }
  63
  64 sub find_column {
  65   my ($class, $col) = @_;
  66   return $class->next::method(lc($col));
  67 }
  68
  69 # _build_query
  70 #
  71 # Build a query hash for find, et al. Overrides Retrieve::_build_query.
  72
  73 sub _build_query {
  74   my ($self, $query) = @_;
  75
  76   my %new_query;
  77   $new_query{lc $_} = $query->{$_} for keys %$query;
  78
  79   return \%new_query;
  80 }
  81
  82
  83 # CDBI will never overwrite an accessor, but it only uses one
  84 # accessor for all column types.  DBIC uses many different
  85 # accessor types so, for example, if you declare a column()
  86 # and then a has_a() for that same column it must overwrite.
  87 #
  88 # To make this work CDBICompat has decide if an accessor
  89 # method was put there by itself and only then overwrite.
  90 {
  91   my %our_accessors;
  92
  93   sub _has_custom_accessor {
  94     my($class, $name) = @_;
  95
  96     no strict 'refs';
  97     my $existing_accessor = *{$class .'::'. $name}{CODE};
  98     return $existing_accessor && !$our_accessors{$existing_accessor};
  99   }
 100
 101   sub _deploy_accessor {
 102     my($class, $name, $accessor) = @_;
 103
 104     return if $class->_has_custom_accessor($name);
 105
 106     for my $name ($name, lc $name) {
 107       no strict 'refs';
 108       no warnings 'redefine';
 109       *{$class .'::'. $name} = $accessor;
 110     }
 111
 112     $our_accessors{$accessor}++;
 113
 114     return 1;
 115   }
 116 }
 117
 118 sub _mk_group_accessors {
 119   my ($class, $type, $group, @fields) = @_;
 120
 121   # So we don't have to do lots of lookups inside the loop.
 122   my $maker = $class->can($type) unless ref $type;
 123
 124   # warn "$class $type $group\n";
 125   foreach my $field (@fields) {
 126     if( $field eq 'DESTROY' ) {
 127         carp("Having a data accessor named DESTROY in ".
 128              "'$class' is unwise.");
 129     }
 130
 131     my $name = $field;
 132
 133     ($name, $field) = @$field if ref $field;
 134
 135     my $accessor = $class->$maker($group, $field);
 136     my $alias = "_${name}_accessor";
 137
 138     # warn "  $field $alias\n";
 139     {
 140       no strict 'refs';
 141
 142       $class->_deploy_accessor($name,  $accessor);
 143       $class->_deploy_accessor($alias, $accessor);
 144     }
 145   }
 146 }
 147
 148 sub new {
 149   my ($class, $attrs, @rest) = @_;
 150   my %att;
 151   $att{lc $_} = $attrs->{$_} for keys %$attrs;
 152   return $class->next::method(\%att, @rest);
 153 }
 154
 155 1;