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   my $colinfo = $self->column_info($col);
  11
  12   $self->throw_exception('FilterColumn does not work with InflateColumn')
  13     if $self->isa('DBIx::Class::InflateColumn') &&
  14       defined $colinfo->{_inflate_info};
  15
  16   $self->throw_exception("No such column $col to filter")
  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   $self->mk_group_accessors(filtered_column => [ (defined $acc ? $acc : $col), $col]);
  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;
 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.