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