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