lib/DBIx/Class/CDBICompat/ColumnCase.pm

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