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->mk_group_accessors('has_a' => $col);
  21   return 1;
  22 }
  23
  24 sub has_many {
  25   my ($class, $rel, $f_class, $f_key, @rest) = @_;
  26   return $class->NEXT::ACTUAL::has_many($rel, $f_class, lc($f_key), @rest);
  27 }
  28
  29 sub get_has_a {
  30   my ($class, $get, @rest) = @_;
  31   return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest);
  32 }
  33
  34 sub store_has_a {
  35   my ($class, $set, @rest) = @_;
  36   return $class->NEXT::ACTUAL::store_has_a(lc($set), @rest);
  37 }
  38
  39 sub set_has_a {
  40   my ($class, $set, @rest) = @_;
  41   return $class->NEXT::ACTUAL::set_has_a(lc($set), @rest);
  42 }
  43
  44 sub get_column {
  45   my ($class, $get, @rest) = @_;
  46   return $class->NEXT::ACTUAL::get_column(lc($get), @rest);
  47 }
  48
  49 sub set_column {
  50   my ($class, $set, @rest) = @_;
  51   return $class->NEXT::ACTUAL::set_column(lc($set), @rest);
  52 }
  53
  54 sub store_column {
  55   my ($class, $set, @rest) = @_;
  56   return $class->NEXT::ACTUAL::store_column(lc($set), @rest);
  57 }
  58
  59 sub find_column {
  60   my ($class, $col) = @_;
  61   return $class->NEXT::ACTUAL::find_column(lc($col));
  62 }
  63
  64 sub _mk_group_accessors {
  65   my ($class, $type, $group, @fields) = @_;
  66   #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
  67   my @extra;
  68   foreach (@fields) {
  69     my ($acc, $field) = ref $_ ? @$_ : ($_, $_);
  70     #warn "$acc ".lc($acc)." $field";
  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;