Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/FilterColumn.pm |
Statements | Executed 20 statements in 700µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 28µs | 274µs | filter_column | DBIx::Class::FilterColumn::
1 | 1 | 1 | 17µs | 22µs | BEGIN@2 | DBIx::Class::FilterColumn::
1 | 1 | 1 | 10µs | 95µs | BEGIN@5 | DBIx::Class::FilterColumn::
1 | 1 | 1 | 9µs | 27µs | BEGIN@3 | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | _column_from_storage | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | _column_to_storage | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | get_column | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | get_columns | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | get_filtered_column | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | new | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | set_filtered_column | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | store_column | DBIx::Class::FilterColumn::
0 | 0 | 0 | 0s | 0s | update | DBIx::Class::FilterColumn::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package DBIx::Class::FilterColumn; | ||||
2 | 3 | 22µs | 2 | 27µs | # spent 22µs (17+5) within DBIx::Class::FilterColumn::BEGIN@2 which was called:
# once (17µs+5µs) by Class::C3::Componentised::ensure_class_loaded at line 2 # spent 22µs making 1 call to DBIx::Class::FilterColumn::BEGIN@2
# spent 5µs making 1 call to strict::import |
3 | 3 | 22µs | 2 | 44µs | # spent 27µs (9+18) within DBIx::Class::FilterColumn::BEGIN@3 which was called:
# once (9µs+18µs) by Class::C3::Componentised::ensure_class_loaded at line 3 # spent 27µs making 1 call to DBIx::Class::FilterColumn::BEGIN@3
# spent 18µs making 1 call to warnings::import |
4 | |||||
5 | 3 | 628µs | 2 | 181µs | # spent 95µs (10+85) within DBIx::Class::FilterColumn::BEGIN@5 which was called:
# once (10µs+85µs) by Class::C3::Componentised::ensure_class_loaded at line 5 # spent 95µs making 1 call to DBIx::Class::FilterColumn::BEGIN@5
# spent 85µs making 1 call to base::import |
6 | |||||
7 | # spent 274µs (28+246) within DBIx::Class::FilterColumn::filter_column which was called:
# once (28µs+246µs) by Class::C3::Componentised::ensure_class_loaded at line 34 of Tapper/Schema/ReportsDB/Result/ReportFile.pm | ||||
8 | 1 | 1µs | my ($self, $col, $attrs) = @_; | ||
9 | |||||
10 | 1 | 1µs | 1 | 17µs | my $colinfo = $self->column_info($col); # spent 17µs making 1 call to DBIx::Class::ResultSourceProxy::column_info |
11 | |||||
12 | 1 | 13µs | 1 | 2µs | $self->throw_exception('FilterColumn does not work with InflateColumn') # spent 2µs making 1 call to UNIVERSAL::isa |
13 | if $self->isa('DBIx::Class::InflateColumn') && | ||||
14 | defined $colinfo->{_inflate_info}; | ||||
15 | |||||
16 | 1 | 2µs | 1 | 16µs | $self->throw_exception("No such column $col to filter") # spent 16µs making 1 call to DBIx::Class::ResultSourceProxy::has_column |
17 | unless $self->has_column($col); | ||||
18 | |||||
19 | 1 | 1µs | $self->throw_exception('filter_column expects a hashref of filter specifications') | ||
20 | unless ref $attrs eq 'HASH'; | ||||
21 | |||||
22 | 1 | 500ns | $self->throw_exception('An invocation of filter_column() must specify either a filter_from_storage or filter_to_storage') | ||
23 | unless $attrs->{filter_from_storage} || $attrs->{filter_to_storage}; | ||||
24 | |||||
25 | 1 | 800ns | $colinfo->{_filter_info} = $attrs; | ||
26 | 1 | 500ns | my $acc = $colinfo->{accessor}; | ||
27 | 1 | 2µs | 1 | 211µs | $self->mk_group_accessors(filtered_column => [ (defined $acc ? $acc : $col), $col]); # spent 211µs making 1 call to Class::Accessor::Grouped::mk_group_accessors |
28 | 1 | 4µs | return 1; | ||
29 | } | ||||
30 | |||||
31 | sub _column_from_storage { | ||||
32 | my ($self, $col, $value) = @_; | ||||
33 | |||||
34 | return $value unless defined $value; | ||||
35 | |||||
36 | my $info = $self->column_info($col) | ||||
37 | or $self->throw_exception("No column info for $col"); | ||||
38 | |||||
39 | return $value unless exists $info->{_filter_info}; | ||||
40 | |||||
41 | my $filter = $info->{_filter_info}{filter_from_storage}; | ||||
42 | |||||
43 | return defined $filter ? $self->$filter($value) : $value; | ||||
44 | } | ||||
45 | |||||
46 | sub _column_to_storage { | ||||
47 | my ($self, $col, $value) = @_; | ||||
48 | |||||
49 | my $info = $self->column_info($col) or | ||||
50 | $self->throw_exception("No column info for $col"); | ||||
51 | |||||
52 | return $value unless exists $info->{_filter_info}; | ||||
53 | |||||
54 | my $unfilter = $info->{_filter_info}{filter_to_storage}; | ||||
55 | |||||
56 | return defined $unfilter ? $self->$unfilter($value) : $value; | ||||
57 | } | ||||
58 | |||||
59 | sub get_filtered_column { | ||||
60 | my ($self, $col) = @_; | ||||
61 | |||||
62 | $self->throw_exception("$col is not a filtered column") | ||||
63 | unless exists $self->column_info($col)->{_filter_info}; | ||||
64 | |||||
65 | return $self->{_filtered_column}{$col} | ||||
66 | if exists $self->{_filtered_column}{$col}; | ||||
67 | |||||
68 | my $val = $self->get_column($col); | ||||
69 | |||||
70 | return $self->{_filtered_column}{$col} = $self->_column_from_storage($col, $val); | ||||
71 | } | ||||
72 | |||||
73 | sub get_column { | ||||
74 | my ($self, $col) = @_; | ||||
75 | if (exists $self->{_filtered_column}{$col}) { | ||||
76 | return $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col}); | ||||
77 | } | ||||
78 | |||||
79 | return $self->next::method ($col); | ||||
80 | } | ||||
81 | |||||
82 | # sadly a separate codepath in Row.pm ( used by insert() ) | ||||
83 | sub get_columns { | ||||
84 | my $self = shift; | ||||
85 | |||||
86 | foreach my $col (keys %{$self->{_filtered_column}||{}}) { | ||||
87 | $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col}) | ||||
88 | if exists $self->{_filtered_column}{$col}; | ||||
89 | } | ||||
90 | |||||
91 | $self->next::method (@_); | ||||
92 | } | ||||
93 | |||||
94 | sub store_column { | ||||
95 | my ($self, $col) = (shift, @_); | ||||
96 | |||||
97 | # blow cache | ||||
98 | delete $self->{_filtered_column}{$col}; | ||||
99 | |||||
100 | $self->next::method(@_); | ||||
101 | } | ||||
102 | |||||
103 | sub set_filtered_column { | ||||
104 | my ($self, $col, $filtered) = @_; | ||||
105 | |||||
106 | # do not blow up the cache via set_column unless necessary | ||||
107 | # (filtering may be expensive!) | ||||
108 | if (exists $self->{_filtered_column}{$col}) { | ||||
109 | return $filtered | ||||
110 | if ($self->_eq_column_values ($col, $filtered, $self->{_filtered_column}{$col} ) ); | ||||
111 | |||||
112 | $self->make_column_dirty ($col); # so the comparison won't run again | ||||
113 | } | ||||
114 | |||||
115 | $self->set_column($col, $self->_column_to_storage($col, $filtered)); | ||||
116 | |||||
117 | return $self->{_filtered_column}{$col} = $filtered; | ||||
118 | } | ||||
119 | |||||
120 | sub update { | ||||
121 | my ($self, $attrs, @rest) = @_; | ||||
122 | |||||
123 | foreach my $key (keys %{$attrs||{}}) { | ||||
124 | if ( | ||||
125 | $self->has_column($key) | ||||
126 | && | ||||
127 | exists $self->column_info($key)->{_filter_info} | ||||
128 | ) { | ||||
129 | $self->set_filtered_column($key, delete $attrs->{$key}); | ||||
130 | |||||
131 | # FIXME update() reaches directly into the object-hash | ||||
132 | # and we may *not* have a filtered value there - thus | ||||
133 | # the void-ctx filter-trigger | ||||
134 | $self->get_column($key) unless exists $self->{_column_data}{$key}; | ||||
135 | } | ||||
136 | } | ||||
137 | |||||
138 | return $self->next::method($attrs, @rest); | ||||
139 | } | ||||
140 | |||||
141 | sub new { | ||||
142 | my ($class, $attrs, @rest) = @_; | ||||
143 | my $source = $attrs->{-result_source} | ||||
144 | or $class->throw_exception('Sourceless rows are not supported with DBIx::Class::FilterColumn'); | ||||
145 | |||||
146 | my $obj = $class->next::method($attrs, @rest); | ||||
147 | foreach my $key (keys %{$attrs||{}}) { | ||||
148 | if ($obj->has_column($key) && | ||||
149 | exists $obj->column_info($key)->{_filter_info} ) { | ||||
150 | $obj->set_filtered_column($key, $attrs->{$key}); | ||||
151 | } | ||||
152 | } | ||||
153 | |||||
154 | return $obj; | ||||
155 | } | ||||
156 | |||||
157 | 1 | 2µs | 1; | ||
158 | |||||
159 | =head1 NAME | ||||
160 | |||||
161 | DBIx::Class::FilterColumn - Automatically convert column data | ||||
162 | |||||
163 | =head1 SYNOPSIS | ||||
164 | |||||
165 | In your Schema or DB class add "FilterColumn" to the top of the component list. | ||||
166 | |||||
167 | __PACKAGE__->load_components(qw( FilterColumn ... )); | ||||
168 | |||||
169 | Set up filters for the columns you want to convert. | ||||
170 | |||||
171 | __PACKAGE__->filter_column( money => { | ||||
172 | filter_to_storage => 'to_pennies', | ||||
173 | filter_from_storage => 'from_pennies', | ||||
174 | }); | ||||
175 | |||||
176 | sub to_pennies { $_[1] * 100 } | ||||
177 | |||||
178 | sub from_pennies { $_[1] / 100 } | ||||
179 | |||||
180 | 1; | ||||
181 | |||||
182 | |||||
183 | =head1 DESCRIPTION | ||||
184 | |||||
185 | This component is meant to be a more powerful, but less DWIM-y, | ||||
186 | L<DBIx::Class::InflateColumn>. One of the major issues with said component is | ||||
187 | that it B<only> works with references. Generally speaking anything that can | ||||
188 | be done with L<DBIx::Class::InflateColumn> can be done with this component. | ||||
189 | |||||
190 | =head1 METHODS | ||||
191 | |||||
192 | =head2 filter_column | ||||
193 | |||||
194 | __PACKAGE__->filter_column( colname => { | ||||
195 | filter_from_storage => 'method'|\&coderef, | ||||
196 | filter_to_storage => 'method'|\&coderef, | ||||
197 | }) | ||||
198 | |||||
199 | This is the method that you need to call to set up a filtered column. It takes | ||||
200 | exactly two arguments; the first being the column name the second being a hash | ||||
201 | reference with C<filter_from_storage> and C<filter_to_storage> set to either | ||||
202 | a method name or a code reference. In either case the filter is invoked as: | ||||
203 | |||||
204 | $row_obj->$filter_specification ($value_to_filter) | ||||
205 | |||||
206 | with C<$filter_specification> being chosen depending on whether the | ||||
207 | C<$value_to_filter> is being retrieved from or written to permanent | ||||
208 | storage. | ||||
209 | |||||
210 | If a specific directional filter is not specified, the original value will be | ||||
211 | passed to/from storage unfiltered. | ||||
212 | |||||
213 | =head2 get_filtered_column | ||||
214 | |||||
215 | $obj->get_filtered_column('colname') | ||||
216 | |||||
217 | Returns the filtered value of the column | ||||
218 | |||||
219 | =head2 set_filtered_column | ||||
220 | |||||
221 | $obj->set_filtered_column(colname => 'new_value') | ||||
222 | |||||
223 | Sets the filtered value of the column | ||||
224 | |||||
225 | =head1 EXAMPLE OF USE | ||||
226 | |||||
227 | Some databases have restrictions on values that can be passed to | ||||
228 | boolean columns, and problems can be caused by passing value that | ||||
229 | perl considers to be false (such as C<undef>). | ||||
230 | |||||
231 | One solution to this is to ensure that the boolean values are set | ||||
232 | to something that the database can handle - such as numeric zero | ||||
233 | and one, using code like this:- | ||||
234 | |||||
235 | __PACKAGE__->filter_column( | ||||
236 | my_boolean_column => { | ||||
237 | filter_to_storage => sub { $_[1] ? 1 : 0 }, | ||||
238 | } | ||||
239 | ); | ||||
240 | |||||
241 | In this case the C<filter_from_storage> is not required, as just | ||||
242 | passing the database value through to perl does the right thing. |