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