lib/DBIx/Class/CDBICompat/ColumnCase.pm

   1 package DBIx::Class::CDBICompat::ColumnCase;
   2
   3 use strict;
   4 use warnings;
   5 use NEXT;
   6
   7 sub _register_column_group {
   8   my ($class, $group, @cols) = @_;
   9   return $class->NEXT::ACTUAL::_register_column_group($group => map lc, @cols);
  10 }
  11
  12 sub _register_columns {
  13   my ($class, @cols) = @_;
  14   return $class->NEXT::ACTUAL::_register_columns(map lc, @cols);
  15 }
  16
  17 sub has_a {
  18   my ($class, $col, @rest) = @_;
  19   $class->NEXT::ACTUAL::has_a(lc($col), @rest);
  20   $class->delete_accessor($col);
  21   $class->mk_group_accessors('has_a' => $col);
  22   return 1;
  23 }
  24
  25 sub has_many {
  26   my ($class, $rel, $f_class, $f_key, @rest) = @_;
  27   return $class->NEXT::ACTUAL::has_many($rel, $f_class, lc($f_key), @rest);
  28 }
  29
  30 sub get_has_a {
  31   my ($class, $get, @rest) = @_;
  32   return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest);
  33 }
  34
  35 sub store_has_a {
  36   my ($class, $set, @rest) = @_;
  37   return $class->NEXT::ACTUAL::store_has_a(lc($set), @rest);
  38 }
  39
  40 sub set_has_a {
  41   my ($class, $set, @rest) = @_;
  42   return $class->NEXT::ACTUAL::set_has_a(lc($set), @rest);
  43 }
  44
  45 sub get_column {
  46   my ($class, $get, @rest) = @_;
  47   return $class->NEXT::ACTUAL::get_column(lc($get), @rest);
  48 }
  49
  50 sub set_column {
  51   my ($class, $set, @rest) = @_;
  52   return $class->NEXT::ACTUAL::set_column(lc($set), @rest);
  53 }
  54
  55 sub store_column {
  56   my ($class, $set, @rest) = @_;
  57   return $class->NEXT::ACTUAL::store_column(lc($set), @rest);
  58 }
  59
  60 sub find_column {
  61   my ($class, $col) = @_;
  62   return $class->NEXT::ACTUAL::find_column(lc($col));
  63 }
  64
  65 sub _mk_group_accessors {
  66   my ($class, $type, $group, @fields) = @_;
  67   #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
  68   my @extra;
  69   foreach (@fields) {
  70     my ($acc, $field) = ref $_ ? @$_ : ($_, $_);
  71     next if defined &{"${class}::${acc}"};
  72     push(@extra, [ lc $acc => $field ]);
  73   }
  74   return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group,
  75                                                      @fields, @extra);
  76 }
  77
  78 sub _cond_key {
  79   my ($class, $attrs, $key, @rest) = @_;
  80   return $class->NEXT::ACTUAL::_cond_key($attrs, lc($key), @rest);
  81 }
  82
  83 sub _cond_value {
  84   my ($class, $attrs, $key, @rest) = @_;
  85   return $class->NEXT::ACTUAL::_cond_value($attrs, lc($key), @rest);
  86 }
  87
  88 sub new {
  89   my ($class, $attrs, @rest) = @_;
  90   my %att;
  91   $att{lc $_} = $attrs->{$_} for keys %$attrs;
  92   return $class->NEXT::ACTUAL::new(\%att, @rest);
  93 }
  94
  95 1;