Fix the skip for DBD::Multi
[dbsrgits/DBIx-Class.git] / 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;