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