lib/DBIx/Class/FilterColumn.pm

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