| 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 | DBIx::Class::FilterColumn::filter_column |
| 1 | 1 | 1 | 17µs | 22µs | DBIx::Class::FilterColumn::BEGIN@2 |
| 1 | 1 | 1 | 10µs | 95µs | DBIx::Class::FilterColumn::BEGIN@5 |
| 1 | 1 | 1 | 9µs | 27µs | DBIx::Class::FilterColumn::BEGIN@3 |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::_column_from_storage |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::_column_to_storage |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::get_column |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::get_columns |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::get_filtered_column |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::new |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::set_filtered_column |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::store_column |
| 0 | 0 | 0 | 0s | 0s | DBIx::Class::FilterColumn::update |
| 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 | 10 | 26µs | my ($self, $col, $attrs) = @_; | ||
| 9 | |||||
| 10 | 1 | 17µs | my $colinfo = $self->column_info($col); # spent 17µs making 1 call to DBIx::Class::ResultSourceProxy::column_info | ||
| 11 | |||||
| 12 | 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 | 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 | $self->throw_exception('filter_column expects a hashref of filter specifications') | ||||
| 20 | unless ref $attrs eq 'HASH'; | ||||
| 21 | |||||
| 22 | $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 | $colinfo->{_filter_info} = $attrs; | ||||
| 26 | my $acc = $colinfo->{accessor}; | ||||
| 27 | 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 | 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. |