ResultSetColumn::func() now returns all results if called in list context
[dbsrgits/DBIx-Class-Historic.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 use Scalar::Util ();
9 use Scope::Guard;
10
11 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
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 Passing an object, or an arrayref of objects as a value will call
33 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
34 passed a hashref or an arrayref of hashrefs as the value, these will
35 be turned into objects via new_related, and treated as if you had
36 passed objects.
37
38 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
39
40 =cut
41
42 ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
43 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
44 ## When doing the later insert, we need to make sure the PKs are set.
45 ## using _relationship_data in new and funky ways..
46 ## check Relationship::CascadeActions and Relationship::Accessor for compat
47 ## tests!
48
49 sub new {
50   my ($class, $attrs) = @_;
51   $class = ref $class if ref $class;
52
53   my $new = { _column_data => {} };
54   bless $new, $class;
55
56   if (my $handle = delete $attrs->{-source_handle}) {
57     $new->_source_handle($handle);
58   }
59   if (my $source = delete $attrs->{-result_source}) {
60     $new->result_source($source);
61   }
62
63   if ($attrs) {
64     $new->throw_exception("attrs must be a hashref")
65       unless ref($attrs) eq 'HASH';
66     
67     my ($related,$inflated);
68     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
69     $new->{_rel_in_storage} = 1;
70
71     foreach my $key (keys %$attrs) {
72       if (ref $attrs->{$key}) {
73         ## Can we extract this lot to use with update(_or .. ) ?
74         my $info = $class->relationship_info($key);
75         if ($info && $info->{attrs}{accessor}
76           && $info->{attrs}{accessor} eq 'single')
77         {
78           my $rel_obj = delete $attrs->{$key};
79           if(!Scalar::Util::blessed($rel_obj)) {
80             $rel_obj = $new->find_or_new_related($key, $rel_obj);
81           }
82
83           $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
84
85           $new->set_from_related($key, $rel_obj);        
86           $related->{$key} = $rel_obj;
87           next;
88         } elsif ($info && $info->{attrs}{accessor}
89             && $info->{attrs}{accessor} eq 'multi'
90             && ref $attrs->{$key} eq 'ARRAY') {
91           my $others = delete $attrs->{$key};
92           foreach my $rel_obj (@$others) {
93             if(!Scalar::Util::blessed($rel_obj)) {
94               $rel_obj = $new->new_related($key, $rel_obj);
95               $new->{_rel_in_storage} = 0;
96             }
97
98             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
99           }
100           $related->{$key} = $others;
101           next;
102         } elsif ($info && $info->{attrs}{accessor}
103           && $info->{attrs}{accessor} eq 'filter')
104         {
105           ## 'filter' should disappear and get merged in with 'single' above!
106           my $rel_obj = delete $attrs->{$key};
107           if(!Scalar::Util::blessed($rel_obj)) {
108             $rel_obj = $new->find_or_new_related($key, $rel_obj);
109             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
110           }
111           $inflated->{$key} = $rel_obj;
112           next;
113         } elsif ($class->has_column($key)
114             && $class->column_info($key)->{_inflate_info}) {
115           $inflated->{$key} = $attrs->{$key};
116           next;
117         }
118       }
119       use Data::Dumper;
120       $new->throw_exception("No such column $key on $class")
121         unless $class->has_column($key);
122       $new->store_column($key => $attrs->{$key});          
123     }
124
125     $new->{_relationship_data} = $related if $related;
126     $new->{_inflated_column} = $inflated if $inflated;
127   }
128
129   return $new;
130 }
131
132 =head2 insert
133
134   $obj->insert;
135
136 Inserts an object into the database if it isn't already in
137 there. Returns the object itself. Requires the object's result source to
138 be set, or the class to have a result_source_instance method. To insert
139 an entirely new object into the database, use C<create> (see
140 L<DBIx::Class::ResultSet/create>).
141
142 This will also insert any uninserted, related objects held inside this
143 one, see L<DBIx::Class::ResultSet/create> for more details.
144
145 =cut
146
147 sub insert {
148   my ($self) = @_;
149   return $self if $self->in_storage;
150   my $source = $self->result_source;
151   $source ||=  $self->result_source($self->result_source_instance)
152     if $self->can('result_source_instance');
153   $self->throw_exception("No result_source set on this object; can't insert")
154     unless $source;
155
156   my $rollback_guard;
157
158   # Check if we stored uninserted relobjs here in new()
159   my %related_stuff = (%{$self->{_relationship_data} || {}}, 
160                        %{$self->{_inflated_column} || {}});
161
162   if(!$self->{_rel_in_storage}) {
163     $source->storage->txn_begin;
164
165     # The guard will save us if we blow out of this scope via die
166
167     $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
168
169     ## Should all be in relationship_data, but we need to get rid of the
170     ## 'filter' reltype..
171     ## These are the FK rels, need their IDs for the insert.
172
173     my @pri = $self->primary_columns;
174
175     REL: foreach my $relname (keys %related_stuff) {
176
177       my $rel_obj = $related_stuff{$relname};
178
179       next REL unless (Scalar::Util::blessed($rel_obj)
180                        && $rel_obj->isa('DBIx::Class::Row'));
181
182       my $cond = $source->relationship_info($relname)->{cond};
183
184       next REL unless ref($cond) eq 'HASH';
185
186       # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
187
188       my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
189
190       # assume anything that references our PK probably is dependent on us
191       # rather than vice versa, unless the far side is (a) defined or (b)
192       # auto-increment
193
194       foreach my $p (@pri) {
195         if (exists $keyhash->{$p}) {
196           unless (defined($rel_obj->get_column($keyhash->{$p}))
197                   || $rel_obj->column_info($keyhash->{$p})
198                              ->{is_auto_increment}) {
199             next REL;
200           }
201         }
202       }
203
204       $rel_obj->insert();
205       $self->set_from_related($relname, $rel_obj);
206       delete $related_stuff{$relname};
207     }
208   }
209
210   $source->storage->insert($source, { $self->get_columns });
211
212   ## PK::Auto
213   my @auto_pri = grep {
214                    !defined $self->get_column($_) || 
215                    ref($self->get_column($_)) eq 'SCALAR'
216                  } $self->primary_columns;
217
218   if (@auto_pri) {
219     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
220     #  if defined $too_many;
221
222     my $storage = $self->result_source->storage;
223     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
224       unless $storage->can('last_insert_id');
225     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
226     $self->throw_exception( "Can't get last insert id" )
227       unless (@ids == @auto_pri);
228     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
229   }
230
231   if(!$self->{_rel_in_storage}) {
232     ## Now do the has_many rels, that need $selfs ID.
233     foreach my $relname (keys %related_stuff) {
234       my $rel_obj = $related_stuff{$relname};
235       my @cands;
236       if (Scalar::Util::blessed($rel_obj)
237           && $rel_obj->isa('DBIx::Class::Row')) {
238         @cands = ($rel_obj);
239       } elsif (ref $rel_obj eq 'ARRAY') {
240         @cands = @$rel_obj;
241       }
242       if (@cands) {
243         my $reverse = $source->reverse_relationship_info($relname);
244         foreach my $obj (@cands) {
245           $obj->set_from_related($_, $self) for keys %$reverse;
246           $obj->insert() if(!$obj->in_storage);
247         }
248       }
249     }
250     $source->storage->txn_commit;
251     $rollback_guard->dismiss;
252   }
253
254   $self->in_storage(1);
255   $self->{_dirty_columns} = {};
256   $self->{related_resultsets} = {};
257   undef $self->{_orig_ident};
258   return $self;
259 }
260
261 =head2 in_storage
262
263   $obj->in_storage; # Get value
264   $obj->in_storage(1); # Set value
265
266 Indicates whether the object exists as a row in the database or not
267
268 =cut
269
270 sub in_storage {
271   my ($self, $val) = @_;
272   $self->{_in_storage} = $val if @_ > 1;
273   return $self->{_in_storage};
274 }
275
276 =head2 update
277
278   $obj->update \%columns?;
279
280 Must be run on an object that is already in the database; issues an SQL
281 UPDATE query to commit any changes to the object to the database if
282 required.
283
284 Also takes an options hashref of C<< column_name => value> pairs >> to update
285 first. But be aware that this hashref might be edited in place, so dont rely on
286 it being the same after a call to C<update>. If you need to preserve the hashref,
287 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
288
289 =cut
290
291 sub update {
292   my ($self, $upd) = @_;
293   $self->throw_exception( "Not in database" ) unless $self->in_storage;
294   my $ident_cond = $self->ident_condition;
295   $self->throw_exception("Cannot safely update a row in a PK-less table")
296     if ! keys %$ident_cond;
297
298   if ($upd) {
299     foreach my $key (keys %$upd) {
300       if (ref $upd->{$key}) {
301         my $info = $self->relationship_info($key);
302         if ($info && $info->{attrs}{accessor}
303           && $info->{attrs}{accessor} eq 'single')
304         {
305           my $rel = delete $upd->{$key};
306           $self->set_from_related($key => $rel);
307           $self->{_relationship_data}{$key} = $rel;          
308         } elsif ($info && $info->{attrs}{accessor}
309             && $info->{attrs}{accessor} eq 'multi'
310             && ref $upd->{$key} eq 'ARRAY') {
311             my $others = delete $upd->{$key};
312             foreach my $rel_obj (@$others) {
313               if(!Scalar::Util::blessed($rel_obj)) {
314                 $rel_obj = $self->create_related($key, $rel_obj);
315               }
316             }
317             $self->{_relationship_data}{$key} = $others; 
318 #            $related->{$key} = $others;
319             next;
320         }
321         elsif ($self->has_column($key)
322           && exists $self->column_info($key)->{_inflate_info})
323         {
324           $self->set_inflated_column($key, delete $upd->{$key});          
325         }
326       }
327     }
328     $self->set_columns($upd);    
329   }
330   my %to_update = $self->get_dirty_columns;
331   return $self unless keys %to_update;
332   my $rows = $self->result_source->storage->update(
333                $self->result_source, \%to_update,
334                $self->{_orig_ident} || $ident_cond
335              );
336   if ($rows == 0) {
337     $self->throw_exception( "Can't update ${self}: row not found" );
338   } elsif ($rows > 1) {
339     $self->throw_exception("Can't update ${self}: updated more than one row");
340   }
341   $self->{_dirty_columns} = {};
342   $self->{related_resultsets} = {};
343   undef $self->{_orig_ident};
344   return $self;
345 }
346
347 =head2 delete
348
349   $obj->delete
350
351 Deletes the object from the database. The object is still perfectly
352 usable, but C<< ->in_storage() >> will now return 0 and the object must
353 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
354 on it. If you delete an object in a class with a C<has_many>
355 relationship, all the related objects will be deleted as well. To turn
356 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
357 hashref. Any database-level cascade or restrict will take precedence
358 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
359
360 =cut
361
362 sub delete {
363   my $self = shift;
364   if (ref $self) {
365     $self->throw_exception( "Not in database" ) unless $self->in_storage;
366     my $ident_cond = $self->ident_condition;
367     $self->throw_exception("Cannot safely delete a row in a PK-less table")
368       if ! keys %$ident_cond;
369     foreach my $column (keys %$ident_cond) {
370             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
371               unless exists $self->{_column_data}{$column};
372     }
373     $self->result_source->storage->delete(
374       $self->result_source, $ident_cond);
375     $self->in_storage(undef);
376   } else {
377     $self->throw_exception("Can't do class delete without a ResultSource instance")
378       unless $self->can('result_source_instance');
379     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
380     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
381     $self->result_source_instance->resultset->search(@_)->delete;
382   }
383   return $self;
384 }
385
386 =head2 get_column
387
388   my $val = $obj->get_column($col);
389
390 Gets a column value from a row object. Does not do any queries; the column 
391 must have already been fetched from the database and stored in the object. If 
392 there is an inflated value stored that has not yet been deflated, it is deflated
393 when the method is invoked.
394
395 =cut
396
397 sub get_column {
398   my ($self, $column) = @_;
399   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
400   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
401   if (exists $self->{_inflated_column}{$column}) {
402     return $self->store_column($column,
403       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
404   }
405   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
406   return undef;
407 }
408
409 =head2 has_column_loaded
410
411   if ( $obj->has_column_loaded($col) ) {
412      print "$col has been loaded from db";
413   }
414
415 Returns a true value if the column value has been loaded from the
416 database (or set locally).
417
418 =cut
419
420 sub has_column_loaded {
421   my ($self, $column) = @_;
422   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
423   return 1 if exists $self->{_inflated_column}{$column};
424   return exists $self->{_column_data}{$column};
425 }
426
427 =head2 get_columns
428
429   my %data = $obj->get_columns;
430
431 Does C<get_column>, for all column values at once.
432
433 =cut
434
435 sub get_columns {
436   my $self = shift;
437   if (exists $self->{_inflated_column}) {
438     foreach my $col (keys %{$self->{_inflated_column}}) {
439       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
440         unless exists $self->{_column_data}{$col};
441     }
442   }
443   return %{$self->{_column_data}};
444 }
445
446 =head2 get_dirty_columns
447
448   my %data = $obj->get_dirty_columns;
449
450 Identical to get_columns but only returns those that have been changed.
451
452 =cut
453
454 sub get_dirty_columns {
455   my $self = shift;
456   return map { $_ => $self->{_column_data}{$_} }
457            keys %{$self->{_dirty_columns}};
458 }
459
460 =head2 get_inflated_columns
461
462   my $inflated_data = $obj->get_inflated_columns;
463
464 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
465
466 =cut
467
468 sub get_inflated_columns {
469   my $self = shift;
470   return map {
471     my $accessor = $self->column_info($_)->{'accessor'} || $_;
472     ($_ => $self->$accessor);
473   } $self->columns;
474 }
475
476 =head2 set_column
477
478   $obj->set_column($col => $val);
479
480 Sets a column value. If the new value is different from the old one,
481 the column is marked as dirty for when you next call $obj->update.
482
483 =cut
484
485 sub set_column {
486   my $self = shift;
487   my ($column) = @_;
488   $self->{_orig_ident} ||= $self->ident_condition;
489   my $old = $self->get_column($column);
490   my $ret = $self->store_column(@_);
491   $self->{_dirty_columns}{$column} = 1
492     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
493   return $ret;
494 }
495
496 =head2 set_columns
497
498   my $copy = $orig->set_columns({ $col => $val, ... });
499
500 Sets more than one column value at once.
501
502 =cut
503
504 sub set_columns {
505   my ($self,$data) = @_;
506   foreach my $col (keys %$data) {
507     $self->set_column($col,$data->{$col});
508   }
509   return $self;
510 }
511
512 =head2 copy
513
514   my $copy = $orig->copy({ change => $to, ... });
515
516 Inserts a new row with the specified changes.
517
518 =cut
519
520 sub copy {
521   my ($self, $changes) = @_;
522   $changes ||= {};
523   my $col_data = { %{$self->{_column_data}} };
524   foreach my $col (keys %$col_data) {
525     delete $col_data->{$col}
526       if $self->result_source->column_info($col)->{is_auto_increment};
527   }
528
529   my $new = { _column_data => $col_data };
530   bless $new, ref $self;
531
532   $new->result_source($self->result_source);
533   $new->set_columns($changes);
534   $new->insert;
535   foreach my $rel ($self->result_source->relationships) {
536     my $rel_info = $self->result_source->relationship_info($rel);
537     if ($rel_info->{attrs}{cascade_copy}) {
538       my $resolved = $self->result_source->resolve_condition(
539        $rel_info->{cond}, $rel, $new);
540       foreach my $related ($self->search_related($rel)) {
541         $related->copy($resolved);
542       }
543     }
544   }
545   return $new;
546 }
547
548 =head2 store_column
549
550   $obj->store_column($col => $val);
551
552 Sets a column value without marking it as dirty.
553
554 =cut
555
556 sub store_column {
557   my ($self, $column, $value) = @_;
558   $self->throw_exception( "No such column '${column}'" )
559     unless exists $self->{_column_data}{$column} || $self->has_column($column);
560   $self->throw_exception( "set_column called for ${column} without value" )
561     if @_ < 3;
562   return $self->{_column_data}{$column} = $value;
563 }
564
565 =head2 inflate_result
566
567   Class->inflate_result($result_source, \%me, \%prefetch?)
568
569 Called by ResultSet to inflate a result from storage
570
571 =cut
572
573 sub inflate_result {
574   my ($class, $source, $me, $prefetch) = @_;
575
576   my ($source_handle) = $source;
577
578   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
579       $source = $source_handle->resolve
580   } else {
581       $source_handle = $source->handle
582   }
583
584   my $new = {
585     _source_handle => $source_handle,
586     _column_data => $me,
587     _in_storage => 1
588   };
589   bless $new, (ref $class || $class);
590
591   my $schema;
592   foreach my $pre (keys %{$prefetch||{}}) {
593     my $pre_val = $prefetch->{$pre};
594     my $pre_source = $source->related_source($pre);
595     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
596       unless $pre_source;
597     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
598       my @pre_objects;
599       foreach my $pre_rec (@$pre_val) {
600         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
601            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
602           next;
603         }
604         push(@pre_objects, $pre_source->result_class->inflate_result(
605                              $pre_source, @{$pre_rec}));
606       }
607       $new->related_resultset($pre)->set_cache(\@pre_objects);
608     } elsif (defined $pre_val->[0]) {
609       my $fetched;
610       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
611          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
612       {
613         $fetched = $pre_source->result_class->inflate_result(
614                       $pre_source, @{$pre_val});
615       }
616       $new->related_resultset($pre)->set_cache([ $fetched ]);
617       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
618       $class->throw_exception("No accessor for prefetched $pre")
619        unless defined $accessor;
620       if ($accessor eq 'single') {
621         $new->{_relationship_data}{$pre} = $fetched;
622       } elsif ($accessor eq 'filter') {
623         $new->{_inflated_column}{$pre} = $fetched;
624       } else {
625        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
626       }
627     }
628   }
629   return $new;
630 }
631
632 =head2 update_or_insert
633
634   $obj->update_or_insert
635
636 Updates the object if it's already in the db, else inserts it.
637
638 =head2 insert_or_update
639
640   $obj->insert_or_update
641
642 Alias for L</update_or_insert>
643
644 =cut
645
646 *insert_or_update = \&update_or_insert;
647 sub update_or_insert {
648   my $self = shift;
649   return ($self->in_storage ? $self->update : $self->insert);
650 }
651
652 =head2 is_changed
653
654   my @changed_col_names = $obj->is_changed();
655   if ($obj->is_changed()) { ... }
656
657 In array context returns a list of columns with uncommited changes, or
658 in scalar context returns a true value if there are uncommitted
659 changes.
660
661 =cut
662
663 sub is_changed {
664   return keys %{shift->{_dirty_columns} || {}};
665 }
666
667 =head2 is_column_changed
668
669   if ($obj->is_column_changed('col')) { ... }
670
671 Returns a true value if the column has uncommitted changes.
672
673 =cut
674
675 sub is_column_changed {
676   my( $self, $col ) = @_;
677   return exists $self->{_dirty_columns}->{$col};
678 }
679
680 =head2 result_source
681
682   my $resultsource = $object->result_source;
683
684 Accessor to the ResultSource this object was created from
685
686 =cut
687
688 sub result_source {
689     my $self = shift;
690
691     if (@_) {
692         $self->_source_handle($_[0]->handle);
693     } else {
694         $self->_source_handle->resolve;
695     }
696 }
697
698 =head2 register_column
699
700   $column_info = { .... };
701   $class->register_column($column_name, $column_info);
702
703 Registers a column on the class. If the column_info has an 'accessor'
704 key, creates an accessor named after the value if defined; if there is
705 no such key, creates an accessor with the same name as the column
706
707 The column_info attributes are described in
708 L<DBIx::Class::ResultSource/add_columns>
709
710 =cut
711
712 sub register_column {
713   my ($class, $col, $info) = @_;
714   my $acc = $col;
715   if (exists $info->{accessor}) {
716     return unless defined $info->{accessor};
717     $acc = [ $info->{accessor}, $col ];
718   }
719   $class->mk_group_accessors('column' => $acc);
720 }
721
722
723 =head2 throw_exception
724
725 See Schema's throw_exception.
726
727 =cut
728
729 sub throw_exception {
730   my $self=shift;
731   if (ref $self && ref $self->result_source && $self->result_source->schema) {
732     $self->result_source->schema->throw_exception(@_);
733   } else {
734     croak(@_);
735   }
736 }
737
738 1;
739
740 =head1 AUTHORS
741
742 Matt S. Trout <mst@shadowcatsystems.co.uk>
743
744 =head1 LICENSE
745
746 You may distribute this code under the same terms as Perl itself.
747
748 =cut