lib/DBIx/Class/InflateColumn.pm

   1 package DBIx::Class::InflateColumn;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw/croak/;
   7
   8 use base qw/DBIx::Class::Row/;
   9
  10 =head1 NAME
  11
  12 DBIx::Class::InflateColumn - Automatically create objects from column data
  13
  14 =head1 SYNOPSIS
  15
  16     # In your table classes
  17     __PACKAGE__->inflate_column('column_name', {
  18         inflate => sub { ... },
  19         deflate => sub { ... },
  20     });
  21
  22 =head1 DESCRIPTION
  23
  24 This component translates column data into objects, i.e. "inflating"
  25 the column data. It also "deflates" objects into an appropriate format
  26 for the database.
  27
  28 It can be used, for example, to automatically convert to and from
  29 L<DateTime> objects for your date and time fields.
  30
  31 =head1 METHODS
  32
  33 =head2 inflate_column
  34
  35 Instruct L<DBIx::Class> to inflate the given column.
  36
  37 In addition to the column name, you must provide C<inflate> and
  38 C<deflate> methods. The C<inflate> method is called when you access
  39 the field, while the C<deflate> method is called when the field needs
  40 to used by the database.
  41
  42 For example, if you have a table C<events> with a timestamp field
  43 named C<insert_time>, you could inflate the column in the
  44 corresponding table class using something like:
  45
  46     __PACKAGE__->inflate_column('insert_time', {
  47         inflate => sub { DateTime::Format::Pg->parse_datetime(shift); },
  48         deflate => sub { DateTime::Format::Pg->format_datetime(shift); },
  49     });
  50
  51 (Replace L<DateTime::Format::Pg> with the appropriate module for your
  52 database, or consider L<DateTime::Format::DBI>.)
  53
  54 In this example, calls to an event's C<insert_time> accessor return a
  55 L<DateTime> object. This L<DateTime> object is later "deflated" when
  56 used in the database layer.
  57
  58 =cut
  59
  60 sub inflate_column {
  61   my ($self, $col, $attrs) = @_;
  62   croak "No such column $col to inflate" unless $self->has_column($col);
  63   croak "inflate_column needs attr hashref" unless ref $attrs eq 'HASH';
  64   $self->column_info($col)->{_inflate_info} = $attrs;
  65   $self->mk_group_accessors('inflated_column' => $col);
  66   return 1;
  67 }
  68
  69 sub _inflated_column {
  70   my ($self, $col, $value) = @_;
  71   return $value unless defined $value; # NULL is NULL is NULL
  72   my $info = $self->column_info($col) || croak "No column info for $col";
  73   return $value unless exists $info->{_inflate_info};
  74   my $inflate = $info->{_inflate_info}{inflate};
  75   croak "No inflator for $col" unless defined $inflate;
  76   return $inflate->($value, $self);
  77 }
  78
  79 sub _deflated_column {
  80   my ($self, $col, $value) = @_;
  81   return $value unless ref $value; # If it's not an object, don't touch it
  82   my $info = $self->column_info($col) || croak "No column info for $col";
  83   return $value unless exists $info->{_inflate_info};
  84   my $deflate = $info->{_inflate_info}{deflate};
  85   croak "No deflator for $col" unless defined $deflate;
  86   return $deflate->($value, $self);
  87 }
  88
  89 sub get_inflated_column {
  90   my ($self, $col) = @_;
  91   $self->throw("$col is not an inflated column") unless
  92     exists $self->column_info($col)->{_inflate_info};
  93
  94   return $self->{_inflated_column}{$col}
  95     if exists $self->{_inflated_column}{$col};
  96   return $self->{_inflated_column}{$col} =
  97            $self->_inflated_column($col, $self->get_column($col));
  98 }
  99
 100 sub set_inflated_column {
 101   my ($self, $col, @rest) = @_;
 102   my $ret = $self->_inflated_column_op('set', $col, @rest);
 103   return $ret;
 104 }
 105
 106 sub store_inflated_column {
 107   my ($self, $col, @rest) = @_;
 108   my $ret = $self->_inflated_column_op('store', $col, @rest);
 109   return $ret;
 110 }
 111
 112 sub _inflated_column_op {
 113   my ($self, $op, $col, $obj) = @_;
 114   my $meth = "${op}_column";
 115   unless (ref $obj) {
 116     delete $self->{_inflated_column}{$col};
 117     return $self->$meth($col, $obj);
 118   }
 119
 120   my $deflated = $self->_deflated_column($col, $obj);
 121            # Do this now so we don't store if it's invalid
 122
 123   $self->{_inflated_column}{$col} = $obj;
 124   $self->$meth($col, $deflated);
 125   return $obj;
 126 }
 127
 128 sub new {
 129   my ($class, $attrs, @rest) = @_;
 130   $attrs ||= {};
 131   foreach my $key (keys %$attrs) {
 132     if (ref $attrs->{$key}
 133           && exists $class->column_info($key)->{_inflate_info}) {
 134       $attrs->{$key} = $class->_deflated_column($key, $attrs->{$key});
 135     }
 136   }
 137   return $class->next::method($attrs, @rest);
 138 }
 139
 140 =head1 SEE ALSO
 141
 142 =over 4
 143
 144 =item L<DBIx::Class::Core> - This component is loaded as part of the
 145       "core" L<DBIx::Class> components; generally there is no need to
 146       load it directly
 147
 148 =back
 149
 150 =head1 AUTHOR
 151
 152 Matt S. Trout <mst@shadowcatsystems.co.uk>
 153
 154 =head1 CONTRIBUTORS
 155
 156 Daniel Westermann-Clark <danieltwc@cpan.org> (documentation)
 157
 158 =head1 LICENSE
 159
 160 You may distribute this code under the same terms as Perl itself.
 161
 162 =cut
 163
 164 1;