partially working has_many prefetch
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Row.pm
1 package DBIx::Class::Row;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7 use Carp::Clan qw/^DBIx::Class/;
8
9 __PACKAGE__->load_components(qw/AccessorGroup/);
10
11 __PACKAGE__->mk_group_accessors('simple' => 'result_source');
12
13 =head1 NAME 
14
15 DBIx::Class::Row - Basic row methods
16
17 =head1 SYNOPSIS
18
19 =head1 DESCRIPTION
20
21 This class is responsible for defining and doing basic operations on rows
22 derived from L<DBIx::Class::ResultSource> objects.
23
24 =head1 METHODS
25
26 =head2 new
27
28   my $obj = My::Class->new($attrs);
29
30 Creates a new row object from column => value mappings passed as a hash ref
31
32 =cut
33
34 sub new {
35   my ($class, $attrs) = @_;
36   $class = ref $class if ref $class;
37   my $new = bless({ _column_data => { } }, $class);
38   if ($attrs) {
39     $new->throw_exception("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
40     while (my ($k, $v) = each %{$attrs}) {
41       $new->throw_exception("No such column $k on $class") unless $class->has_column($k);
42       $new->store_column($k => $v);
43     }
44   }
45   return $new;
46 }
47
48 =head2 insert
49
50   $obj->insert;
51
52 Inserts an object into the database if it isn't already in there. Returns
53 the object itself. Requires the object's result source to be set, or the
54 class to have a result_source_instance method.
55
56 =cut
57
58 sub insert {
59   my ($self) = @_;
60   return $self if $self->in_storage;
61   $self->{result_source} ||= $self->result_source_instance
62     if $self->can('result_source_instance');
63   my $source = $self->{result_source};
64   $self->throw_exception("No result_source set on this object; can't insert") unless $source;
65   #use Data::Dumper; warn Dumper($self);
66   $source->storage->insert($source->from, { $self->get_columns });
67   $self->in_storage(1);
68   $self->{_dirty_columns} = {};
69   $self->{related_resultsets} = {};
70   return $self;
71 }
72
73 =head2 in_storage
74
75   $obj->in_storage; # Get value
76   $obj->in_storage(1); # Set value
77
78 Indicated whether the object exists as a row in the database or not
79
80 =cut
81
82 sub in_storage {
83   my ($self, $val) = @_;
84   $self->{_in_storage} = $val if @_ > 1;
85   return $self->{_in_storage};
86 }
87
88 =head2 update
89
90   $obj->update;
91
92 Must be run on an object that is already in the database; issues an SQL
93 UPDATE query to commit any changes to the object to the db if required.
94
95 =cut
96
97 sub update {
98   my ($self, $upd) = @_;
99   $self->throw_exception( "Not in database" ) unless $self->in_storage;
100   $self->set_columns($upd) if $upd;
101   my %to_update = $self->get_dirty_columns;
102   return $self unless keys %to_update;
103   my $ident_cond = $self->ident_condition;
104   $self->throw_exception("Cannot safely update a row in a PK-less table")
105     if ! keys %$ident_cond;
106   my $rows = $self->result_source->storage->update(
107                $self->result_source->from, \%to_update, $ident_cond);
108   if ($rows == 0) {
109     $self->throw_exception( "Can't update ${self}: row not found" );
110   } elsif ($rows > 1) {
111     $self->throw_exception("Can't update ${self}: updated more than one row");
112   }
113   $self->{_dirty_columns} = {};
114   $self->{related_resultsets} = {};
115   return $self;
116 }
117
118 =head2 delete
119
120   $obj->delete
121
122 Deletes the object from the database. The object is still perfectly usable
123 accessor-wise etc. but ->in_storage will now return 0 and the object must
124 be re ->insert'ed before it can be ->update'ed
125
126 =cut
127
128 sub delete {
129   my $self = shift;
130   if (ref $self) {
131     $self->throw_exception( "Not in database" ) unless $self->in_storage;
132     my $ident_cond = $self->ident_condition;
133     $self->throw_exception("Cannot safely delete a row in a PK-less table")
134       if ! keys %$ident_cond;
135     foreach my $column (keys %$ident_cond) {
136         $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
137         unless exists $self->{_column_data}{$column};
138     }
139     $self->result_source->storage->delete(
140       $self->result_source->from, $ident_cond);
141     $self->in_storage(undef);
142   } else {
143     $self->throw_exception("Can't do class delete without a ResultSource instance")
144       unless $self->can('result_source_instance');
145     my $attrs = { };
146     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
147       $attrs = { %{ pop(@_) } };
148     }
149     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
150     $self->result_source_instance->resultset->search(@_)->delete;
151   }
152   return $self;
153 }
154
155 =head2 get_column
156
157   my $val = $obj->get_column($col);
158
159 Gets a column value from a row object. Currently, does not do
160 any queries; the column must have already been fetched from
161 the database and stored in the object.
162
163 =cut
164
165 sub get_column {
166   my ($self, $column) = @_;
167   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
168   return $self->{_column_data}{$column}
169     if exists $self->{_column_data}{$column};
170   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
171   return undef;
172 }
173
174 =head2 get_columns
175
176   my %data = $obj->get_columns;
177
178 Does C<get_column>, for all column values at once.
179
180 =cut
181
182 sub get_columns {
183   my $self = shift;
184   return %{$self->{_column_data}};
185 }
186
187 =head2 get_dirty_columns
188
189   my %data = $obj->get_dirty_columns;
190
191 Identical to get_columns but only returns those that have been changed.
192
193 =cut
194
195 sub get_dirty_columns {
196   my $self = shift;
197   return map { $_ => $self->{_column_data}{$_} }
198            keys %{$self->{_dirty_columns}};
199 }
200
201 =head2 set_column
202
203   $obj->set_column($col => $val);
204
205 Sets a column value. If the new value is different from the old one,
206 the column is marked as dirty for when you next call $obj->update.
207
208 =cut
209
210 sub set_column {
211   my $self = shift;
212   my ($column) = @_;
213   my $old = $self->get_column($column);
214   my $ret = $self->store_column(@_);
215   $self->{_dirty_columns}{$column} = 1
216     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
217   return $ret;
218 }
219
220 =head2 set_columns
221
222   my $copy = $orig->set_columns({ $col => $val, ... });
223
224 Sets more than one column value at once.
225
226 =cut
227
228 sub set_columns {
229   my ($self,$data) = @_;
230   while (my ($col,$val) = each %$data) {
231     $self->set_column($col,$val);
232   }
233   return $self;
234 }
235
236 =head2 copy
237
238   my $copy = $orig->copy({ change => $to, ... });
239
240 Inserts a new row with the specified changes.
241
242 =cut
243
244 sub copy {
245   my ($self, $changes) = @_;
246   $changes ||= {};
247   my $col_data = { %{$self->{_column_data}} };
248   foreach my $col (keys %$col_data) {
249     delete $col_data->{$col}
250       if $self->result_source->column_info($col)->{is_auto_increment};
251   }
252   my $new = bless({ _column_data => $col_data }, ref $self);
253   $new->set_columns($changes);
254   $new->insert;
255   foreach my $rel ($self->result_source->relationships) {
256     my $rel_info = $self->result_source->relationship_info($rel);
257     if ($rel_info->{attrs}{cascade_copy}) {
258       my $resolved = $self->result_source->resolve_condition(
259        $rel_info->{cond}, $rel, $new);
260       foreach my $related ($self->search_related($rel)) {
261         $related->copy($resolved);
262       }
263     }
264   }
265   return $new;
266 }
267
268 =head2 store_column
269
270   $obj->store_column($col => $val);
271
272 Sets a column value without marking it as dirty.
273
274 =cut
275
276 sub store_column {
277   my ($self, $column, $value) = @_;
278   $self->throw_exception( "No such column '${column}'" ) 
279     unless exists $self->{_column_data}{$column} || $self->has_column($column);
280   $self->throw_exception( "set_column called for ${column} without value" ) 
281     if @_ < 3;
282   return $self->{_column_data}{$column} = $value;
283 }
284
285 =head2 inflate_result
286
287   Class->inflate_result($result_source, \%me, \%prefetch?)
288
289 Called by ResultSet to inflate a result from storage
290
291 =cut
292
293 sub inflate_result {
294   my ($class, $source, $me, $prefetch) = @_;
295   #use Data::Dumper; print Dumper(@_);
296   my $new = bless({ result_source => $source,
297                     _column_data => $me,
298                     _in_storage => 1
299                   },
300                   ref $class || $class);
301   my $schema;
302   foreach my $pre (keys %{$prefetch||{}}) {
303     my $pre_val = $prefetch->{$pre};
304     my $pre_source = $source->related_source($pre);
305     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
306       unless $pre_source;
307     #warn Data::Dumper::Dumper($pre_val)." ";
308     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
309       my @pre_objects;
310       foreach my $pre_rec (@$pre_val) {
311         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_} 
312            and !defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
313           next;
314         }
315         push(@pre_objects, $pre_source->result_class->inflate_result(
316                              $pre_source, @{$pre_rec}));
317       }
318       $new->related_resultset($pre)->set_cache(\@pre_objects);
319     } else {
320       my $fetched;
321       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_} 
322          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
323       {
324         $fetched = $pre_source->result_class->inflate_result(
325                       $pre_source, @{$pre_val});      
326       }
327       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
328       $class->throw_exception("No accessor for prefetched $pre")
329        unless defined $accessor;
330       if ($accessor eq 'single') {
331         $new->{_relationship_data}{$pre} = $fetched;
332       } elsif ($accessor eq 'filter') {
333         $new->{_inflated_column}{$pre} = $fetched;
334       } else {
335        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
336       }
337     }
338   }
339   return $new;
340 }
341
342 =head2 insert_or_update
343
344   $obj->insert_or_update
345
346 Updates the object if it's already in the db, else inserts it.
347
348 =cut
349
350 sub insert_or_update {
351   my $self = shift;
352   return ($self->in_storage ? $self->update : $self->insert);
353 }
354
355 =head2 is_changed
356
357   my @changed_col_names = $obj->is_changed
358
359 =cut
360
361 sub is_changed {
362   return keys %{shift->{_dirty_columns} || {}};
363 }
364
365 =head2 result_source
366
367   Accessor to the ResultSource this object was created from
368
369 =head2 register_column
370
371 =head3 Arguments: ($column, $column_info)
372
373   Registers a column on the class. If the column_info has an 'accessor' key,
374   creates an accessor named after the value if defined; if there is no such
375   key, creates an accessor with the same name as the column
376
377 =cut
378
379 sub register_column {
380   my ($class, $col, $info) = @_;
381   my $acc = $col;
382   if (exists $info->{accessor}) {
383     return unless defined $info->{accessor};
384     $acc = [ $info->{accessor}, $col ];
385   }
386   $class->mk_group_accessors('column' => $acc);
387 }
388
389
390 =head2 throw_exception
391
392 See Schema's throw_exception.
393
394 =cut
395
396 sub throw_exception {
397   my $self=shift;
398   if (ref $self && ref $self->result_source) {
399     $self->result_source->schema->throw_exception(@_);
400   } else {
401     croak(@_);
402   }
403 }
404
405 1;
406
407 =head1 AUTHORS
408
409 Matt S. Trout <mst@shadowcatsystems.co.uk>
410
411 =head1 LICENSE
412
413 You may distribute this code under the same terms as Perl itself.
414
415 =cut
416