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