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