1 package # hide from PAUSE
2 DBIx::Class::CDBICompat::ColumnCase;
7 use base qw/DBIx::Class/;
9 sub _register_column_group {
10 my ($class, $group, @cols) = @_;
11 return $class->next::method($group => map lc, @cols);
15 my ($class, @cols) = @_;
16 $class->mk_group_accessors(column => @cols);
17 $class->result_source_instance->add_columns(map lc, @cols);
21 my ($class, $col, @rest) = @_;
22 $class->next::method(lc($col), @rest);
23 $class->mk_group_accessors('inflated_column' => $col);
28 my ($class, $rel, $f_class, $f_key, @rest) = @_;
29 return $class->next::method($rel, $f_class, ( ref($f_key) ?
34 sub get_inflated_column {
35 my ($class, $get, @rest) = @_;
36 return $class->next::method(lc($get), @rest);
39 sub store_inflated_column {
40 my ($class, $set, @rest) = @_;
41 return $class->next::method(lc($set), @rest);
44 sub set_inflated_column {
45 my ($class, $set, @rest) = @_;
46 return $class->next::method(lc($set), @rest);
50 my ($class, $get, @rest) = @_;
51 return $class->next::method(lc($get), @rest);
55 my ($class, $set, @rest) = @_;
56 return $class->next::method(lc($set), @rest);
60 my ($class, $set, @rest) = @_;
61 return $class->next::method(lc($set), @rest);
65 my ($class, $col) = @_;
66 return $class->next::method(lc($col));
71 # Build a query hash for find, et al. Overrides Retrieve::_build_query.
74 my ($self, $query) = @_;
77 $new_query{lc $_} = $query->{$_} for keys %$query;
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.
88 # To make this work CDBICompat has decide if an accessor
89 # method was put there by itself and only then overwrite.
93 sub _has_custom_accessor {
94 my($class, $name) = @_;
97 my $existing_accessor = *{$class .'::'. $name}{CODE};
98 return $existing_accessor && !$our_accessors{$existing_accessor};
101 sub _deploy_accessor {
102 my($class, $name, $accessor) = @_;
104 return if $class->_has_custom_accessor($name);
106 for my $name ($name, lc $name) {
108 no warnings 'redefine';
109 *{$class .'::'. $name} = $accessor;
112 $our_accessors{$accessor}++;
118 sub _mk_group_accessors {
119 my ($class, $type, $group, @fields) = @_;
121 # So we don't have to do lots of lookups inside the loop.
122 my $maker = $class->can($type) unless ref $type;
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.");
133 ($name, $field) = @$field if ref $field;
135 my $accessor = $class->$maker($group, $field);
136 my $alias = "_${name}_accessor";
138 # warn " $field $alias\n";
142 $class->_deploy_accessor($name, $accessor);
143 $class->_deploy_accessor($alias, $accessor);
149 my ($class, $attrs, @rest) = @_;
151 $att{lc $_} = $attrs->{$_} for keys %$attrs;
152 return $class->next::method(\%att, @rest);