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