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