Merge 'trunk' into 'DBIx-Class-current'
[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__->mk_group_accessors('simple' => 'result_source');
10
11 =head1 NAME
12
13 DBIx::Class::Row - Basic row methods
14
15 =head1 SYNOPSIS
16
17 =head1 DESCRIPTION
18
19 This class is responsible for defining and doing basic operations on rows
20 derived from L<DBIx::Class::ResultSource> objects.
21
22 =head1 METHODS
23
24 =head2 new
25
26   my $obj = My::Class->new($attrs);
27
28 Creates a new row object from column => value mappings passed as a hash ref
29
30 =cut
31
32 sub new {
33   my ($class, $attrs) = @_;
34   $class = ref $class if ref $class;
35
36   my $new = { _column_data => {} };
37   bless $new, $class;
38
39   if ($attrs) {
40     $new->throw_exception("attrs must be a hashref")
41       unless ref($attrs) eq 'HASH';
42     if (my $source = delete $attrs->{-result_source}) {
43       $new->result_source($source);
44     }
45     
46     my ($related,$inflated);
47     foreach my $key (keys %$attrs) {
48       if (ref $attrs->{$key}) {
49         my $info = $class->relationship_info($key);
50         if ($info && $info->{attrs}{accessor}
51           && $info->{attrs}{accessor} eq 'single')
52         {
53           $new->set_from_related($key, $attrs->{$key});        
54           $related->{$key} = $attrs->{$key};
55           next;
56         }
57         elsif ($class->has_column($key)
58           && exists $class->column_info($key)->{_inflate_info})
59         {
60           $inflated->{$key} = $attrs->{$key};
61           next;
62         }
63       }
64       $new->throw_exception("No such column $key on $class")
65         unless $class->has_column($key);
66       $new->store_column($key => $attrs->{$key});          
67     }
68     $new->{_relationship_data} = $related if $related;
69     $new->{_inflated_column} = $inflated if $inflated;
70   }
71
72   return $new;
73 }
74
75 =head2 insert
76
77   $obj->insert;
78
79 Inserts an object into the database if it isn't already in
80 there. Returns the object itself. Requires the object's result source to
81 be set, or the class to have a result_source_instance method. To insert
82 an entirely new object into the database, use C<create> (see
83 L<DBIx::Class::ResultSet/create>).
84
85 =cut
86
87 sub insert {
88   my ($self) = @_;
89   return $self if $self->in_storage;
90   $self->{result_source} ||= $self->result_source_instance
91     if $self->can('result_source_instance');
92   my $source = $self->{result_source};
93   $self->throw_exception("No result_source set on this object; can't insert")
94     unless $source;
95   #use Data::Dumper; warn Dumper($self);
96   $source->storage->insert($source->from, { $self->get_columns });
97   $self->in_storage(1);
98   $self->{_dirty_columns} = {};
99   $self->{related_resultsets} = {};
100   undef $self->{_orig_ident};
101   return $self;
102 }
103
104 =head2 in_storage
105
106   $obj->in_storage; # Get value
107   $obj->in_storage(1); # Set value
108
109 Indicated whether the object exists as a row in the database or not
110
111 =cut
112
113 sub in_storage {
114   my ($self, $val) = @_;
115   $self->{_in_storage} = $val if @_ > 1;
116   return $self->{_in_storage};
117 }
118
119 =head2 update
120
121   $obj->update;
122
123 Must be run on an object that is already in the database; issues an SQL
124 UPDATE query to commit any changes to the object to the database if
125 required.
126
127 =cut
128
129 sub update {
130   my ($self, $upd) = @_;
131   $self->throw_exception( "Not in database" ) unless $self->in_storage;
132   my $ident_cond = $self->ident_condition;
133   $self->throw_exception("Cannot safely update a row in a PK-less table")
134     if ! keys %$ident_cond;
135   if ($upd) {
136     foreach my $key (keys %$upd) {
137       if (ref $upd->{$key}) {
138         my $info = $self->relationship_info($key);
139         if ($info && $info->{attrs}{accessor}
140           && $info->{attrs}{accessor} eq 'single')
141         {
142           my $rel = delete $upd->{$key};
143           $self->set_from_related($key => $rel);
144           $self->{_relationship_data}{$key} = $rel;          
145         } 
146         elsif ($self->has_column($key)
147           && exists $self->column_info($key)->{_inflate_info})
148         {
149           $self->set_inflated_column($key, delete $upd->{$key});          
150         }
151       }
152     }
153     $self->set_columns($upd);    
154   }
155   my %to_update = $self->get_dirty_columns;
156   return $self unless keys %to_update;
157   my $rows = $self->result_source->storage->update(
158                $self->result_source->from, \%to_update, $self->{_orig_ident} || $ident_cond);
159   if ($rows == 0) {
160     $self->throw_exception( "Can't update ${self}: row not found" );
161   } elsif ($rows > 1) {
162     $self->throw_exception("Can't update ${self}: updated more than one row");
163   }
164   $self->{_dirty_columns} = {};
165   $self->{related_resultsets} = {};
166   undef $self->{_orig_ident};
167   return $self;
168 }
169
170 =head2 delete
171
172   $obj->delete
173
174 Deletes the object from the database. The object is still perfectly
175 usable, but C<< ->in_storage() >> will now return 0 and the object must
176 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
177 on it. If you delete an object in a class with a C<has_many>
178 relationship, all the related objects will be deleted as well. To turn
179 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
180 hashref. Any database-level cascade or restrict will take precedence
181 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
182
183 =cut
184
185 sub delete {
186   my $self = shift;
187   if (ref $self) {
188     $self->throw_exception( "Not in database" ) unless $self->in_storage;
189     my $ident_cond = $self->ident_condition;
190     $self->throw_exception("Cannot safely delete a row in a PK-less table")
191       if ! keys %$ident_cond;
192     foreach my $column (keys %$ident_cond) {
193             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
194               unless exists $self->{_column_data}{$column};
195     }
196     $self->result_source->storage->delete(
197       $self->result_source->from, $ident_cond);
198     $self->in_storage(undef);
199   } else {
200     $self->throw_exception("Can't do class delete without a ResultSource instance")
201       unless $self->can('result_source_instance');
202     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
203     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
204     $self->result_source_instance->resultset->search(@_)->delete;
205   }
206   return $self;
207 }
208
209 =head2 get_column
210
211   my $val = $obj->get_column($col);
212
213 Gets a column value from a row object. Does not do any queries; the column 
214 must have already been fetched from the database and stored in the object. If 
215 there is an inflated value stored that has not yet been deflated, it is deflated
216 when the method is invoked.
217
218 =cut
219
220 sub get_column {
221   my ($self, $column) = @_;
222   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
223   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
224   if (exists $self->{_inflated_column}{$column}) {
225     return $self->store_column($column,
226       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
227   }
228   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
229   return undef;
230 }
231
232 =head2 has_column_loaded
233
234   if ( $obj->has_column_loaded($col) ) {
235      print "$col has been loaded from db";
236   }
237
238 Returns a true value if the column value has been loaded from the
239 database (or set locally).
240
241 =cut
242
243 sub has_column_loaded {
244   my ($self, $column) = @_;
245   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
246   return 1 if exists $self->{_inflated_column}{$column};
247   return exists $self->{_column_data}{$column};
248 }
249
250 =head2 get_columns
251
252   my %data = $obj->get_columns;
253
254 Does C<get_column>, for all column values at once.
255
256 =cut
257
258 sub get_columns {
259   my $self = shift;
260   if (exists $self->{_inflated_column}) {
261     foreach my $col (keys %{$self->{_inflated_column}}) {
262       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
263         unless exists $self->{_column_data}{$col};
264     }
265   }
266   return %{$self->{_column_data}};
267 }
268
269 =head2 get_dirty_columns
270
271   my %data = $obj->get_dirty_columns;
272
273 Identical to get_columns but only returns those that have been changed.
274
275 =cut
276
277 sub get_dirty_columns {
278   my $self = shift;
279   return map { $_ => $self->{_column_data}{$_} }
280            keys %{$self->{_dirty_columns}};
281 }
282
283 =head2 set_column
284
285   $obj->set_column($col => $val);
286
287 Sets a column value. If the new value is different from the old one,
288 the column is marked as dirty for when you next call $obj->update.
289
290 =cut
291
292 sub set_column {
293   my $self = shift;
294   my ($column) = @_;
295   $self->{_orig_ident} ||= $self->ident_condition;
296   my $old = $self->get_column($column);
297   my $ret = $self->store_column(@_);
298   $self->{_dirty_columns}{$column} = 1
299     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
300   return $ret;
301 }
302
303 =head2 set_columns
304
305   my $copy = $orig->set_columns({ $col => $val, ... });
306
307 Sets more than one column value at once.
308
309 =cut
310
311 sub set_columns {
312   my ($self,$data) = @_;
313   foreach my $col (keys %$data) {
314     $self->set_column($col,$data->{$col});
315   }
316   return $self;
317 }
318
319 =head2 copy
320
321   my $copy = $orig->copy({ change => $to, ... });
322
323 Inserts a new row with the specified changes.
324
325 =cut
326
327 sub copy {
328   my ($self, $changes) = @_;
329   $changes ||= {};
330   my $col_data = { %{$self->{_column_data}} };
331   foreach my $col (keys %$col_data) {
332     delete $col_data->{$col}
333       if $self->result_source->column_info($col)->{is_auto_increment};
334   }
335
336   my $new = { _column_data => $col_data };
337   bless $new, ref $self;
338
339   $new->result_source($self->result_source);
340   $new->set_columns($changes);
341   $new->insert;
342   foreach my $rel ($self->result_source->relationships) {
343     my $rel_info = $self->result_source->relationship_info($rel);
344     if ($rel_info->{attrs}{cascade_copy}) {
345       my $resolved = $self->result_source->resolve_condition(
346        $rel_info->{cond}, $rel, $new);
347       foreach my $related ($self->search_related($rel)) {
348         $related->copy($resolved);
349       }
350     }
351   }
352   return $new;
353 }
354
355 =head2 store_column
356
357   $obj->store_column($col => $val);
358
359 Sets a column value without marking it as dirty.
360
361 =cut
362
363 sub store_column {
364   my ($self, $column, $value) = @_;
365   $self->throw_exception( "No such column '${column}'" )
366     unless exists $self->{_column_data}{$column} || $self->has_column($column);
367   $self->throw_exception( "set_column called for ${column} without value" )
368     if @_ < 3;
369   return $self->{_column_data}{$column} = $value;
370 }
371
372 =head2 inflate_result
373
374   Class->inflate_result($result_source, \%me, \%prefetch?)
375
376 Called by ResultSet to inflate a result from storage
377
378 =cut
379
380 sub inflate_result {
381   my ($class, $source, $me, $prefetch) = @_;
382   #use Data::Dumper; print Dumper(@_);
383   my $new = {
384     result_source => $source,
385     _column_data => $me,
386     _in_storage => 1
387   };
388   bless $new, (ref $class || $class);
389
390   my $schema;
391   foreach my $pre (keys %{$prefetch||{}}) {
392     my $pre_val = $prefetch->{$pre};
393     my $pre_source = $source->related_source($pre);
394     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
395       unless $pre_source;
396     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
397       my @pre_objects;
398       foreach my $pre_rec (@$pre_val) {
399         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
400            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
401           next;
402         }
403         push(@pre_objects, $pre_source->result_class->inflate_result(
404                              $pre_source, @{$pre_rec}));
405       }
406       $new->related_resultset($pre)->set_cache(\@pre_objects);
407     } elsif (defined $pre_val->[0]) {
408       my $fetched;
409       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
410          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
411       {
412         $fetched = $pre_source->result_class->inflate_result(
413                       $pre_source, @{$pre_val});
414       }
415       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
416       $class->throw_exception("No accessor for prefetched $pre")
417        unless defined $accessor;
418       if ($accessor eq 'single') {
419         $new->{_relationship_data}{$pre} = $fetched;
420       } elsif ($accessor eq 'filter') {
421         $new->{_inflated_column}{$pre} = $fetched;
422       } else {
423        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
424       }
425     }
426   }
427   return $new;
428 }
429
430 =head2 update_or_insert
431
432   $obj->update_or_insert
433
434 Updates the object if it's already in the db, else inserts it.
435
436 =head2 insert_or_update
437
438   $obj->insert_or_update
439
440 Alias for L</update_or_insert>
441
442 =cut
443
444 *insert_or_update = \&update_or_insert;
445 sub update_or_insert {
446   my $self = shift;
447   return ($self->in_storage ? $self->update : $self->insert);
448 }
449
450 =head2 is_changed
451
452   my @changed_col_names = $obj->is_changed();
453   if ($obj->is_changed()) { ... }
454
455 In array context returns a list of columns with uncommited changes, or
456 in scalar context returns a true value if there are uncommitted
457 changes.
458
459 =cut
460
461 sub is_changed {
462   return keys %{shift->{_dirty_columns} || {}};
463 }
464
465 =head2 is_column_changed
466
467   if ($obj->is_column_changed('col')) { ... }
468
469 Returns a true value if the column has uncommitted changes.
470
471 =cut
472
473 sub is_column_changed {
474   my( $self, $col ) = @_;
475   return exists $self->{_dirty_columns}->{$col};
476 }
477
478 =head2 result_source
479
480   my $resultsource = $object->result_source;
481
482 Accessor to the ResultSource this object was created from
483
484 =head2 register_column
485
486   $column_info = { .... };
487   $class->register_column($column_name, $column_info);
488
489 Registers a column on the class. If the column_info has an 'accessor'
490 key, creates an accessor named after the value if defined; if there is
491 no such key, creates an accessor with the same name as the column
492
493 The column_info attributes are described in
494 L<DBIx::Class::ResultSource/add_columns>
495
496 =cut
497
498 sub register_column {
499   my ($class, $col, $info) = @_;
500   my $acc = $col;
501   if (exists $info->{accessor}) {
502     return unless defined $info->{accessor};
503     $acc = [ $info->{accessor}, $col ];
504   }
505   $class->mk_group_accessors('column' => $acc);
506 }
507
508
509 =head2 throw_exception
510
511 See Schema's throw_exception.
512
513 =cut
514
515 sub throw_exception {
516   my $self=shift;
517   if (ref $self && ref $self->result_source) {
518     $self->result_source->schema->throw_exception(@_);
519   } else {
520     croak(@_);
521   }
522 }
523
524 1;
525
526 =head1 AUTHORS
527
528 Matt S. Trout <mst@shadowcatsystems.co.uk>
529
530 =head1 LICENSE
531
532 You may distribute this code under the same terms as Perl itself.
533
534 =cut