Commit | Line | Data |
c0e7b4e5 |
1 | package # hide from PAUSE |
2 | DBIx::Class::CDBICompat::ColumnCase; |
ea2e61bf |
3 | |
4 | use strict; |
5 | use warnings; |
75a23b3e |
6 | |
7 | use base qw/DBIx::Class/; |
ea2e61bf |
8 | |
9 | sub _register_column_group { |
10 | my ($class, $group, @cols) = @_; |
147dd158 |
11 | return $class->next::method($group => map lc, @cols); |
ea2e61bf |
12 | } |
13 | |
ec77fadc |
14 | sub add_columns { |
15 | my ($class, @cols) = @_; |
1f23a877 |
16 | $class->mk_group_accessors(column => @cols); |
8c49f629 |
17 | $class->result_source_instance->add_columns(map lc, @cols); |
ec77fadc |
18 | } |
19 | |
12bbb339 |
20 | sub has_a { |
21 | my ($class, $col, @rest) = @_; |
147dd158 |
22 | $class->next::method(lc($col), @rest); |
9f300b1b |
23 | $class->mk_group_accessors('inflated_column' => $col); |
12bbb339 |
24 | return 1; |
25 | } |
26 | |
b8e1e21f |
27 | sub has_many { |
28 | my ($class, $rel, $f_class, $f_key, @rest) = @_; |
75d07914 |
29 | return $class->next::method($rel, $f_class, ( ref($f_key) ? |
30 | $f_key : |
be7fff92 |
31 | lc($f_key) ), @rest); |
b8e1e21f |
32 | } |
33 | |
9f300b1b |
34 | sub get_inflated_column { |
12bbb339 |
35 | my ($class, $get, @rest) = @_; |
147dd158 |
36 | return $class->next::method(lc($get), @rest); |
12bbb339 |
37 | } |
38 | |
9f300b1b |
39 | sub store_inflated_column { |
12bbb339 |
40 | my ($class, $set, @rest) = @_; |
147dd158 |
41 | return $class->next::method(lc($set), @rest); |
12bbb339 |
42 | } |
43 | |
9f300b1b |
44 | sub set_inflated_column { |
12bbb339 |
45 | my ($class, $set, @rest) = @_; |
147dd158 |
46 | return $class->next::method(lc($set), @rest); |
ea2e61bf |
47 | } |
48 | |
510ca912 |
49 | sub get_column { |
ea2e61bf |
50 | my ($class, $get, @rest) = @_; |
147dd158 |
51 | return $class->next::method(lc($get), @rest); |
ea2e61bf |
52 | } |
53 | |
510ca912 |
54 | sub set_column { |
ea2e61bf |
55 | my ($class, $set, @rest) = @_; |
147dd158 |
56 | return $class->next::method(lc($set), @rest); |
510ca912 |
57 | } |
58 | |
59 | sub store_column { |
60 | my ($class, $set, @rest) = @_; |
147dd158 |
61 | return $class->next::method(lc($set), @rest); |
ea2e61bf |
62 | } |
63 | |
64 | sub find_column { |
65 | my ($class, $col) = @_; |
147dd158 |
66 | return $class->next::method(lc($col)); |
ea2e61bf |
67 | } |
68 | |
9387c904 |
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 | |
e60dc79f |
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 | |
510ca912 |
118 | sub _mk_group_accessors { |
119 | my ($class, $type, $group, @fields) = @_; |
e60dc79f |
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 | } |
b8e1e21f |
145 | } |
12bbb339 |
146 | } |
147 | |
12bbb339 |
148 | sub new { |
149 | my ($class, $attrs, @rest) = @_; |
150 | my %att; |
151 | $att{lc $_} = $attrs->{$_} for keys %$attrs; |
147dd158 |
152 | return $class->next::method(\%att, @rest); |
ea2e61bf |
153 | } |
154 | |
155 | 1; |